Filter out empty-typed binders in selector 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 431f3794dd01465f59937dbb16c65b58fdda051f..5386e7e61b698a0681830ffc9b4b14c2c9c1e67f 100644 (file)
--- a/cλash/CLasH/VHDL/Generate.hs
+++ b/cλash/CLasH/VHDL/Generate.hs
@@ -160,10 +160,14 @@ 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
+      bndrs' <- Monad.filterM hasNonEmptyType bndrs
+      case List.elemIndex sel_bndr bndrs' of
         Just i -> do
           labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
           let label = labels!!i
@@ -196,11 +200,24 @@ mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let exp
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be expressions.
 genExprArgs wrap dst func args = do
-  args' <- eitherCoreOrExprArgs args
+  args' <- argsToVHDLExprs args
   wrap dst func args'
 
-eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
-eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift tsType) . varToVHDLExpr . exprToVar) return) args
+-- | Turn the all lefts into VHDL Expressions.
+argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
+argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
+
+argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
+argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
+  let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
+  ty_maybe <- vhdl_ty errmsg expr
+  case ty_maybe of
+    Just _ -> do
+      vhdl_expr <- varToVHDLExpr $ exprToVar expr
+      return $ Just vhdl_expr
+    Nothing -> return $ Nothing
+
+argToVHDLExpr (Right expr) = return $ Just expr
 
 -- A function to wrap a builder-like function that generates no component
 -- instantiations
@@ -770,12 +787,12 @@ genApplication dst f args = do
           -- Local binder that references a top level binding.  Generate a
           -- component instantiation.
           signature <- getEntity f
-          args' <- eitherCoreOrExprArgs args
+          args' <- argsToVHDLExprs args
           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 portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
+          portmaps <- mkAssocElems args' ((either varToVHDLName id) dst) signature
           return ([mkComponentInst label entity_id portmaps], [f])
         False -> do
           -- Not a top level binder, so this must be a local variable reference.
@@ -791,7 +808,7 @@ genApplication dst f args = do
           Left bndr -> do
             -- We have the bndr, so we can get at the type
             labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
-            args' <- eitherCoreOrExprArgs args
+            args' <- argsToVHDLExprs args
             return $ (zipWith mkassign labels $ args', [])
             where
               mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm