Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project

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

diff --git a/VHDL.hs b/VHDL.hs
index eb454203ebeda699ebcc9c595f4a6f395dbdfee7..72b0a925ec8554753109ff04946eb667a6581c04 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -264,6 +264,17 @@ mkConcSm ::
   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
   -> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
 
+
+-- Ignore Cast expressions, they should not longer have any meaning as long as
+-- the type works out.
+mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
+
+-- For simple a = b assignments, just generate an unconditional signal
+-- assignment. This should only happen for dataconstructors without arguments.
+-- TODO: Integrate this with the below code for application (essentially this
+-- is an application without arguments)
+mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
+
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
   let valargs' = filter isValArg args
@@ -289,18 +300,32 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do
       -- It's a global value imported from elsewhere. These can be builtin
       -- functions.
       funSignatures <- getA vsNameTable
+      signatures <- getA vsSignatures
       case (Map.lookup (bndrToString f) funSignatures) of
         Just (arg_count, builder) ->
           if length valargs == arg_count then
-            let
-              sigs = map (bndrToString.varBndr) valargs
-              sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
-              func = builder sigsNames
-              src_wform = AST.Wform [AST.WformElem func Nothing]
-              dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
-              assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
-            in
-              return [AST.CSSASm assign]
+            case builder of
+              Left funBuilder ->
+                let
+                  sigs = map (varToVHDLExpr.varBndr) valargs
+                  func = funBuilder sigs
+                  src_wform = AST.Wform [AST.WformElem func Nothing]
+                  dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
+                  assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+                in
+                  return [AST.CSSASm assign]
+              Right genBuilder ->
+                let
+                  ty = Var.varType bndr
+                  len = tfvec_len ty 
+                  sigs = map varBndr valargs
+                  signature = Maybe.fromMaybe
+                    (error $ "Using function '" ++ (bndrToString (head sigs)) ++ "' without signature? This should not happen!") 
+                    (Map.lookup (head sigs) signatures)
+                  arg_names = map (mkVHDLExtId . bndrToString) (tail sigs)
+                  dst_name = mkVHDLExtId (bndrToString bndr)
+                  genSm = genBuilder len signature (arg_names ++ [dst_name])  
+                in return [AST.CSGSm genSm]
           else
             error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
         Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
@@ -346,7 +371,7 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 -- first is the default case, if there is any.
 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
   let
-    cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
+    cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
     true_expr  = (varToVHDLExpr true)
     false_expr  = (varToVHDLExpr false)
   in
@@ -422,13 +447,26 @@ getFieldLabels ty = do
 
 -- Turn a variable reference into a AST expression
 varToVHDLExpr :: Var.Var -> AST.Expr
-varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
-
--- Turn a constructor into an AST expression. For dataconstructors, this is
--- only the constructor itself, not any arguments it has. Should not be called
--- with a DEFAULT constructor.
-conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
-conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
+varToVHDLExpr var = 
+  case Id.isDataConWorkId_maybe var of
+    Just dc -> dataconToVHDLExpr dc
+    -- This is a dataconstructor.
+    -- Not a datacon, just another signal. Perhaps we should check for
+    -- local/global here as well?
+    Nothing -> AST.PrimName $ AST.NSimple $ bndrToVHDLId var
+
+-- Turn a alternative constructor into an AST expression. For
+-- dataconstructors, this is only the constructor itself, not any arguments it
+-- has. Should not be called with a DEFAULT constructor.
+altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
+
+altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
+altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
+
+-- Turn a datacon (without arguments!) into a VHDL expression.
+dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
+dataconToVHDLExpr dc = AST.PrimLit lit
   where
     tycon = DataCon.dataConTyCon dc
     tyname = TyCon.tyConName tycon
@@ -437,9 +475,6 @@ conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
       -- TODO: Do something more robust than string matching
       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
-conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
-conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
-
 
 
 {-