7 import qualified DataCon
8 import qualified CoreUtils
9 import Outputable ( showSDoc, ppr )
10 import qualified Control.Monad.State as State
12 -- | A datatype that maps each of the single values in a haskell structure to
13 -- a mapto. The map has the same structure as the haskell type mapped, ie
15 data HsValueMap mapto =
16 Tuple [HsValueMap mapto]
20 instance Functor HsValueMap where
21 fmap f (Single s) = Single (f s)
22 fmap f (Tuple maps) = Tuple (fmap (fmap f) maps)
24 -- | Creates a HsValueMap with the same structure as the given type, using the
25 -- given function for mapping the single types.
27 Type.Type -- ^ The type to map to a HsValueMap
28 -> HsValueMap Type.Type -- ^ The resulting map and state
31 case Type.splitTyConApp_maybe ty of
33 if (TyCon.isTupleTyCon tycon)
35 Tuple (map mkHsValueMap args)
40 -- Extract the arguments from a data constructor application (that is, the
41 -- normal args, leaving out the type args).
42 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
43 dataConAppArgs dc args =
46 tycount = length $ DataCon.dataConAllTyVars dc
50 data FlatFunction = FlatFunction {
51 args :: [SignalDefMap],
53 --sigs :: [SignalDef],
58 type SignalUseMap = HsValueMap SignalUse
59 type SignalDefMap = HsValueMap SignalDef
61 useMapToDefMap :: SignalUseMap -> SignalDefMap
62 useMapToDefMap = fmap (\(SignalUse u) -> SignalDef u)
64 defMapToUseMap :: SignalDefMap -> SignalUseMap
65 defMapToUseMap = fmap (\(SignalDef u) -> SignalUse u)
69 data SignalUse = SignalUse {
73 data SignalDef = SignalDef {
78 appFunc :: HsFunction,
79 appArgs :: [SignalUseMap],
80 appRes :: SignalDefMap
83 data CondDef = CondDef {
90 -- | How is a given (single) value in a function's type (ie, argument or
91 -- return value) used?
93 Port -- ^ Use it as a port (input or output)
94 | State Int -- ^ Use it as state (input or output). The int is used to
95 -- match input state to output state.
96 | HighOrder { -- ^ Use it as a high order function input
97 hoName :: String, -- ^ Which function is passed in?
98 hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This
99 -- ^ map should only contain Port and other
104 type HsUseMap = HsValueMap HsValueUse
106 data HsFunction = HsFunction {
107 hsFuncName :: String,
108 hsFuncArgs :: [HsUseMap],
109 hsFuncRes :: HsUseMap
110 } deriving (Show, Eq)
113 CoreBndr, -- ^ The bind name
114 Either -- ^ The bind value which is either
115 SignalUseMap -- ^ a signal
117 HsValueUse, -- ^ or a HighOrder function
118 [SignalUse] -- ^ With these signals already applied to it
122 type FlattenState = State.State ([FApp], [CondDef], SignalId)
124 -- | Add an application to the current FlattenState
125 addApp :: FApp -> FlattenState ()
127 (apps, conds, n) <- State.get
128 State.put (a:apps, conds, n)
130 -- | Add a conditional definition to the current FlattenState
131 addCondDef :: CondDef -> FlattenState ()
133 (apps, conds, n) <- State.get
134 State.put (apps, c:conds, n)
136 -- | Generates a new signal id, which is unique within the current flattening.
137 genSignalId :: FlattenState SignalId
139 (apps, conds, n) <- State.get
140 State.put (apps, conds, n+1)
145 -> FlattenState SignalUseMap
147 genSignalUses ty = do
148 typeMapToUseMap tymap
150 -- First generate a map with the right structure containing the types
151 tymap = mkHsValueMap ty
155 -> FlattenState SignalUseMap
157 typeMapToUseMap (Single ty) = do
159 return $ Single (SignalUse id)
161 typeMapToUseMap (Tuple tymaps) = do
162 usemaps <- mapM typeMapToUseMap tymaps
163 return $ Tuple usemaps
165 -- | Flatten a haskell function
167 HsFunction -- ^ The function to flatten
168 -> CoreBind -- ^ The function value
169 -> FlatFunction -- ^ The resulting flat function
171 flattenFunction _ (Rec _) = error "Recursive binders not supported"
172 flattenFunction hsfunc bind@(NonRec var expr) =
173 FlatFunction args res apps conds
175 init_state = ([], [], 0)
176 (fres, end_state) = State.runState (flattenExpr [] expr) init_state
178 (apps, conds, _) = end_state
183 -> FlattenState ([SignalDefMap], SignalUseMap)
185 flattenExpr binds lam@(Lam b expr) = do
186 -- Find the type of the binder
187 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
188 -- Create signal names for the binder
189 defs <- genSignalUses arg_ty
190 let binds' = (b, Left defs):binds
191 (args, res) <- flattenExpr binds' expr
192 return ((useMapToDefMap defs) : args, res)
194 flattenExpr binds (Var id) =
196 Left sig_use -> return ([], sig_use)
197 Right _ -> error "Higher order functions not supported."
199 bind = Maybe.fromMaybe
200 (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
203 flattenExpr binds app@(App _ _) = do
204 -- Is this a data constructor application?
205 case CoreUtils.exprIsConApp_maybe app of
206 -- Is this a tuple construction?
207 Just (dc, args) -> if DataCon.isTupleCon dc
209 flattenBuildTupleExpr binds (dataConAppArgs dc args)
211 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
213 -- Normal function application
214 let ((Var f), args) = collectArgs app in
215 flattenApplicationExpr binds (CoreUtils.exprType app) f args
217 flattenBuildTupleExpr = error $ "Tuple construction not supported: " ++ (showSDoc $ ppr app)
218 flattenApplicationExpr binds ty f args = error $ "Function application not supported: " ++ (showSDoc $ ppr app)
221 return ([], Tuple [])
224 -- vim: set ts=8 sw=2 sts=2 expandtab: