Support application of dataconstructors.

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

diff --git a/VHDL.hs b/VHDL.hs
index 5f4b5833628c2805f26954f5f67fcd6ba4d16983..f0bd3c4cca75a4a1314a87e2cb47a3b02c67ecf3 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -32,6 +32,7 @@ import qualified IdInfo
 import qualified TyCon
 import qualified DataCon
 import qualified CoreSubst
+import qualified CoreUtils
 import Outputable ( showSDoc, ppr )
 
 -- Local imports
@@ -251,6 +252,25 @@ mkConcSm ::
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
   case Var.globalIdVarDetails f of
+    IdInfo.DataConWorkId dc ->
+        -- It's a datacon. Create a record from its arguments.
+        -- First, filter out type args. TODO: Is this the best way to do this?
+        -- The types should already have been taken into acocunt when creating
+        -- the signal, so this should probably work...
+        let valargs = filter isValArg args in
+        if all is_var valargs then do
+          labels <- getFieldLabels (CoreUtils.exprType app)
+          let assigns = zipWith mkassign labels valargs
+          let block_id = bndrToVHDLId bndr
+          let block = AST.BlockSm block_id [] (AST.PMapAspect []) [] assigns
+          return $ AST.CSBSm block
+        else
+          error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
+      where
+        mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
+        mkassign label (Var arg) =
+          let sel_name = mkSelectedName bndr label in
+          mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
     IdInfo.VanillaGlobal -> do
       -- It's a global value imported from elsewhere. These can be builting
       -- functions.
@@ -302,7 +322,7 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
           let label = labels!!i
           let sel_name = mkSelectedName scrut label
           let sel_expr = AST.PrimName sel_name
-          return $ mkUncondAssign bndr sel_expr
+          return $ mkUncondAssign (Left bndr) sel_expr
         Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
       
     _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
@@ -317,35 +337,35 @@ mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)]))
     true_expr  = (varToVHDLExpr true)
     false_expr  = (varToVHDLExpr false)
   in
-    return $ mkCondAssign bndr cond_expr true_expr false_expr
+    return $ mkCondAssign (Left bndr) cond_expr true_expr false_expr
 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
 
 -- Create an unconditional assignment statement
 mkUncondAssign ::
-  CoreBndr -- ^ The signal to assign to
+  Either CoreBndr AST.VHDLName -- ^ The signal to assign to
   -> AST.Expr -- ^ The expression to assign
   -> AST.ConcSm -- ^ The resulting concurrent statement
-mkUncondAssign bndr expr = mkAssign bndr Nothing expr
+mkUncondAssign dst expr = mkAssign dst Nothing expr
 
 -- Create a conditional assignment statement
 mkCondAssign ::
-  CoreBndr -- ^ The signal to assign to
+  Either CoreBndr AST.VHDLName -- ^ The signal to assign to
   -> AST.Expr -- ^ The condition
   -> AST.Expr -- ^ The value when true
   -> AST.Expr -- ^ The value when false
   -> AST.ConcSm -- ^ The resulting concurrent statement
-mkCondAssign bndr cond true false = mkAssign bndr (Just (cond, true)) false
+mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
 
 -- Create a conditional or unconditional assignment statement
 mkAssign ::
-  CoreBndr -> -- ^ The signal to assign to
+  Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
   Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
                                  -- and the value to assign when true.
   AST.Expr -> -- ^ The value to assign when false or no condition
   AST.ConcSm -- ^ The resulting concurrent statement
 
-mkAssign bndr cond false_expr =
+mkAssign dst cond false_expr =
   let
     -- I'm not 100% how this assignment AST works, but this gets us what we
     -- want...
@@ -357,7 +377,9 @@ mkAssign bndr cond false_expr =
           [AST.WhenElse true_wform cond_expr]
       Nothing -> []
     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
-    dst_name  = AST.NSimple (bndrToVHDLId bndr)
+    dst_name  = case dst of
+      Left bndr -> AST.NSimple (bndrToVHDLId bndr)
+      Right name -> name
     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
   in
     AST.CSSASm assign