From a07f47bf0b471c935e3e76e814b2f6ebfb298d35 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 11 Feb 2009 19:53:47 +0100 Subject: [PATCH] Make FlatFunction parameterized with the signal id type. This allows us to define a NamedFlatFunction later on where the signals have names. --- Flatten.hs | 8 +++---- FlattenTypes.hs | 60 ++++++++++++++++++++++++++----------------------- Pretty.hs | 10 ++++----- 3 files changed, 41 insertions(+), 37 deletions(-) diff --git a/Flatten.hs b/Flatten.hs index 8a23016..e550db8 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -25,7 +25,7 @@ dataConAppArgs dc args = genSignalUses :: Type.Type - -> FlattenState SignalUseMap + -> FlattenState (SignalUseMap UnnamedSignal) genSignalUses ty = do typeMapToUseMap tymap @@ -35,7 +35,7 @@ genSignalUses ty = do typeMapToUseMap :: HsValueMap Type.Type - -> FlattenState SignalUseMap + -> FlattenState (SignalUseMap UnnamedSignal) typeMapToUseMap (Single ty) = do id <- genSignalId @@ -63,7 +63,7 @@ flattenFunction hsfunc bind@(NonRec var expr) = flattenExpr :: BindMap -> CoreExpr - -> FlattenState ([SignalDefMap], SignalUseMap) + -> FlattenState ([SignalDefMap UnnamedSignal], (SignalUseMap UnnamedSignal)) flattenExpr binds lam@(Lam b expr) = do -- Find the type of the binder @@ -154,7 +154,7 @@ flattenExpr binds expr@(Case (Var v) b _ alts) = -> Var.Var -- The scrutinee -> CoreBndr -- The binder to bind the scrutinee to -> CoreAlt -- The single alternative - -> FlattenState ( [SignalDefMap], SignalUseMap) + -> FlattenState ( [SignalDefMap UnnamedSignal], SignalUseMap UnnamedSignal) -- See expandExpr flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) = if not (DataCon.isTupleCon datacon) diff --git a/FlattenTypes.hs b/FlattenTypes.hs index 81088ba..c5546ea 100644 --- a/FlattenTypes.hs +++ b/FlattenTypes.hs @@ -8,29 +8,29 @@ import CoreSyn import HsValueMap -- | A signal identifier -type SignalId = Int +type UnnamedSignal = Int -- | A use of a signal -data SignalUse = SignalUse { - sigUseId :: SignalId +data SignalUse sigid = SignalUse { + sigUseId :: sigid } deriving (Show, Eq) -- | A def of a signal -data SignalDef = SignalDef { - sigDefId :: SignalId +data SignalDef sigid = SignalDef { + sigDefId :: sigid } deriving (Show, Eq) -- | A map of a Haskell value to signal uses -type SignalUseMap = HsValueMap SignalUse +type SignalUseMap sigid = HsValueMap (SignalUse sigid) -- | A map of a Haskell value to signal defs -type SignalDefMap = HsValueMap SignalDef +type SignalDefMap sigid = HsValueMap (SignalDef sigid) -- | Translate a SignalUseMap to an equivalent SignalDefMap -useMapToDefMap :: SignalUseMap -> SignalDefMap +useMapToDefMap :: SignalUseMap sigid -> SignalDefMap sigid useMapToDefMap = fmap (\(SignalUse u) -> SignalDef u) -- | Translate a SignalDefMap to an equivalent SignalUseMap -defMapToUseMap :: SignalDefMap -> SignalUseMap +defMapToUseMap :: SignalDefMap sigid -> SignalUseMap sigid defMapToUseMap = fmap (\(SignalDef u) -> SignalUse u) -- | How is a given (single) value in a function's type (ie, argument or @@ -80,57 +80,61 @@ data HsFunction = HsFunction { } deriving (Show, Eq, Ord) -- | A flattened function application -data FApp = FApp { +data FApp sigid = FApp { appFunc :: HsFunction, - appArgs :: [SignalUseMap], - appRes :: SignalDefMap + appArgs :: [SignalUseMap sigid], + appRes :: SignalDefMap sigid } deriving (Show, Eq) -- | A conditional signal definition -data CondDef = CondDef { - cond :: SignalUse, - high :: SignalUse, - low :: SignalUse, - condRes :: SignalDef +data CondDef sigid = CondDef { + cond :: SignalUse sigid, + high :: SignalUse sigid, + low :: SignalUse sigid, + condRes :: SignalDef sigid } deriving (Show, Eq) -- | A flattened function -data FlatFunction = FlatFunction { - args :: [SignalDefMap], - res :: SignalUseMap, +data FlatFunction' sigid = FlatFunction { + args :: [SignalDefMap sigid], + res :: SignalUseMap sigid, --sigs :: [SignalDef], - apps :: [FApp], - conds :: [CondDef] + apps :: [FApp sigid], + conds :: [CondDef sigid] } deriving (Show, Eq) +-- | A flat function that does not have its signals named +type FlatFunction = FlatFunction' UnnamedSignal + -- | A list of binds in effect at a particular point of evaluation type BindMap = [( CoreBndr, -- ^ The bind name Either -- ^ The bind value which is either - SignalUseMap -- ^ a signal + (SignalUseMap UnnamedSignal) + -- ^ a signal ( HsValueUse, -- ^ or a HighOrder function - [SignalUse] -- ^ With these signals already applied to it + [SignalUse UnnamedSignal] -- ^ With these signals already applied to it ) )] -- | The state during the flattening of a single function -type FlattenState = State.State ([FApp], [CondDef], SignalId) +type FlattenState = State.State ([FApp UnnamedSignal], [CondDef UnnamedSignal], UnnamedSignal) -- | Add an application to the current FlattenState -addApp :: FApp -> FlattenState () +addApp :: (FApp UnnamedSignal) -> FlattenState () addApp a = do (apps, conds, n) <- State.get State.put (a:apps, conds, n) -- | Add a conditional definition to the current FlattenState -addCondDef :: CondDef -> FlattenState () +addCondDef :: (CondDef UnnamedSignal) -> FlattenState () addCondDef c = do (apps, conds, n) <- State.get State.put (apps, c:conds, n) -- | Generates a new signal id, which is unique within the current flattening. -genSignalId :: FlattenState SignalId +genSignalId :: FlattenState UnnamedSignal genSignalId = do (apps, conds, n) <- State.get State.put (apps, conds, n+1) diff --git a/Pretty.hs b/Pretty.hs index 6f88877..bd4d9e5 100644 --- a/Pretty.hs +++ b/Pretty.hs @@ -27,24 +27,24 @@ instance Pretty HsValueUse where pPrint (State n) = char 'C' <> int n pPrint (HighOrder _ _) = text "Higher Order" -instance Pretty FlatFunction where +instance Pretty id => Pretty (FlatFunction' id) where pPrint (FlatFunction args res apps conds) = (text "Args: ") $$ nest 10 (pPrint args) $+$ (text "Result: ") $$ nest 10 (pPrint res) $+$ (text "Apps: ") $$ nest 10 (vcat (map pPrint apps)) $+$ (text "Conds: ") $$ nest 10 (pPrint conds) -instance Pretty FApp where +instance Pretty id => Pretty (FApp id) where pPrint (FApp func args res) = pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res -instance Pretty SignalDef where +instance Pretty id => Pretty (SignalDef id) where pPrint (SignalDef id) = pPrint id -instance Pretty SignalUse where +instance Pretty id => Pretty (SignalUse id) where pPrint (SignalUse id) = pPrint id -instance Pretty CondDef where +instance Pretty id => Pretty (CondDef id) where pPrint _ = text "TODO" instance Pretty VHDLSession where -- 2.30.2