X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=338a1ca1b1f91e39b0c968321a339b7417115f5b;hb=f476ee837aaea76011f8e47e1181e4a09ec86555;hp=8a230162daf6f43cf21036390c6a072ae261ce8d;hpb=41e6a89a1d9347431e80b895cb74ab5ecc03e9b7;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Flatten.hs b/Flatten.hs index 8a23016..338a1ca 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -5,8 +5,11 @@ 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 +import qualified Data.Foldable as Foldable import Control.Applicative import Outputable ( showSDoc, ppr ) import qualified Control.Monad.State as State @@ -23,27 +26,25 @@ dataConAppArgs dc args = where tycount = length $ DataCon.dataConAllTyVars dc -genSignalUses :: +genSignals :: Type.Type - -> FlattenState SignalUseMap - -genSignalUses ty = do - typeMapToUseMap tymap + -> FlattenState SignalMap + +genSignals ty = + -- First generate a map with the right structure containing the types, and + -- generate signals for each of them. + Traversable.mapM (\ty -> genSignalId SigInternal ty) (mkHsValueMap ty) + +-- | Marks a signal as the given SigUse, if its id is in the list of id's +-- given. +markSignals :: SigUse -> [SignalId] -> (SignalId, SignalInfo) -> (SignalId, SignalInfo) +markSignals use ids (id, info) = + (id, info') where - -- First generate a map with the right structure containing the types - tymap = mkHsValueMap ty - -typeMapToUseMap :: - HsValueMap Type.Type - -> FlattenState SignalUseMap + info' = if id `elem` ids then info { sigUse = use} else info -typeMapToUseMap (Single ty) = do - id <- genSignalId - return $ Single (SignalUse id) - -typeMapToUseMap (Tuple tymaps) = do - usemaps <- State.mapM typeMapToUseMap tymaps - return $ Tuple usemaps +markSignal :: SigUse -> SignalId -> (SignalId, SignalInfo) -> (SignalId, SignalInfo) +markSignal use id = markSignals use [id] -- | Flatten a haskell function flattenFunction :: @@ -53,26 +54,36 @@ flattenFunction :: flattenFunction _ (Rec _) = error "Recursive binders not supported" flattenFunction hsfunc bind@(NonRec var expr) = - FlatFunction args res apps conds + FlatFunction args res defs sigs'''' where init_state = ([], [], 0) (fres, end_state) = State.runState (flattenExpr [] expr) init_state + (defs, sigs, _) = end_state (args, res) = fres - (apps, conds, _) = end_state + 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 ([SignalDefMap], SignalUseMap) + -> FlattenState ([SignalMap], SignalMap) flattenExpr binds lam@(Lam b expr) = do -- Find the type of the binder let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam) -- Create signal names for the binder - defs <- genSignalUses arg_ty + defs <- genSignals arg_ty let binds' = (b, Left defs):binds (args, res) <- flattenExpr binds' expr - return ((useMapToDefMap defs) : args, res) + return (defs : args, res) flattenExpr binds (Var id) = case bind of @@ -114,14 +125,14 @@ flattenExpr binds app@(App _ _) = do -- Check and split each of the arguments let (_, arg_ress) = unzip (zipWith checkArg args flat_args) -- Generate signals for our result - res <- genSignalUses ty + res <- genSignals ty -- Create the function application let app = FApp { appFunc = func, appArgs = arg_ress, - appRes = useMapToDefMap res + 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 @@ -154,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 ( [SignalDefMap], SignalUseMap) + -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) = if not (DataCon.isTupleCon datacon) @@ -194,4 +205,50 @@ appToHsFunction ty f args = hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args hsres = useAsPort (mkHsValueMap ty) +-- | 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 + -> [(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. + +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, 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: