X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=8eb130fad8e0d11e016e3222e011f55b36977e05;hb=0273d87f3e6e8790ca7beb5a46bea8d478a89194;hp=561c2790d5537bc56d4f5b12d6d9505b2f2a30fb;hpb=3f12ee5d723fd8c01190c5971641141a8c7a9d98;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDL.hs b/VHDL.hs
index 561c279..8eb130f 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -22,12 +22,13 @@ import Debug.Trace
 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 CoreSyn
+import qualified DataCon
 import Outputable ( showSDoc, ppr )
 
 -- Local imports
@@ -38,6 +39,9 @@ import TranslatorTypes
 import HsValueMap
 import Pretty
 import CoreTools
+import Constants
+import Generate
+import GlobalNameTable
 
 createDesignFiles ::
   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
@@ -48,7 +52,7 @@ createDesignFiles binds =
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where
-    init_session = VHDLSession Map.empty builtin_funcs
+    init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session
     ty_decls = Map.elems (final_session ^. vsTypes)
@@ -109,7 +113,7 @@ createEntity (fname, expr) = do
       CoreSyn.CoreBndr 
       -> VHDLState VHDLSignalMapElement
     -- We only need the vsTypes element from the state
-    mkMap = MonadState.lift vsTypes . (\bndr ->
+    mkMap = (\bndr ->
       let
         --info = Maybe.fromMaybe
         --  (error $ "Signal not found in the name map? This should not happen!")
@@ -191,7 +195,7 @@ createArchitecture (fname, expr) = do
     procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
     procs' = map AST.CSPSm procs
     -- mkSigDec only uses vsTypes from the state
-    mkSigDec' = MonadState.lift vsTypes . mkSigDec
+    mkSigDec' = mkSigDec
 
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.
@@ -220,7 +224,7 @@ mkStateProcSm (num, old, new) =
     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 
-mkSigDec :: CoreSyn.CoreBndr -> TypeState (Maybe AST.SigDec)
+mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
 mkSigDec bndr =
   if True then do --isInternalSigUse use || isStateSigUse use then do
     type_mark <- vhdl_ty $ Var.varType bndr
@@ -243,25 +247,82 @@ mkConcSm ::
 
 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)
-      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 [])
-      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") [] []
 
+-- 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
@@ -281,7 +342,7 @@ mkConcSm sigs (UncondDef src dst) _ = do
           -- Create a cast expression, which is just a function call using the
           -- type name as the function name.
           let litexpr = AST.PrimLit lit
-          ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
+          ty_id <- vhdl_ty ty
           let ty_name = AST.NSimple ty_id
           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)] 
           return $ AST.PrimFCall $ AST.FCall ty_name args
@@ -361,9 +422,9 @@ std_logic_ty :: AST.TypeMark
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 
 -- Translate a Haskell type to a VHDL type
-vhdl_ty :: Type.Type -> TypeState AST.TypeMark
+vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
 vhdl_ty ty = do
-  typemap <- State.get
+  typemap <- getA vsTypes
   let builtin_ty = do -- See if this is a tycon and lookup its name
         (tycon, args) <- Type.splitTyConApp_maybe ty
         let name = Name.getOccString (TyCon.tyConName tycon)
@@ -380,7 +441,7 @@ vhdl_ty ty = do
             (tycon, args) <- Type.splitTyConApp_maybe ty
             let name = Name.getOccString (TyCon.tyConName tycon)
             case name of
-              "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
+              "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty
               "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
               otherwise -> Nothing
       -- Return new_ty when a new type was successfully created
@@ -392,7 +453,7 @@ vhdl_ty ty = do
 mk_vector_ty ::
   Int -- ^ The length of the vector
   -> Type.Type -- ^ The Haskell type to create a VHDL type for
-  -> TypeState AST.TypeMark -- The typemark created.
+  -> VHDLState AST.TypeMark -- The typemark created.
 
 mk_vector_ty len ty = do
   -- Assume there is a single type argument
@@ -402,7 +463,9 @@ mk_vector_ty len ty = do
   let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
   let ty_dec = AST.TypeDec ty_id ty_def
   -- TODO: Check name uniqueness
-  State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
+  --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
+  modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
+  modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
   return ty_id