From a3ea63eb2bd94867dae27a30aa900c9dfa9babb1 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 17 Feb 2009 15:35:19 +0100 Subject: [PATCH] Create state procs for state signals. --- Flatten.hs | 35 +++++++++++++++++++++++++++++++++++ HsValueMap.hs | 15 +++++++++++++++ Translator.hs | 2 +- VHDL.hs | 28 ++++++++++++++++++++++++---- 4 files changed, 75 insertions(+), 5 deletions(-) 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 :: -- 2.30.2