X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=338a1ca1b1f91e39b0c968321a339b7417115f5b;hb=48b92d378f7a8ce1a3c41443a4c9ad957bcd59c4;hp=12f6ee3be26cfa8d25cf778aa15a404ae11a5d2e;hpb=a3ea63eb2bd94867dae27a30aa900c9dfa9babb1;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Flatten.hs b/Flatten.hs index 12f6ee3..338a1ca 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -5,6 +5,7 @@ import qualified Var import qualified Type import qualified Name import qualified Maybe +import qualified Control.Arrow as Arrow import qualified DataCon import qualified CoreUtils import qualified Data.Traversable as Traversable @@ -27,7 +28,7 @@ dataConAppArgs dc args = genSignals :: Type.Type - -> FlattenState (SignalMap UnnamedSignal) + -> FlattenState SignalMap genSignals ty = -- First generate a map with the right structure containing the types, and @@ -36,12 +37,15 @@ genSignals ty = -- | Marks a signal as the given SigUse, if its id is in the list of id's -- given. -markSignal :: SigUse -> [UnnamedSignal] -> (UnnamedSignal, SignalInfo) -> (UnnamedSignal, SignalInfo) -markSignal use ids (id, info) = +markSignals :: SigUse -> [SignalId] -> (SignalId, SignalInfo) -> (SignalId, SignalInfo) +markSignals use ids (id, info) = (id, info') where info' = if id `elem` ids then info { sigUse = use} else info +markSignal :: SigUse -> SignalId -> (SignalId, SignalInfo) -> (SignalId, SignalInfo) +markSignal use id = markSignals use [id] + -- | Flatten a haskell function flattenFunction :: HsFunction -- ^ The function to flatten @@ -50,19 +54,27 @@ 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 + (defs, sigs, _) = end_state (args, res) = fres - portlist = concat (map Foldable.toList (res:args)) - (apps, conds, sigs, _) = end_state - sigs' = fmap (markSignal SigPort portlist) sigs + arg_ports = concat (map Foldable.toList args) + res_ports = Foldable.toList res + -- Mark args and result signals as input and output ports resp. + sigs' = fmap (markSignals SigPortIn arg_ports) sigs + sigs'' = fmap (markSignals SigPortOut res_ports) sigs' + -- Mark args and result states as old and new state resp. + args_states = concat $ zipWith stateList (hsFuncArgs hsfunc) args + sigs''' = foldl (\s (num, id) -> map (markSignal (SigStateOld num) id) s) sigs'' args_states + res_states = stateList (hsFuncRes hsfunc) res + sigs'''' = foldl (\s (num, id) -> map (markSignal (SigStateNew num) id) s) sigs''' res_states flattenExpr :: BindMap -> CoreExpr - -> FlattenState ([SignalMap UnnamedSignal], (SignalMap UnnamedSignal)) + -> FlattenState ([SignalMap], SignalMap) flattenExpr binds lam@(Lam b expr) = do -- Find the type of the binder @@ -120,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 @@ -153,7 +165,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 ( [SignalMap UnnamedSignal], SignalMap UnnamedSignal) + -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) = if not (DataCon.isTupleCon datacon) @@ -193,23 +205,33 @@ 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 - - +-- | Filters non-state signals and returns the state number and signal id for +-- state values. +filterState :: + SignalId -- | The signal id to look at + -> HsValueUse -- | How is this signal used? + -> Maybe (StateId, SignalId ) -- | The state num and signal id, if this + -- signal was used as state + +filterState id (State num) = + Just (num, id) +filterState _ _ = Nothing + +-- | Returns a list of the state number and signal id of all used-as-state +-- signals in the given maps. +stateList :: + HsUseMap + -> (SignalMap) + -> [(StateId, SignalId)] + +stateList uses signals = + Maybe.catMaybes $ Foldable.toList $ zipValueMapsWith filterState signals uses + -- | 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)] + -> [(StateId, 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. @@ -221,11 +243,12 @@ getOwnStates hsfunc flatfunc = , 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 + -- Translate args and res to lists of (statenum, sigid) + args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc) + res = stateList (hsFuncRes hsfunc) (flat_res flatfunc) + -- Replace the second tuple element with the corresponding SignalInfo + args_states = map (Arrow.second $ signalInfo sigs) args + res_states = map (Arrow.second $ signalInfo sigs) res -- vim: set ts=8 sw=2 sts=2 expandtab: