X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=ba49d0b8a22a5f7440d1b371a397007ad77e9786;hb=0082f01a853476cdcec0e73bacf8c0d4508dbec0;hp=12f6ee3be26cfa8d25cf778aa15a404ae11a5d2e;hpb=a3ea63eb2bd94867dae27a30aa900c9dfa9babb1;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Flatten.hs b/Flatten.hs index 12f6ee3..ba49d0b 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,75 @@ 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) - (fres, end_state) = State.runState (flattenExpr [] expr) init_state + init_state = ([], [], 0) + (fres, end_state) = State.runState (flattenTopExpr hsfunc 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 +flattenTopExpr :: + HsFunction + -> CoreExpr + -> FlattenState ([SignalMap], SignalMap) + +flattenTopExpr hsfunc expr = do + -- Flatten the expression + (args, res) <- flattenExpr [] expr + + -- Join the signal ids and uses together + let zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc) + let zipped_res = zipValueMaps res (hsFuncRes hsfunc) + -- Set the signal uses for each argument / result, possibly updating + -- argument or result signals. + args' <- mapM (Traversable.mapM $ hsUseToSigUse args_use) zipped_args + res' <- Traversable.mapM (hsUseToSigUse res_use) zipped_res + return (args', res') + where + args_use Port = SigPortIn + args_use (State n) = SigStateOld n + res_use Port = SigPortOut + res_use (State n) = SigStateNew n + + +hsUseToSigUse :: + (HsValueUse -> SigUse) -- ^ A function to actually map the use value + -> (SignalId, HsValueUse) -- ^ The signal to look at and its use + -> FlattenState SignalId -- ^ The resulting signal. This is probably the + -- same as the input, but it could be different. +hsUseToSigUse f (id, use) = do + info <- getSignalInfo id + id' <- case sigUse info of + -- Internal signals can be marked as different uses freely. + SigInternal -> do + return id + -- Signals that already have another use, must be duplicated before + -- marking. This prevents signals mapping to the same input or output + -- port or state variables and ports overlapping, etc. + otherwise -> do + duplicateSignal id + setSignalInfo id' (info { sigUse = f use}) + return id' + +-- | Duplicate the given signal, assigning its value to the new signal. +-- Returns the new signal id. +duplicateSignal :: SignalId -> FlattenState SignalId +duplicateSignal id = do + -- Find the type of the original signal + info <- getSignalInfo id + let ty = sigTy info + -- Generate a new signal (which is SigInternal for now, that will be + -- sorted out later on). + id' <- genSignalId SigInternal ty + -- Assign the old signal to the new signal + addDef $ UncondDef id id' + -- Replace the signal with the new signal + return id' + 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 +180,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 +213,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 +253,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 +-- | 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 -findState sigs id (State num) = - Just (num, Maybe.fromJust $ lookup id sigs) -findState _ _ _ = Nothing +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 +291,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: