Add function propagation transform.

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

diff --git a/VHDL.hs b/VHDL.hs
index d177a10b934dc8004425a150552de5df83c12e4e..8eb130fad8e0d11e016e3222e011f55b36977e05 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -22,12 +22,13 @@ import Debug.Trace
 import qualified ForSyDe.Backend.VHDL.AST as AST
 
 -- GHC API
 import qualified ForSyDe.Backend.VHDL.AST as AST
 
 -- GHC API

+import CoreSyn

 import qualified Type
 import qualified Name
 import qualified OccName
 import qualified Var
 import qualified TyCon
 import qualified Type
 import qualified Name
 import qualified OccName
 import qualified Var
 import qualified TyCon

-import qualified CoreSyn
+import qualified DataCon

 import Outputable ( showSDoc, ppr )
 
 -- Local imports
 import Outputable ( showSDoc, ppr )
 
 -- Local imports


@@ -246,25 +247,82 @@ mkConcSm ::
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   signatures <- getA vsSignatures
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   signatures <- getA vsSignatures

-  let 
-      (CoreSyn.Var f, args) = CoreSyn.collectArgs app
-      signature = Maybe.fromMaybe
-          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
+  funSignatures <- getA vsNameTable
+  let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+  case (Map.lookup (bndrToString f) funSignatures) of
+    Just funSignature ->
+      let
+        sigs = map (bndrToString.varBndr) args
+        sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
+        func = (snd funSignature) 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
+    Nothing ->
+      let  
+        signature = Maybe.fromMaybe 
+          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") 

           (Map.lookup (bndrToString f) signatures)
           (Map.lookup (bndrToString f) signatures)

-      entity_id = ent_id signature
-      label = bndrToString bndr
+        entity_id = ent_id signature
+        label = bndrToString bndr

       -- Add a clk port if we have state
       --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
       --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
       -- Add a clk port if we have state
       --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
       --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])

-      portmaps = mkAssocElems args bndr signature
-    in
-      return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+        portmaps = mkAssocElems args bndr signature
+      in
+        return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)

 
 -- GHC generates some funny "r = r" bindings in let statements before
 -- simplification. This outputs some dummy ConcSM for these, so things will at
 -- least compile for now.
 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
 
 
 -- GHC generates some funny "r = r" bindings in let statements before
 -- simplification. This outputs some dummy ConcSM for these, so things will at
 -- least compile for now.
 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
 

+-- A single alt case must be a selector
+mkConcSm (bndr, (Case (Var scrut) b ty [alt])) = error "Single case alt not supported yet"
+
+-- Multiple case alt are be conditional assignments and have only wild
+-- binders in the alts and only variables in the case values and a variable
+-- for a scrutinee. We check the constructor of the second alt, since the
+-- 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)
+    true_expr  = (varToVHDLExpr true)
+    false_expr  = (varToVHDLExpr false)
+    false_wform = AST.Wform [AST.WformElem false_expr Nothing]
+    true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+    whenelse = AST.WhenElse true_wform cond_expr
+    dst_name  = AST.NSimple (bndrToVHDLId bndr)
+    assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
+  in
+    return $ AST.CSSASm assign
+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"
+
+-- 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
+  where
+    tycon = DataCon.dataConTyCon dc
+    tyname = TyCon.tyConName tycon
+    dcname = DataCon.dataConName dc
+    lit = case Name.getOccString tyname of
+      -- 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!"
+
+
+

 {-
 mkConcSm sigs (UncondDef src dst) _ = do
   src_expr <- vhdl_expr src
 {-
 mkConcSm sigs (UncondDef src dst) _ = do
   src_expr <- vhdl_expr src