X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FGenerate.hs;h=48b56169241214dccd82cf574bddf28929fcc86a;hb=cf53d927025a818188af17622903df33ade92ff8;hp=0e147b369c8fd77159908907f1a95f9fb18e23e7;hpb=d94fff8d7e24f6518588786141e0ba08d3141ea7;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 0e147b3..48b5616 100644
--- "a/c\316\273ash/CLasH/VHDL/Generate.hs"
+++ "b/c\316\273ash/CLasH/VHDL/Generate.hs"
@@ -44,15 +44,15 @@ getEntity ::
 
 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
+      -- Split the normalized expression
+      let (args, binds, res) = Normalize.splitNormalized expr
       -- 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
       res' <- mkMap res
-      let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
+      count <- getA tsEntityCounter 
+      let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
+      putA tsEntityCounter (count + 1)
       let ent_decl = createEntityAST vhdl_id args' res'
       let signature = Entity vhdl_id args' res' ent_decl
       return signature
@@ -111,12 +111,12 @@ getArchitecture ::
 
 getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
   expr <- Normalize.getNormalized fname
+  -- Split the normalized expression
+  let (args, binds, res) = Normalize.splitNormalized expr
+  
+  -- Get the entity for this function
   signature <- getEntity fname
   let entity_id = ent_id signature
-  -- Strip off lambda's, these will be arguments
-  let (args, letexpr) = CoreSyn.collectBinders expr
-  -- There must be a let at top level 
-  let (CoreSyn.Let (CoreSyn.Rec binds) (CoreSyn.Var res)) = letexpr
 
   -- Create signal declarations for all binders in the let expression, except
   -- for the output port (that will already have an output port declared in
@@ -129,9 +129,9 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
   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)]
-        ([], []) -> []
+  state_proc <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
+        ([in_state], [out_state]) -> mkStateProcSm (in_state, out_state)
+        ([], []) -> return []
         (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
@@ -144,12 +144,12 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
               -> 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
+    dobind (bndr, unpacked@(CoreSyn.Cast packed coercion)) 
+      | hasStateType packed && not (hasStateType unpacked)
       = return ((Just bndr, Nothing), ([], []))
     -- With simplCore, newtype packing is just a cast
-    dobind (bndr, expr@(CoreSyn.Cast (CoreSyn.Var state) coercion)) 
-      | hasStateType expr
+    dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion)) 
+      | hasStateType packed && not (hasStateType unpacked)
       = 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))) 
@@ -162,9 +162,12 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
 
 mkStateProcSm :: 
   (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
-  -> AST.ProcSm -- ^ The resulting statement
-mkStateProcSm (old, new) =
-  AST.ProcSm label [clk] [statement]
+  -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements
+mkStateProcSm (old, new) = do
+  nonempty <- hasNonEmptyType old 
+  if nonempty 
+    then return [AST.CSPSm $ AST.ProcSm label [clk] [statement]]
+    else return []
   where
     label       = mkVHDLBasicId $ "state"
     clk         = mkVHDLBasicId "clock"
@@ -860,7 +863,7 @@ genApplication dst f args = do
           let entity_id = ent_id signature
           -- TODO: Using show here isn't really pretty, but we'll need some
           -- unique-ish value...
-          let label = "comp_ins_" ++ (either show prettyShow) dst
+          let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
           let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
           return ([mkComponentInst label entity_id portmaps], [f])
         False -> do