From d23c70f3fee490d865aae9c5bfcad1bf1e1f565f Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 17 Feb 2009 18:08:47 +0100 Subject: [PATCH] Generalize FApp and CondDef into SigDef and add UncondDef. --- Flatten.hs | 8 +++---- FlattenTypes.hs | 62 ++++++++++++++++++++++++++----------------------- Pretty.hs | 12 ++++------ Translator.hs | 4 ++-- VHDL.hs | 35 ++++++++++++++-------------- 5 files changed, 61 insertions(+), 60 deletions(-) diff --git a/Flatten.hs b/Flatten.hs index 1076d95..338a1ca 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -54,11 +54,11 @@ flattenFunction :: flattenFunction _ (Rec _) = error "Recursive binders not supported" flattenFunction hsfunc bind@(NonRec var expr) = - FlatFunction args res apps conds sigs'''' + FlatFunction args res defs sigs'''' where - init_state = ([], [], [], 0) + init_state = ([], [], 0) (fres, end_state) = State.runState (flattenExpr [] expr) init_state - (apps, conds, sigs, _) = end_state + (defs, sigs, _) = end_state (args, res) = fres arg_ports = concat (map Foldable.toList args) res_ports = Foldable.toList res @@ -132,7 +132,7 @@ flattenExpr binds app@(App _ _) = do appArgs = arg_ress, appRes = res } - addApp app + addDef app return ([], res) -- | Check a flattened expression to see if it is valid to use as a -- function argument. The first argument is the original expression for diff --git a/FlattenTypes.hs b/FlattenTypes.hs index 409c2ac..af6289e 100644 --- a/FlattenTypes.hs +++ b/FlattenTypes.hs @@ -75,20 +75,31 @@ hasState hsfunc = any (Foldable.any isStateUse) (hsFuncArgs hsfunc) || Foldable.any isStateUse (hsFuncRes hsfunc) --- | A flattened function application -data FApp = FApp { - appFunc :: HsFunction, - appArgs :: [SignalMap], - appRes :: SignalMap -} deriving (Show, Eq) - --- | A conditional signal definition -data CondDef = CondDef { - cond :: SignalId, - high :: SignalId, - low :: SignalId, - condRes :: SignalId -} deriving (Show, Eq) +-- | Something that defines a signal +data SigDef = + -- | A flattened function application + FApp { + appFunc :: HsFunction, + appArgs :: [SignalMap], + appRes :: SignalMap + } + -- | A conditional signal definition + | CondDef { + cond :: SignalId, + high :: SignalId, + low :: SignalId, + condRes :: SignalId + } + -- | Unconditional signal definition + | UncondDef { + defSrc :: SignalId, + defDst :: SignalId + } deriving (Show, Eq) + +-- Returns the function used by the given SigDef, if any +usedHsFunc :: SigDef -> Maybe HsFunction +usedHsFunc (FApp hsfunc _ _) = Just hsfunc +usedHsFunc _ = Nothing -- | How is a given signal used in the resulting VHDL? data SigUse = @@ -127,8 +138,7 @@ data SignalInfo = SignalInfo { data FlatFunction = FlatFunction { flat_args :: [SignalMap], flat_res :: SignalMap, - flat_apps :: [FApp], - flat_conds :: [CondDef], + flat_defs :: [SigDef], flat_sigs :: [(SignalId, SignalInfo)] } @@ -150,25 +160,19 @@ type BindMap = [( )] -- | The state during the flattening of a single function -type FlattenState = State.State ([FApp], [CondDef], [(SignalId, SignalInfo)], SignalId) +type FlattenState = State.State ([SigDef], [(SignalId, SignalInfo)], SignalId) -- | Add an application to the current FlattenState -addApp :: (FApp) -> FlattenState () -addApp a = do - (apps, conds, sigs, n) <- State.get - State.put (a:apps, conds, sigs, n) - --- | Add a conditional definition to the current FlattenState -addCondDef :: (CondDef) -> FlattenState () -addCondDef c = do - (apps, conds, sigs, n) <- State.get - State.put (apps, c:conds, sigs, n) +addDef :: SigDef -> FlattenState () +addDef d = do + (defs, sigs, n) <- State.get + State.put (d:defs, sigs, n) -- | Generates a new signal id, which is unique within the current flattening. genSignalId :: SigUse -> Type.Type -> FlattenState SignalId genSignalId use ty = do - (apps, conds, sigs, n) <- State.get + (defs, sigs, n) <- State.get -- Generate a new numbered but unnamed signal let s = (n, SignalInfo Nothing use ty) - State.put (apps, conds, s:sigs, n+1) + State.put (defs, s:sigs, n+1) return n diff --git a/Pretty.hs b/Pretty.hs index ba0e3d0..183125c 100644 --- a/Pretty.hs +++ b/Pretty.hs @@ -37,21 +37,19 @@ instance Pretty HsValueUse where pPrint (HighOrder _ _) = text "Higher Order" instance Pretty FlatFunction where - pPrint (FlatFunction args res apps conds sigs) = + pPrint (FlatFunction args res defs sigs) = (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) + $+$ (text "Defs: ") $$ nest 10 (pPrint defs) $+$ text "Signals: " $$ nest 10 (printList ppsig sigs) where ppsig (id, info) = pPrint id <> pPrint info -instance Pretty FApp where +instance Pretty SigDef where pPrint (FApp func args res) = pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res - -instance Pretty CondDef where - pPrint _ = text "TODO" + pPrint (CondDef _ _ _ _) = text "TODO" + pPrint (UncondDef src dst) = text "TODO" instance Pretty SignalInfo where pPrint (SignalInfo name use ty) = diff --git a/Translator.hs b/Translator.hs index f875dd6..e000847 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)) ["dff"] + let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["sfull_adder"] liftIO $ putStr $ prettyShow binds -- Turn bind into VHDL let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty) @@ -111,7 +111,7 @@ flattenBind hsfunc bind@(NonRec var expr) = do let flatfunc = flattenFunction hsfunc bind addFunc hsfunc setFlatFunc hsfunc flatfunc - let used_hsfuncs = map appFunc (flat_apps flatfunc) + let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc) State.mapM resolvFunc used_hsfuncs return () diff --git a/VHDL.hs b/VHDL.hs index 67b8394..c791a34 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -129,19 +129,18 @@ 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 :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm @@ -174,14 +173,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 +189,17 @@ 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) 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 +208,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 -- 2.30.2