X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=1c7eba9ea2e848fbca70c620357e1b0e9fb09f85;hb=9b7d00ad53acfc821840051ef693d87470b4462b;hp=32279fdea471a0c055a50ccb39cd6bd8491fd9de;hpb=e273d2759db01787f0599a1cbe9059864e1704d7;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDL.hs b/VHDL.hs
index 32279fd..1c7eba9 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -8,6 +8,7 @@ import qualified Maybe
 import qualified Control.Monad as Monad
 
 import qualified Type
+import qualified TysWiredIn
 import qualified Name
 import qualified TyCon
 import Outputable ( showSDoc, ppr )
@@ -129,22 +130,21 @@ createArchitecture hsfunc fdata =
       let sigs = flat_sigs flatfunc
       let args = flat_args flatfunc
       let res  = flat_res  flatfunc
-      let apps = flat_apps flatfunc
+      let defs = flat_defs flatfunc
       let entity_id = Maybe.fromMaybe
                       (error $ "Building architecture without an entity? This should not happen!")
                       (getEntityId fdata)
       -- Create signal declarations for all signals that are not in args and
       -- res
       let sig_decs = Maybe.catMaybes $ map (mkSigDec . snd) sigs
-      -- Create component instantiations for all function applications
-      insts <- mapM (mkCompInsSm sigs) apps
+      -- Create concurrent statements for all signal definitions
+      statements <- mapM (mkConcSm sigs) defs
       let procs = map mkStateProcSm (getOwnStates hsfunc flatfunc)
-      let insts' = map AST.CSISm insts
       let procs' = map AST.CSPSm procs
-      let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (insts' ++ procs')
+      let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
       setArchitecture hsfunc arch
 
-mkStateProcSm :: (Int, SignalInfo, SignalInfo) -> AST.ProcSm
+mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 mkStateProcSm (num, old, new) =
   AST.ProcSm label [clk] [statement]
   where
@@ -174,14 +174,13 @@ getSignalId info =
       (error $ "Unnamed signal? This should not happen!")
       (sigName info)
 
--- | Transforms a flat function application to a VHDL component instantiation.
-mkCompInsSm ::
+-- | Transforms a signal definition into a VHDL concurrent statement
+mkConcSm ::
   [(SignalId, SignalInfo)] -- | The signals in the current architecture
-  -> FApp                       -- | The application to look at.
-  -> VHDLState AST.CompInsSm    -- | The corresponding VHDL component instantiation.
+  -> SigDef                -- | The signal definition
+  -> VHDLState AST.ConcSm    -- | The corresponding VHDL component instantiation.
 
-mkCompInsSm sigs app = do
-  let hsfunc = appFunc app
+mkConcSm sigs (FApp hsfunc args res) = do
   fdata_maybe <- getFunc hsfunc
   let fdata = Maybe.fromMaybe
         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
@@ -191,16 +190,51 @@ mkCompInsSm sigs app = do
         (funcEntity fdata)
   let entity_id = ent_id entity
   label <- uniqueName (AST.fromVHDLId entity_id)
-  let portmaps = mkAssocElems sigs app entity
-  return $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+  let portmaps = mkAssocElems sigs args res entity
+  return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+
+mkConcSm sigs (UncondDef src dst) = do
+  let src_expr  = vhdl_expr src
+  let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
+  let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
+  let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+  return $ AST.CSSASm assign
+  where
+    vhdl_expr (Left id) = mkIdExpr sigs id
+    vhdl_expr (Right expr) =
+      case expr of
+        (EqLit id lit) ->
+          (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
+        (Literal lit) ->
+          AST.PrimLit lit
+        (Eq a b) ->
+          (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
+
+mkConcSm sigs (CondDef cond true false dst) = do
+  let cond_expr  = mkIdExpr sigs cond
+  let true_expr  = mkIdExpr sigs true
+  let false_expr  = mkIdExpr sigs false
+  let false_wform = AST.Wform [AST.WformElem false_expr Nothing]
+  let true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+  let whenelse = AST.WhenElse true_wform cond_expr
+  let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
+  let assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
+  return $ AST.CSSASm assign
+
+-- | Turn a SignalId into a VHDL Expr
+mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
+mkIdExpr sigs id =
+  let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
+  AST.PrimName src_name
 
 mkAssocElems :: 
-  [(SignalId, SignalInfo)] -- | The signals in the current architecture
-  -> FApp                       -- | The application to look at.
+  [(SignalId, SignalInfo)]      -- | The signals in the current architecture
+  -> [SignalMap]                -- | The signals that are applied to function
+  -> SignalMap                  -- | the signals in which to store the function result
   -> Entity                     -- | The entity to map against.
   -> [AST.AssocElem]            -- | The resulting port maps
 
-mkAssocElems sigmap app entity =
+mkAssocElems sigmap args res entity =
     -- Create the actual AssocElems
     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
   where
@@ -209,8 +243,8 @@ mkAssocElems sigmap app entity =
     -- the similar form?
     arg_ports = concat (map Foldable.toList (ent_args entity))
     res_ports = Foldable.toList (ent_res entity)
-    arg_sigs  = (concat (map Foldable.toList (appArgs app)))
-    res_sigs  = Foldable.toList (appRes app)
+    arg_sigs  = (concat (map Foldable.toList args))
+    res_sigs  = Foldable.toList res
     -- Extract the id part from the (id, type) tuple
     ports     = (map (fmap fst) (arg_ports ++ res_ports)) 
     -- Translate signal numbers into names
@@ -260,6 +294,10 @@ getLibraryUnits (hsfunc, fdata) =
 bit_ty :: AST.TypeMark
 bit_ty = AST.unsafeVHDLBasicId "Bit"
 
+-- | The VHDL Boolean type
+bool_ty :: AST.TypeMark
+bool_ty = AST.unsafeVHDLBasicId "Boolean"
+
 -- | The VHDL std_logic
 std_logic_ty :: AST.TypeMark
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
@@ -273,14 +311,18 @@ vhdl_ty ty = Maybe.fromMaybe
 -- Translate a Haskell type to a VHDL type
 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
 vhdl_ty_maybe ty =
-  case Type.splitTyConApp_maybe ty of
-    Just (tycon, args) ->
-      let name = TyCon.tyConName tycon in
-        -- TODO: Do something more robust than string matching
-        case Name.getOccString name of
-          "Bit"      -> Just bit_ty
-          otherwise  -> Nothing
-    otherwise -> Nothing
+  if Type.coreEqType ty TysWiredIn.boolTy
+    then
+      Just bool_ty
+    else
+      case Type.splitTyConApp_maybe ty of
+        Just (tycon, args) ->
+          let name = TyCon.tyConName tycon in
+            -- TODO: Do something more robust than string matching
+            case Name.getOccString name of
+              "Bit"      -> Just std_logic_ty
+              otherwise  -> Nothing
+        otherwise -> Nothing
 
 -- Shortcut
 mkVHDLId :: String -> AST.VHDLId