X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=4194904c046ea211fbd83a6f0b7978f737415d80;hb=e273d2759db01787f0599a1cbe9059864e1704d7;hp=b08ead4e9c53937632795b4c20883631ad77fa00;hpb=59e4501737547855380d1ba49629d5e2496bbfa0;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Flatten.hs b/Flatten.hs index b08ead4..4194904 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -4,62 +4,19 @@ import Control.Monad import qualified Var import qualified Type import qualified Name -import qualified TyCon import qualified Maybe -import Data.Traversable +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 Data.Foldable as Foldable import qualified Control.Monad.State as State --- | A datatype that maps each of the single values in a haskell structure to --- a mapto. The map has the same structure as the haskell type mapped, ie --- nested tuples etc. -data HsValueMap mapto = - Tuple [HsValueMap mapto] - | Single mapto - deriving (Show, Eq, Ord) - -instance Functor HsValueMap where - fmap f (Single s) = Single (f s) - fmap f (Tuple maps) = Tuple (map (fmap f) maps) - -instance Foldable.Foldable HsValueMap where - foldMap f (Single s) = f s - -- The first foldMap folds a list of HsValueMaps, the second foldMap folds - -- each of the HsValueMaps in that list - foldMap f (Tuple maps) = Foldable.foldMap (Foldable.foldMap f) maps - -instance Traversable HsValueMap where - traverse f (Single s) = Single <$> f s - traverse f (Tuple maps) = Tuple <$> (traverse (traverse f) maps) - -data PassState s x = PassState (s -> (s, x)) - -instance Functor (PassState s) where - fmap f (PassState a) = PassState (\s -> let (s', a') = a s in (s', f a')) - -instance Applicative (PassState s) where - pure x = PassState (\s -> (s, x)) - PassState f <*> PassState x = PassState (\s -> let (s', f') = f s; (s'', x') = x s' in (s'', f' x')) - --- | Creates a HsValueMap with the same structure as the given type, using the --- given function for mapping the single types. -mkHsValueMap :: - Type.Type -- ^ The type to map to a HsValueMap - -> HsValueMap Type.Type -- ^ The resulting map and state - -mkHsValueMap ty = - case Type.splitTyConApp_maybe ty of - Just (tycon, args) -> - if (TyCon.isTupleTyCon tycon) - then - Tuple (map mkHsValueMap args) - else - Single ty - Nothing -> Single ty +import HsValueMap +import TranslatorTypes +import FlattenTypes -- Extract the arguments from a data constructor application (that is, the -- normal args, leaving out the type args). @@ -69,143 +26,25 @@ dataConAppArgs dc args = where tycount = length $ DataCon.dataConAllTyVars dc - - -data FlatFunction = FlatFunction { - args :: [SignalDefMap], - res :: SignalUseMap, - --sigs :: [SignalDef], - apps :: [FApp], - conds :: [CondDef] -} deriving (Show, Eq) - -type SignalUseMap = HsValueMap SignalUse -type SignalDefMap = HsValueMap SignalDef - -useMapToDefMap :: SignalUseMap -> SignalDefMap -useMapToDefMap = fmap (\(SignalUse u) -> SignalDef u) - -defMapToUseMap :: SignalDefMap -> SignalUseMap -defMapToUseMap = fmap (\(SignalDef u) -> SignalUse u) - - -type SignalId = Int -data SignalUse = SignalUse { - sigUseId :: SignalId -} deriving (Show, Eq) - -data SignalDef = SignalDef { - sigDefId :: SignalId -} deriving (Show, Eq) - -data FApp = FApp { - appFunc :: HsFunction, - appArgs :: [SignalUseMap], - appRes :: SignalDefMap -} deriving (Show, Eq) - -data CondDef = CondDef { - cond :: SignalUse, - high :: SignalUse, - low :: SignalUse, - condRes :: SignalDef -} deriving (Show, Eq) - --- | How is a given (single) value in a function's type (ie, argument or --- return value) used? -data HsValueUse = - Port -- ^ Use it as a port (input or output) - | State Int -- ^ Use it as state (input or output). The int is used to - -- match input state to output state. - | HighOrder { -- ^ Use it as a high order function input - hoName :: String, -- ^ Which function is passed in? - hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This - -- ^ map should only contain Port and other - -- HighOrder values. - } - deriving (Show, Eq, Ord) - -type HsUseMap = HsValueMap HsValueUse - --- | Builds a HsUseMap with the same structure has the given HsValueMap in --- which all the Single elements are marked as State, with increasing state --- numbers. -useAsState :: HsValueMap a -> HsUseMap -useAsState map = - map' - where - -- Traverse the existing map, resulting in a function that maps an initial - -- state number to the final state number and the new map - PassState f = traverse asState map - -- Run this function to get the new map - (_, map') = f 0 - -- This function maps each element to a State with a unique number, by - -- incrementing the state count. - asState x = PassState (\s -> (s+1, State s)) - --- | Builds a HsUseMap with the same structure has the given HsValueMap in --- which all the Single elements are marked as Port. -useAsPort :: HsValueMap a -> HsUseMap -useAsPort map = fmap (\x -> Port) map - -data HsFunction = HsFunction { - hsFuncName :: String, - hsFuncArgs :: [HsUseMap], - hsFuncRes :: HsUseMap -} deriving (Show, Eq, Ord) - -type BindMap = [( - CoreBndr, -- ^ The bind name - Either -- ^ The bind value which is either - SignalUseMap -- ^ a signal - ( - HsValueUse, -- ^ or a HighOrder function - [SignalUse] -- ^ With these signals already applied to it - ) - )] - -type FlattenState = State.State ([FApp], [CondDef], SignalId) - --- | Add an application to the current FlattenState -addApp :: FApp -> 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 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 = do - (apps, conds, n) <- State.get - State.put (apps, conds, n+1) - return n - -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 + info' = if id `elem` ids then info { sigUse = use} else info -typeMapToUseMap :: - HsValueMap Type.Type - -> FlattenState SignalUseMap - -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 :: @@ -215,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 apps conds sigs'''' where - init_state = ([], [], 0) + init_state = ([], [], [], 0) (fres, end_state) = State.runState (flattenExpr [] expr) init_state + (apps, conds, 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 @@ -276,12 +125,12 @@ 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 return ([], res) @@ -316,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) @@ -356,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 (Int, 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) + -> [(Int, 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)] + -- | 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: