From: Matthijs Kooijman <m.kooijman@student.utwente.nl>
Date: Tue, 17 Feb 2009 14:35:19 +0000 (+0100)
Subject: Create state procs for state signals.
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=a3ea63eb2bd94867dae27a30aa900c9dfa9babb1;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

Create state procs for state signals.
---

diff --git a/Flatten.hs b/Flatten.hs
index 2e66e90..12f6ee3 100644
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -193,4 +193,39 @@ appToHsFunction ty f args =
     hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
     hsres  = useAsPort (mkHsValueMap ty)
 
+-- | Translates signal id's to SignalInfo for any signals used as state.
+findState ::
+  [(UnnamedSignal, SignalInfo)] -- | A map of id to info
+  -> UnnamedSignal              -- | The signal id to look at
+  -> HsValueUse                 -- | How is this signal used?
+  -> Maybe (Int, SignalInfo)    -- | The state num and SignalInfo, if appropriate
+
+findState sigs id (State num) = 
+  Just (num, Maybe.fromJust $ lookup id sigs)
+findState _ _ _ = Nothing
+
+
+-- | Returns pairs of signals that should be mapped to state in this function.
+getOwnStates ::
+  HsFunction                      -- | The function to look at
+  -> FlatFunction                 -- | The function to look at
+  -> [(Int, SignalInfo, SignalInfo)]   
+        -- | The state signals. The first is the state number, the second the
+        --   signal to assign the current state to, the last is the signal
+        --   that holds the new state.
+
+getOwnStates hsfunc flatfunc =
+  [(old_num, old_info, new_info) 
+    | (old_num, old_info) <- args_states
+    , (new_num, new_info) <- res_states
+    , old_num == new_num]
+  where
+    sigs = flat_sigs flatfunc
+    -- Translate args and res to lists of (statenum, SignalInfo)
+    args = zipWith (zipValueMapsWith $ findState sigs) (flat_args flatfunc) (hsFuncArgs hsfunc)
+    args_states = Maybe.catMaybes $ concat $ map Foldable.toList $ args
+    res = zipValueMapsWith (findState sigs) (flat_res flatfunc) (hsFuncRes hsfunc)
+    res_states = Maybe.catMaybes $ Foldable.toList res
+
+    
 -- vim: set ts=8 sw=2 sts=2 expandtab:
diff --git a/HsValueMap.hs b/HsValueMap.hs
index c2407f5..97e4cdb 100644
--- a/HsValueMap.hs
+++ b/HsValueMap.hs
@@ -54,3 +54,18 @@ mkHsValueMap ty =
         else
           Single ty
     Nothing -> Single ty
+
+-- | Creates a map of pairs from two maps. The maps must have the same
+--   structure.
+zipValueMaps :: HsValueMap a -> HsValueMap b -> HsValueMap (a, b)
+zipValueMaps = zipValueMapsWith (\a b -> (a, b))
+
+-- | Creates a map of two maps using the given combination function.
+zipValueMapsWith :: (a -> b -> c) -> HsValueMap a -> HsValueMap b -> HsValueMap c
+zipValueMapsWith f (Tuple as) (Tuple bs) =
+  Tuple $ zipWith (zipValueMapsWith f) as bs
+zipValueMapsWith f (Single a) (Single b) =
+  Single $ f a b
+zipValueMapWith _ _ _ =
+  error $ "Trying to zip unsimilarly formed trees!"
+
diff --git a/Translator.hs b/Translator.hs
index 9ce7206..c037a1e 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -54,7 +54,7 @@ main =
           --core <- GHC.compileToCoreSimplified "Adders.hs"
           core <- GHC.compileToCoreSimplified "Adders.hs"
           --liftIO $ printBinds (cm_binds core)
-          let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["sfull_adder"]
+          let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["dff"]
           liftIO $ putStr $ prettyShow binds
           -- Turn bind into VHDL
           let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty)
diff --git a/VHDL.hs b/VHDL.hs
index b23e5f3..ef89c4a 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -15,6 +15,7 @@ import Outputable ( showSDoc, ppr )
 import qualified ForSyDe.Backend.VHDL.AST as AST
 
 import VHDLTypes
+import Flatten
 import FlattenTypes
 import TranslatorTypes
 import Pretty
@@ -112,18 +113,37 @@ createArchitecture hsfunc fdata =
       let sig_decs = [mkSigDec info | (id, info) <- sigs, (all (id `Foldable.notElem`) (res:args)) ]
       -- Create component instantiations for all function applications
       insts <- mapM (mkCompInsSm sigs) apps
+      let procs = map mkStateProcSm (getOwnStates hsfunc flatfunc)
       let insts' = map AST.CSISm insts
-      let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) insts'
+      let procs' = map AST.CSPSm procs
+      let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (insts' ++ procs')
       setArchitecture hsfunc arch
 
+mkStateProcSm :: (Int, SignalInfo, SignalInfo) -> AST.ProcSm
+mkStateProcSm (num, old, new) =
+  AST.ProcSm label [clk] [statement]
+  where
+    label       = mkVHDLId $ "state_" ++ (show num)
+    clk         = mkVHDLId "clk"
+    rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
+    wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
+    assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
+    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 :: SignalInfo -> AST.SigDec
 mkSigDec info =
-    AST.SigDec (mkVHDLId name) (vhdl_ty ty) Nothing
+    AST.SigDec (getSignalId info) (vhdl_ty ty) Nothing
   where
-    name = Maybe.fromMaybe
+    ty = sigTy info
+
+-- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
+--   is not named.
+getSignalId :: SignalInfo -> AST.VHDLId
+getSignalId info =
+    mkVHDLId $ Maybe.fromMaybe
       (error $ "Unnamed signal? This should not happen!")
       (sigName info)
-    ty = sigTy info
 
 -- | Transforms a flat function application to a VHDL component instantiation.
 mkCompInsSm ::