Don't generate VHDL for substate extractor cases.

[matthijs/master-project/cλash.git] / cλash / CLasH / VHDL / Generate.hs

diff --git a/cλash/CLasH/VHDL/Generate.hs b/cλash/CLasH/VHDL/Generate.hs
index 5360cff1234cc226039dc2a25881bf7aa7e8b9ea..5698ef89a6efe29503b4c263b524c288a46f0016 100644 (file)
--- a/cλash/CLasH/VHDL/Generate.hs
+++ b/cλash/CLasH/VHDL/Generate.hs
@@ -28,7 +28,7 @@ import CLasH.Translator.TranslatorTypes
 import CLasH.VHDL.Constants
 import CLasH.VHDL.VHDLTypes
 import CLasH.VHDL.VHDLTools
-import qualified CLasH.Utils as Utils
+import CLasH.Utils as Utils
 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.Pretty
 import qualified CLasH.Normalize as Normalize
@@ -46,10 +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
-      args' <- mapM mkMap args
+      -- Generate ports for all non-state types
+      args' <- catMaybesM $ mapM mkMap args
       -- There must be a let at top level 
       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
-      res' <- mkMap res
+      -- TODO: Handle Nothing
+      Just 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
@@ -58,7 +60,7 @@ getEntity fname = Utils.makeCached fname tsEntities $ do
     mkMap ::
       --[(SignalId, SignalInfo)] 
       CoreSyn.CoreBndr 
-      -> TranslatorSession Port
+      -> TranslatorSession (Maybe Port)
     mkMap = (\bndr ->
       let
         --info = Maybe.fromMaybe
@@ -69,8 +71,10 @@ getEntity fname = Utils.makeCached fname tsEntities $ do
         ty = Var.varType bndr
         error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr 
       in do
-        type_mark <- MonadState.lift tsType $ vhdl_ty error_msg ty
-        return (id, type_mark)
+        type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg ty
+        case type_mark_maybe of 
+          Just type_mark -> return $ Just (id, type_mark)
+          Nothing -> return Nothing
      )
 
 -- | Create the VHDL AST for an entity
@@ -156,7 +160,10 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do
 -- A single alt case must be a selector. This means thee scrutinee is a simple
 -- variable, the alternative is a dataalt with a single non-wild binder that
 -- is also returned.
-mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) =
+mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) 
+                -- Don't generate VHDL for substate extraction
+                | hasStateType bndr = return ([], [])
+                | otherwise =
   case alt of
     (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
       case List.elemIndex sel_bndr bndrs of
@@ -485,7 +492,8 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do
   -- temporary vector
   let tmp_ty = Type.mkAppTy nvec (Var.varType start)
   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
-  tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
+  -- TODO: Handle Nothing
+  Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
   -- Setup the generate scheme
   let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
   let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
@@ -687,7 +695,8 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
   -- -- temporary vector
   let tmp_ty = Var.varType res
   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
-  tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
+  -- TODO: Handle Nothing
+  Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
   -- Setup the generate scheme
   let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
   let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
@@ -778,7 +787,7 @@ genApplication dst f args = do
           -- assignment here.
           f' <- MonadState.lift tsType $ varToVHDLExpr f
           return $ ([mkUncondAssign dst f'], [])
-    True ->
+    True | not stateful -> 
       case Var.idDetails f of
         IdInfo.DataConWorkId dc -> case dst of
           -- It's a datacon. Create a record from its arguments.
@@ -828,6 +837,16 @@ genApplication dst f args = do
                 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
             Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
         details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+    -- If we can't generate a component instantiation, and the destination is
+    -- a state type, don't generate anything.
+    _ -> return ([], [])
+  where
+    -- Is our destination a state value?
+    stateful = case dst of
+      -- When our destination is a VHDL name, it won't have had a state type
+      Right _ -> False
+      -- Otherwise check its type
+      Left bndr -> hasStateType bndr
 
 -----------------------------------------------------------------------------
 -- Functions to generate functions dealing with vectors.
@@ -838,7 +857,8 @@ genApplication dst f args = do
 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
 vectorFunId el_ty fname = do
   let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
-  elemTM <- vhdl_ty error_msg el_ty
+  -- TODO: Handle the Nothing case?
+  Just elemTM <- vhdl_ty error_msg el_ty
   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
   -- the VHDLState or something.
   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)