9 import Data.Traversable
10 import qualified DataCon
11 import qualified CoreUtils
12 import Control.Applicative
13 import Outputable ( showSDoc, ppr )
14 import qualified Data.Foldable as Foldable
15 import qualified Control.Monad.State as State
17 -- | A datatype that maps each of the single values in a haskell structure to
18 -- a mapto. The map has the same structure as the haskell type mapped, ie
20 data HsValueMap mapto =
21 Tuple [HsValueMap mapto]
25 instance Functor HsValueMap where
26 fmap f (Single s) = Single (f s)
27 fmap f (Tuple maps) = Tuple (map (fmap f) maps)
29 instance Foldable.Foldable HsValueMap where
30 foldMap f (Single s) = f s
31 -- The first foldMap folds a list of HsValueMaps, the second foldMap folds
32 -- each of the HsValueMaps in that list
33 foldMap f (Tuple maps) = Foldable.foldMap (Foldable.foldMap f) maps
35 instance Traversable HsValueMap where
36 traverse f (Single s) = Single <$> f s
37 traverse f (Tuple maps) = Tuple <$> (traverse (traverse f) maps)
39 data PassState s x = PassState (s -> (s, x))
41 instance Functor (PassState s) where
42 fmap f (PassState a) = PassState (\s -> let (s', a') = a s in (s', f a'))
44 instance Applicative (PassState s) where
45 pure x = PassState (\s -> (s, x))
46 PassState f <*> PassState x = PassState (\s -> let (s', f') = f s; (s'', x') = x s' in (s'', f' x'))
48 -- | Creates a HsValueMap with the same structure as the given type, using the
49 -- given function for mapping the single types.
51 Type.Type -- ^ The type to map to a HsValueMap
52 -> HsValueMap Type.Type -- ^ The resulting map and state
55 case Type.splitTyConApp_maybe ty of
57 if (TyCon.isTupleTyCon tycon)
59 Tuple (map mkHsValueMap args)
64 -- Extract the arguments from a data constructor application (that is, the
65 -- normal args, leaving out the type args).
66 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
67 dataConAppArgs dc args =
70 tycount = length $ DataCon.dataConAllTyVars dc
74 data FlatFunction = FlatFunction {
75 args :: [SignalDefMap],
77 --sigs :: [SignalDef],
82 type SignalUseMap = HsValueMap SignalUse
83 type SignalDefMap = HsValueMap SignalDef
85 useMapToDefMap :: SignalUseMap -> SignalDefMap
86 useMapToDefMap = fmap (\(SignalUse u) -> SignalDef u)
88 defMapToUseMap :: SignalDefMap -> SignalUseMap
89 defMapToUseMap = fmap (\(SignalDef u) -> SignalUse u)
93 data SignalUse = SignalUse {
97 data SignalDef = SignalDef {
102 appFunc :: HsFunction,
103 appArgs :: [SignalUseMap],
104 appRes :: SignalDefMap
105 } deriving (Show, Eq)
107 data CondDef = CondDef {
112 } deriving (Show, Eq)
114 -- | How is a given (single) value in a function's type (ie, argument or
115 -- return value) used?
117 Port -- ^ Use it as a port (input or output)
118 | State Int -- ^ Use it as state (input or output). The int is used to
119 -- match input state to output state.
120 | HighOrder { -- ^ Use it as a high order function input
121 hoName :: String, -- ^ Which function is passed in?
122 hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This
123 -- ^ map should only contain Port and other
128 type HsUseMap = HsValueMap HsValueUse
130 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
131 -- which all the Single elements are marked as State, with increasing state
133 useAsState :: HsValueMap a -> HsUseMap
137 -- Traverse the existing map, resulting in a function that maps an initial
138 -- state number to the final state number and the new map
139 PassState f = traverse asState map
140 -- Run this function to get the new map
142 -- This function maps each element to a State with a unique number, by
143 -- incrementing the state count.
144 asState x = PassState (\s -> (s+1, State s))
146 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
147 -- which all the Single elements are marked as Port.
148 useAsPort :: HsValueMap a -> HsUseMap
149 useAsPort map = fmap (\x -> Port) map
151 data HsFunction = HsFunction {
152 hsFuncName :: String,
153 hsFuncArgs :: [HsUseMap],
154 hsFuncRes :: HsUseMap
155 } deriving (Show, Eq)
158 CoreBndr, -- ^ The bind name
159 Either -- ^ The bind value which is either
160 SignalUseMap -- ^ a signal
162 HsValueUse, -- ^ or a HighOrder function
163 [SignalUse] -- ^ With these signals already applied to it
167 type FlattenState = State.State ([FApp], [CondDef], SignalId)
169 -- | Add an application to the current FlattenState
170 addApp :: FApp -> FlattenState ()
172 (apps, conds, n) <- State.get
173 State.put (a:apps, conds, n)
175 -- | Add a conditional definition to the current FlattenState
176 addCondDef :: CondDef -> FlattenState ()
178 (apps, conds, n) <- State.get
179 State.put (apps, c:conds, n)
181 -- | Generates a new signal id, which is unique within the current flattening.
182 genSignalId :: FlattenState SignalId
184 (apps, conds, n) <- State.get
185 State.put (apps, conds, n+1)
190 -> FlattenState SignalUseMap
192 genSignalUses ty = do
193 typeMapToUseMap tymap
195 -- First generate a map with the right structure containing the types
196 tymap = mkHsValueMap ty
200 -> FlattenState SignalUseMap
202 typeMapToUseMap (Single ty) = do
204 return $ Single (SignalUse id)
206 typeMapToUseMap (Tuple tymaps) = do
207 usemaps <- State.mapM typeMapToUseMap tymaps
208 return $ Tuple usemaps
210 -- | Flatten a haskell function
212 HsFunction -- ^ The function to flatten
213 -> CoreBind -- ^ The function value
214 -> FlatFunction -- ^ The resulting flat function
216 flattenFunction _ (Rec _) = error "Recursive binders not supported"
217 flattenFunction hsfunc bind@(NonRec var expr) =
218 FlatFunction args res apps conds
220 init_state = ([], [], 0)
221 (fres, end_state) = State.runState (flattenExpr [] expr) init_state
223 (apps, conds, _) = end_state
228 -> FlattenState ([SignalDefMap], SignalUseMap)
230 flattenExpr binds lam@(Lam b expr) = do
231 -- Find the type of the binder
232 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
233 -- Create signal names for the binder
234 defs <- genSignalUses arg_ty
235 let binds' = (b, Left defs):binds
236 (args, res) <- flattenExpr binds' expr
237 return ((useMapToDefMap defs) : args, res)
239 flattenExpr binds (Var id) =
241 Left sig_use -> return ([], sig_use)
242 Right _ -> error "Higher order functions not supported."
244 bind = Maybe.fromMaybe
245 (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
248 flattenExpr binds app@(App _ _) = do
249 -- Is this a data constructor application?
250 case CoreUtils.exprIsConApp_maybe app of
251 -- Is this a tuple construction?
252 Just (dc, args) -> if DataCon.isTupleCon dc
254 flattenBuildTupleExpr binds (dataConAppArgs dc args)
256 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
258 -- Normal function application
259 let ((Var f), args) = collectArgs app in
260 flattenApplicationExpr binds (CoreUtils.exprType app) f args
262 flattenBuildTupleExpr binds args = do
263 -- Flatten each of our args
264 flat_args <- (State.mapM (flattenExpr binds) args)
265 -- Check and split each of the arguments
266 let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
267 let res = Tuple arg_ress
270 -- | Flatten a normal application expression
271 flattenApplicationExpr binds ty f args = do
272 -- Find the function to call
273 let func = appToHsFunction ty f args
274 -- Flatten each of our args
275 flat_args <- (State.mapM (flattenExpr binds) args)
276 -- Check and split each of the arguments
277 let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
278 -- Generate signals for our result
279 res <- genSignalUses ty
280 -- Create the function application
284 appRes = useMapToDefMap res
288 -- | Check a flattened expression to see if it is valid to use as a
289 -- function argument. The first argument is the original expression for
290 -- use in the error message.
292 let (args, res) = flat in
294 then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
297 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
298 (b_args, b_res) <- flattenExpr binds bexpr
301 error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
303 let binds' = (b, Left b_res) : binds in
304 flattenExpr binds' expr
306 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
308 flattenExpr binds expr@(Case (Var v) b _ alts) =
310 [alt] -> flattenSingleAltCaseExpr binds v b alt
311 otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
313 flattenSingleAltCaseExpr ::
315 -- A list of bindings in effect
316 -> Var.Var -- The scrutinee
317 -> CoreBndr -- The binder to bind the scrutinee to
318 -> CoreAlt -- The single alternative
319 -> FlattenState ( [SignalDefMap], SignalUseMap)
321 flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
322 if not (DataCon.isTupleCon datacon)
324 error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
327 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
328 -- the existing bindings list and get the portname map for each of
330 Left (Tuple tuple_sigs) = Maybe.fromMaybe
331 (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
333 -- TODO include b in the binds list
334 -- Merge our existing binds with the new binds.
335 binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds
337 -- Expand the expression with the new binds list
338 flattenExpr binds' expr
339 flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
344 return ([], Tuple [])
347 Type.Type -- ^ The return type
348 -> Var.Var -- ^ The function to call
349 -> [CoreExpr] -- ^ The function arguments
350 -> HsFunction -- ^ The needed HsFunction
352 appToHsFunction ty f args =
353 HsFunction hsname hsargs hsres
355 hsname = Name.getOccString f
356 hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
357 hsres = useAsPort (mkHsValueMap ty)
359 -- vim: set ts=8 sw=2 sts=2 expandtab: