X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FGenerate.hs;h=ae4769b3842bbec5850dfe5d7fd875ac94cee797;hb=12f3011b6d8b84de55288aa15dbaf3ce8f011be4;hp=f7495408c415f95a04594df71a0ae34729d484b8;hpb=82210ea1ed3bbf1acd5cecef5bc0771e36613bf5;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs"
index f749540..ae4769b 100644
--- "a/c\316\273ash/CLasH/VHDL/Generate.hs"
+++ "b/c\316\273ash/CLasH/VHDL/Generate.hs"
@@ -46,12 +46,12 @@ getEntity fname = Utils.makeCached fname tsEntities $ do
       expr <- Normalize.getNormalized fname
       -- Strip off lambda's, these will be arguments
       let (args, letexpr) = CoreSyn.collectBinders expr
-      -- Generate ports for all non-state types
+      -- Generate ports for all non-empty types
       args' <- catMaybesM $ mapM mkMap args
       -- There must be a let at top level 
       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
       -- TODO: Handle Nothing
-      Just res' <- mkMap res
+      res' <- mkMap res
       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
       let ent_decl = createEntityAST vhdl_id args' res'
       let signature = Entity vhdl_id args' res' ent_decl
@@ -81,7 +81,7 @@ getEntity fname = Utils.makeCached fname tsEntities $ do
 createEntityAST ::
   AST.VHDLId                   -- ^ The name of the function
   -> [Port]                    -- ^ The entity's arguments
-  -> Port                      -- ^ The entity's result
+  -> Maybe Port                -- ^ The entity's result
   -> AST.EntityDec             -- ^ The entity with the ent_decl filled in as well
 
 createEntityAST vhdl_id args res =
@@ -89,15 +89,16 @@ createEntityAST vhdl_id args res =
   where
     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
     ports = map (mkIfaceSigDec AST.In) args
-              ++ [mkIfaceSigDec AST.Out res]
+              ++ (Maybe.maybeToList res_port)
               ++ [clk_port]
     -- Add a clk port if we have state
     clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
+    res_port = fmap (mkIfaceSigDec AST.Out) res
 
 -- | Create a port declaration
 mkIfaceSigDec ::
   AST.Mode                         -- ^ The mode for the port (In / Out)
-  -> (AST.VHDLId, AST.TypeMark)    -- ^ The id and type for the port
+  -> Port                          -- ^ The id and type for the port
   -> AST.IfaceSigDec               -- ^ The resulting port declaration
 
 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
@@ -120,19 +121,59 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
   -- Create signal declarations for all binders in the let expression, except
   -- for the output port (that will already have an output port declared in
   -- the entity).
-  sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
+  sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
-
-  (statementss, used_entitiess) <- Monad.mapAndUnzipM mkConcSm binds
-  let statements = concat statementss
+  -- Process each bind, resulting in info about state variables and concurrent
+  -- statements.
+  (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
+  let (in_state_maybes, out_state_maybes) = unzip state_vars
+  let (statementss, used_entitiess) = unzip sms
+  -- Create a state proc, if needed
+  let state_proc = case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
+        ([in_state], [out_state]) -> [AST.CSPSm $ mkStateProcSm (in_state, out_state)]
+        ([], []) -> []
+        (ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
+  -- Join the create statements and the (optional) state_proc
+  let statements = concat statementss ++ state_proc
+  -- Create the architecture
+  let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
   let used_entities = concat used_entitiess
-  let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
   return (arch, used_entities)
   where
-    procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
-    procs' = map AST.CSPSm procs
-    -- mkSigDec only uses tsTypes from the state
-    mkSigDec' = mkSigDec
+    dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
+              -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
+              -- ^ ((Input state variable, output state variable), (statements, used entities))
+    -- newtype unpacking is just a cast
+    dobind (bndr, (CoreSyn.Cast expr coercion)) 
+      | hasStateType expr
+      = return ((Just bndr, Nothing), ([], []))
+    -- With simplCore, newtype packing is just a cast
+    dobind (bndr, expr@(CoreSyn.Cast (CoreSyn.Var state) coercion)) 
+      | hasStateType expr
+      = return ((Nothing, Just state), ([], []))
+    -- Without simplCore, newtype packing uses a data constructor
+    dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state))) 
+      | isStateCon con
+      = return ((Nothing, Just state), ([], []))
+    -- Anything else is handled by mkConcSm
+    dobind bind = do
+      sms <- mkConcSm bind
+      return ((Nothing, Nothing), sms)
+
+mkStateProcSm :: 
+  (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
+  -> AST.ProcSm -- ^ The resulting statement
+mkStateProcSm (old, new) =
+  AST.ProcSm label [clk] [statement]
+  where
+    label       = mkVHDLBasicId $ "state"
+    clk         = mkVHDLBasicId "clock"
+    rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
+    wform       = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
+    assign      = AST.SigAssign (varToVHDLName old) wform
+    rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
+    statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
+
 
 -- | Transforms a core binding into a VHDL concurrent statement
 mkConcSm ::