7 import qualified CoreUtils
8 import qualified Control.Monad.State as State
10 -- | A datatype that maps each of the single values in a haskell structure to
11 -- a mapto. The map has the same structure as the haskell type mapped, ie
13 data HsValueMap mapto =
14 Tuple [HsValueMap mapto]
20 -- | Creates a HsValueMap with the same structure as the given type, using the
21 -- given function for mapping the single types.
23 Type.Type -- ^ The type to map to a HsValueMap
24 -> HsValueMap Type.Type -- ^ The resulting map and state
27 case Type.splitTyConApp_maybe ty of
29 if (TyCon.isTupleTyCon tycon)
31 Tuple (map mkHsValueMap args)
36 data FlatFunction = FlatFunction {
37 args :: [SignalDefMap],
39 --sigs :: [SignalDef],
44 type SignalUseMap = HsValueMap SignalUse
45 type SignalDefMap = HsValueMap SignalDef
47 useMapToDefMap :: SignalUseMap -> SignalDefMap
48 useMapToDefMap (Single (SignalUse u)) = Single (SignalDef u)
49 useMapToDefMap (Tuple uses) = Tuple (map useMapToDefMap uses)
52 data SignalUse = SignalUse {
56 data SignalDef = SignalDef {
61 appFunc :: HsFunction,
62 appArgs :: [SignalUseMap],
63 appRes :: SignalDefMap
66 data CondDef = CondDef {
73 -- | How is a given (single) value in a function's type (ie, argument or
74 -- return value) used?
76 Port -- ^ Use it as a port (input or output)
77 | State Int -- ^ Use it as state (input or output). The int is used to
78 -- match input state to output state.
79 | HighOrder { -- ^ Use it as a high order function input
80 hoName :: String, -- ^ Which function is passed in?
81 hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This
82 -- ^ map should only contain Port and other
87 type HsUseMap = HsValueMap HsValueUse
89 data HsFunction = HsFunction {
91 hsFuncArgs :: [HsUseMap],
96 CoreBndr, -- ^ The bind name
97 Either -- ^ The bind value which is either
98 SignalUseMap -- ^ a signal
100 HsValueUse, -- ^ or a HighOrder function
101 [SignalUse] -- ^ With these signals already applied to it
105 type FlattenState = State.State ([App], [CondDef], SignalId)
107 -- | Add an application to the current FlattenState
108 addApp :: App -> FlattenState ()
110 (apps, conds, n) <- State.get
111 State.put (a:apps, conds, n)
113 -- | Add a conditional definition to the current FlattenState
114 addCondDef :: CondDef -> FlattenState ()
116 (apps, conds, n) <- State.get
117 State.put (apps, c:conds, n)
119 -- | Generates a new signal id, which is unique within the current flattening.
120 genSignalId :: FlattenState SignalId
122 (apps, conds, n) <- State.get
123 State.put (apps, conds, n+1)
128 -> FlattenState SignalUseMap
130 genSignalUses ty = do
131 typeMapToUseMap tymap
133 -- First generate a map with the right structure containing the types
134 tymap = mkHsValueMap ty
138 -> FlattenState SignalUseMap
140 typeMapToUseMap (Single ty) = do
142 return $ Single (SignalUse id)
144 typeMapToUseMap (Tuple tymaps) = do
145 usemaps <- mapM typeMapToUseMap tymaps
146 return $ Tuple usemaps
148 -- | Flatten a haskell function
150 HsFunction -- ^ The function to flatten
151 -> CoreBind -- ^ The function value
152 -> FlatFunction -- ^ The resulting flat function
154 flattenFunction _ (Rec _) = error "Recursive binders not supported"
155 flattenFunction hsfunc bind@(NonRec var expr) =
156 FlatFunction args res apps conds
158 init_state = ([], [], 0)
159 (fres, end_state) = State.runState (flattenExpr [] expr) init_state
161 (apps, conds, _) = end_state
166 -> FlattenState ([SignalDefMap], SignalUseMap)
168 flattenExpr binds lam@(Lam b expr) = do
169 -- Find the type of the binder
170 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
171 -- Create signal names for the binder
172 defs <- genSignalUses arg_ty
173 let binds' = (b, Left defs):binds
174 (args, res) <- flattenExpr binds' expr
175 return ((useMapToDefMap defs) : args, res)
177 flattenExpr binds (Var id) =
179 Left sig_use -> return ([], sig_use)
180 Right _ -> error "Higher order functions not supported."
182 bind = Maybe.fromMaybe
183 (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
187 return ([], Tuple [])
190 -- vim: set ts=8 sw=2 sts=2 expandtab: