X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=blobdiff_plain;f=Flatten.hs;h=d25ef73aceabb2feec43007b1a469b267a72ce09;hp=b08ead4e9c53937632795b4c20883631ad77fa00;hb=HEAD;hpb=59e4501737547855380d1ba49629d5e2496bbfa0 diff --git a/Flatten.hs b/Flatten.hs index b08ead4..d25ef73 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -1,65 +1,27 @@ module Flatten where import CoreSyn -import Control.Monad +import qualified Control.Monad as 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 TyCon +import qualified Literal import qualified CoreUtils +import qualified TysWiredIn +import qualified IdInfo +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 qualified Control.Monad.Trans.State as State + +import HsValueMap +import TranslatorTypes +import FlattenTypes +import CoreTools -- Extract the arguments from a data constructor application (that is, the -- normal args, leaving out the type args). @@ -69,181 +31,150 @@ 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 - -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 :: HsFunction -- ^ The function to flatten - -> CoreBind -- ^ The function value + -> (CoreBndr, CoreExpr) -- ^ The function value -> FlatFunction -- ^ The resulting flat function -flattenFunction _ (Rec _) = error "Recursive binders not supported" -flattenFunction hsfunc bind@(NonRec var expr) = - FlatFunction args res apps conds +flattenFunction hsfunc (var, expr) = + FlatFunction args res defs sigs where init_state = ([], [], 0) - (fres, end_state) = State.runState (flattenExpr [] expr) init_state + (fres, end_state) = State.runState (flattenTopExpr hsfunc expr) init_state + (defs, sigs, _) = end_state (args, res) = fres - (apps, conds, _) = end_state +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' + +-- | Creates a new internal signal with the same type as the given signal +copySignal :: SignalId -> FlattenState SignalId +copySignal 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). + genSignalId SigInternal ty + +-- | Duplicate the given signal, assigning its value to the new signal. +-- Returns the new signal id. +duplicateSignal :: SignalId -> FlattenState SignalId +duplicateSignal id = do + -- Create a new signal + id' <- copySignal id + -- Assign the old signal to the new signal + addDef $ UncondDef (Left id) id' + -- Replace the signal with the new signal + return id' + 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 + -- Add name hints to the generated signals + let binder_name = Name.getOccString b + Traversable.mapM (addNameHint binder_name) defs let binds' = (b, Left defs):binds (args, res) <- flattenExpr binds' expr - return ((useMapToDefMap defs) : args, res) - -flattenExpr binds (Var id) = - case bind of - Left sig_use -> return ([], sig_use) - Right _ -> error "Higher order functions not supported." - where - bind = Maybe.fromMaybe - (error $ "Argument " ++ Name.getOccString id ++ "is unknown") - (lookup id binds) + return (defs : args, res) + +flattenExpr binds var@(Var id) = + case Var.globalIdVarDetails id of + IdInfo.NotGlobalId -> + let + bind = Maybe.fromMaybe + (error $ "Local value " ++ Name.getOccString id ++ " is unknown") + (lookup id binds) + in + case bind of + Left sig_use -> return ([], sig_use) + Right _ -> error "Higher order functions not supported." + IdInfo.DataConWorkId datacon -> do + if DataCon.isTupleCon datacon && (null $ DataCon.dataConAllTyVars datacon) + then do + -- Empty tuple construction + return ([], Tuple []) + else do + lit <- dataConToLiteral datacon + let ty = CoreUtils.exprType var + sig_id <- genSignalId SigInternal ty + -- Add a name hint to the signal + addNameHint (Name.getOccString id) sig_id + addDef (UncondDef (Right $ Literal lit Nothing) sig_id) + return ([], Single sig_id) + IdInfo.VanillaGlobal -> + -- Treat references to globals as an application with zero elements + flattenApplicationExpr binds (CoreUtils.exprType var) id [] + otherwise -> + error $ "Ids other than local vars and dataconstructors not supported: " ++ (showSDoc $ ppr id) flattenExpr binds app@(App _ _) = do -- Is this a data constructor application? @@ -257,91 +188,227 @@ flattenExpr binds app@(App _ _) = do otherwise -> -- Normal function application let ((Var f), args) = collectArgs app in - flattenApplicationExpr binds (CoreUtils.exprType app) f args + let fname = Name.getOccString f in + if fname == "fst" || fname == "snd" then do + (args', Tuple [a, b]) <- flattenExpr binds (last args) + return (args', if fname == "fst" then a else b) + else if fname == "patError" then do + -- This is essentially don't care, since the program will error out + -- here. We'll just define undriven signals here. + let (argtys, resty) = Type.splitFunTys $ CoreUtils.exprType app + args <- mapM genSignals argtys + res <- genSignals resty + mapM (Traversable.mapM (addNameHint "NC")) args + Traversable.mapM (addNameHint "NC") res + return (args, res) + else if fname == "==" then do + -- Flatten the last two arguments (this skips the type arguments) + ([], a) <- flattenExpr binds (last $ init args) + ([], b) <- flattenExpr binds (last args) + res <- mkEqComparisons a b + return ([], res) + else if fname == "fromInteger" then do + let [to_ty, to_dict, val] = args + -- We assume this is an application of the GHC.Integer.smallInteger + -- function to a literal + let App smallint (Lit lit) = val + let (Literal.MachInt int) = lit + let ty = CoreUtils.exprType app + sig_id <- genSignalId SigInternal ty + -- TODO: fromInteger is defined for more types than just SizedWord + let len = sized_word_len ty + -- Use a to_unsigned to translate the number (a natural) to an unsiged + -- (array of bits) + let lit_str = "to_unsigned(" ++ (show int) ++ ", " ++ (show len) ++ ")" + -- Set the signal to our literal unconditionally, but add the type so + -- the literal will be typecast to the proper type. + addDef $ UncondDef (Right $ Literal lit_str (Just ty)) sig_id + return ([], Single sig_id) + else + flattenApplicationExpr binds (CoreUtils.exprType app) f args where + mkEqComparisons :: SignalMap -> SignalMap -> FlattenState SignalMap + mkEqComparisons a b = do + let zipped = zipValueMaps a b + Traversable.mapM mkEqComparison zipped + + mkEqComparison :: (SignalId, SignalId) -> FlattenState SignalId + mkEqComparison (a, b) = do + -- Generate a signal to hold our result + res <- genSignalId SigInternal TysWiredIn.boolTy + -- Add a name hint to the signal + addNameHint ("s" ++ show a ++ "_eq_s" ++ show b) res + addDef (UncondDef (Right $ Eq a b) res) + return res + flattenBuildTupleExpr binds args = do -- Flatten each of our args - flat_args <- (State.mapM (flattenExpr binds) args) + flat_args <- (mapM (flattenExpr binds) args) -- Check and split each of the arguments let (_, arg_ress) = unzip (zipWith checkArg args flat_args) let res = Tuple arg_ress return ([], res) - -- | Flatten a normal application expression - flattenApplicationExpr binds ty f args = do - -- Find the function to call - let func = appToHsFunction ty f args - -- Flatten each of our args - flat_args <- (State.mapM (flattenExpr binds) args) - -- Check and split each of the arguments - let (_, arg_ress) = unzip (zipWith checkArg args flat_args) - -- Generate signals for our result - res <- genSignalUses ty - -- Create the function application - let app = FApp { - appFunc = func, - appArgs = arg_ress, - appRes = useMapToDefMap res - } - addApp 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 - -- use in the error message. - checkArg arg flat = - let (args, res) = flat in - if not (null args) - then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg) - else flat - flattenExpr binds l@(Let (NonRec b bexpr) expr) = do (b_args, b_res) <- flattenExpr binds bexpr if not (null b_args) then error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l) - else - let binds' = (b, Left b_res) : binds in + else do + let binds' = (b, Left b_res) : binds + -- Add name hints to the generated signals + let binder_name = Name.getOccString b + Traversable.mapM (addNameHint binder_name) b_res flattenExpr binds' expr flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l) -flattenExpr binds expr@(Case (Var v) b _ alts) = +flattenExpr binds expr@(Case scrut b _ alts) = do + -- TODO: Special casing for higher order functions + -- Flatten the scrutinee + (_, res) <- flattenExpr binds scrut + -- Put the scrutinee in the BindMap + let binds' = (b, Left res) : binds case alts of - [alt] -> flattenSingleAltCaseExpr binds v b alt - otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr) + [alt] -> flattenSingleAltCaseExpr binds' res b alt + -- Reverse the alternatives, so the __DEFAULT alternative ends up last + otherwise -> flattenMultipleAltCaseExpr binds' res b (reverse alts) where flattenSingleAltCaseExpr :: BindMap -- A list of bindings in effect - -> Var.Var -- The scrutinee + -> SignalMap -- The scrutinee -> CoreBndr -- The binder to bind the scrutinee to -> CoreAlt -- The single alternative - -> FlattenState ( [SignalDefMap], SignalUseMap) - -- See expandExpr - flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) = - if not (DataCon.isTupleCon datacon) - then - error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt) + -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr + + flattenSingleAltCaseExpr binds scrut b alt@(DataAlt datacon, bind_vars, expr) = + if DataCon.isTupleCon datacon + then do + -- Unpack the scrutinee (which must be a variable bound to a tuple) in + -- the existing bindings list and get the portname map for each of + -- it's elements. + let Tuple tuple_sigs = scrut + -- Add name hints to the returned signals + let binder_name = Name.getOccString b + Monad.zipWithM (\name sigs -> Traversable.mapM (addNameHint $ Name.getOccString name) sigs) bind_vars tuple_sigs + -- Merge our existing binds with the new binds. + let binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds + -- Expand the expression with the new binds list + flattenExpr binds' expr else - let - -- Lookup the scrutinee (which must be a variable bound to a tuple) in - -- the existing bindings list and get the portname map for each of - -- it's elements. - Left (Tuple tuple_sigs) = Maybe.fromMaybe - (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v) - (lookup v binds) - -- TODO include b in the binds list - -- Merge our existing binds with the new binds. - binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds - in - -- Expand the expression with the new binds list - flattenExpr binds' expr + if null bind_vars + then + -- DataAlts without arguments don't need processing + -- (flattenMultipleAltCaseExpr will have done this already). + flattenExpr binds expr + else + error $ "Dataconstructors other than tuple constructors cannot have binder arguments in case pattern of alternative: " ++ (showSDoc $ ppr alt) + + flattenSingleAltCaseExpr binds _ _ alt@(DEFAULT, [], expr) = + flattenExpr binds expr + flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt) - - -flattenExpr _ _ = do - return ([], Tuple []) + flattenMultipleAltCaseExpr :: + BindMap + -- A list of bindings in effect + -> SignalMap -- The scrutinee + -> CoreBndr -- The binder to bind the scrutinee to + -> [CoreAlt] -- The alternatives + -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr + + flattenMultipleAltCaseExpr binds scrut b (a:a':alts) = do + (args, res) <- flattenSingleAltCaseExpr binds scrut b a + (args', res') <- flattenMultipleAltCaseExpr binds scrut b (a':alts) + case a of + (DataAlt datacon, bind_vars, expr) -> do + lit <- dataConToLiteral datacon + -- The scrutinee must be a single signal + let Single sig = scrut + -- Create a signal that contains a boolean + boolsigid <- genSignalId SigInternal TysWiredIn.boolTy + addNameHint ("s" ++ show sig ++ "_eq_" ++ lit) boolsigid + let expr = EqLit sig lit + addDef (UncondDef (Right expr) boolsigid) + -- Create conditional assignments of either args/res or + -- args'/res based on boolsigid, and return the result. + -- TODO: It seems this adds the name hint twice? + our_args <- Monad.zipWithM (mkConditionals boolsigid) args args' + our_res <- mkConditionals boolsigid res res' + return (our_args, our_res) + otherwise -> + error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr a) + where + -- Select either the first or second signal map depending on the value + -- of the first argument (True == first map, False == second map) + mkConditionals :: SignalId -> SignalMap -> SignalMap -> FlattenState SignalMap + mkConditionals boolsigid true false = do + let zipped = zipValueMaps true false + Traversable.mapM (mkConditional boolsigid) zipped + + mkConditional :: SignalId -> (SignalId, SignalId) -> FlattenState SignalId + mkConditional boolsigid (true, false) = do + -- Create a new signal (true and false should be identically typed, + -- so it doesn't matter which one we copy). + res <- copySignal true + addDef (CondDef boolsigid true false res) + return res + + flattenMultipleAltCaseExpr binds scrut b (a:alts) = + flattenSingleAltCaseExpr binds scrut b a + +flattenExpr _ expr = do + error $ "Unsupported expression: " ++ (showSDoc $ ppr expr) + +-- | Flatten a normal application expression +flattenApplicationExpr binds ty f args = do + -- Find the function to call + let func = appToHsFunction ty f args + -- Flatten each of our args + flat_args <- (mapM (flattenExpr binds) args) + -- Check and split each of the arguments + let (_, arg_ress) = unzip (zipWith checkArg args flat_args) + -- Generate signals for our result + res <- genSignals ty + -- Add name hints to the generated signals + let resname = Name.getOccString f ++ "_res" + Traversable.mapM (addNameHint resname) res + -- Create the function application + let app = FApp { + appFunc = func, + appArgs = arg_ress, + appRes = res + } + 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 +-- use in the error message. +checkArg arg flat = + let (args, res) = flat in + if not (null args) + then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg) + else flat + +-- | Translates a dataconstructor without arguments to the corresponding +-- literal. +dataConToLiteral :: DataCon.DataCon -> FlattenState String +dataConToLiteral datacon = do + let tycon = DataCon.dataConTyCon datacon + let tyname = TyCon.tyConName tycon + case Name.getOccString tyname of + -- TODO: Do something more robust than string matching + "Bit" -> do + let dcname = DataCon.dataConName datacon + let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'" + return lit + "Bool" -> do + let dcname = DataCon.dataConName datacon + let lit = case Name.getOccString dcname of "True" -> "true"; "False" -> "false" + return lit + otherwise -> + error $ "Literals of type " ++ (Name.getOccString tyname) ++ " not supported." appToHsFunction :: Type.Type -- ^ The return type @@ -356,4 +423,26 @@ 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 + -- vim: set ts=8 sw=2 sts=2 expandtab: