8 import qualified Control.Arrow as Arrow
9 import qualified DataCon
10 import qualified CoreUtils
11 import qualified Data.Traversable as Traversable
12 import qualified Data.Foldable as Foldable
13 import Control.Applicative
14 import Outputable ( showSDoc, ppr )
15 import qualified Control.Monad.State as State
18 import TranslatorTypes
21 -- Extract the arguments from a data constructor application (that is, the
22 -- normal args, leaving out the type args).
23 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
24 dataConAppArgs dc args =
27 tycount = length $ DataCon.dataConAllTyVars dc
31 -> FlattenState SignalMap
34 -- First generate a map with the right structure containing the types, and
35 -- generate signals for each of them.
36 Traversable.mapM (\ty -> genSignalId SigInternal ty) (mkHsValueMap ty)
38 -- | Marks a signal as the given SigUse, if its id is in the list of id's
40 markSignals :: SigUse -> [SignalId] -> (SignalId, SignalInfo) -> (SignalId, SignalInfo)
41 markSignals use ids (id, info) =
44 info' = if id `elem` ids then info { sigUse = use} else info
46 markSignal :: SigUse -> SignalId -> (SignalId, SignalInfo) -> (SignalId, SignalInfo)
47 markSignal use id = markSignals use [id]
49 -- | Flatten a haskell function
51 HsFunction -- ^ The function to flatten
52 -> CoreBind -- ^ The function value
53 -> FlatFunction -- ^ The resulting flat function
55 flattenFunction _ (Rec _) = error "Recursive binders not supported"
56 flattenFunction hsfunc bind@(NonRec var expr) =
57 FlatFunction args res defs sigs''''
59 init_state = ([], [], 0)
60 (fres, end_state) = State.runState (flattenExpr [] expr) init_state
61 (defs, sigs, _) = end_state
63 arg_ports = concat (map Foldable.toList args)
64 res_ports = Foldable.toList res
65 -- Mark args and result signals as input and output ports resp.
66 sigs' = fmap (markSignals SigPortIn arg_ports) sigs
67 sigs'' = fmap (markSignals SigPortOut res_ports) sigs'
68 -- Mark args and result states as old and new state resp.
69 args_states = concat $ zipWith stateList (hsFuncArgs hsfunc) args
70 sigs''' = foldl (\s (num, id) -> map (markSignal (SigStateOld num) id) s) sigs'' args_states
71 res_states = stateList (hsFuncRes hsfunc) res
72 sigs'''' = foldl (\s (num, id) -> map (markSignal (SigStateNew num) id) s) sigs''' res_states
77 -> FlattenState ([SignalMap], SignalMap)
79 flattenExpr binds lam@(Lam b expr) = do
80 -- Find the type of the binder
81 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
82 -- Create signal names for the binder
83 defs <- genSignals arg_ty
84 let binds' = (b, Left defs):binds
85 (args, res) <- flattenExpr binds' expr
86 return (defs : args, res)
88 flattenExpr binds (Var id) =
90 Left sig_use -> return ([], sig_use)
91 Right _ -> error "Higher order functions not supported."
93 bind = Maybe.fromMaybe
94 (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
97 flattenExpr binds app@(App _ _) = do
98 -- Is this a data constructor application?
99 case CoreUtils.exprIsConApp_maybe app of
100 -- Is this a tuple construction?
101 Just (dc, args) -> if DataCon.isTupleCon dc
103 flattenBuildTupleExpr binds (dataConAppArgs dc args)
105 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
107 -- Normal function application
108 let ((Var f), args) = collectArgs app in
109 flattenApplicationExpr binds (CoreUtils.exprType app) f args
111 flattenBuildTupleExpr binds args = do
112 -- Flatten each of our args
113 flat_args <- (State.mapM (flattenExpr binds) args)
114 -- Check and split each of the arguments
115 let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
116 let res = Tuple arg_ress
119 -- | Flatten a normal application expression
120 flattenApplicationExpr binds ty f args = do
121 -- Find the function to call
122 let func = appToHsFunction ty f args
123 -- Flatten each of our args
124 flat_args <- (State.mapM (flattenExpr binds) args)
125 -- Check and split each of the arguments
126 let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
127 -- Generate signals for our result
129 -- Create the function application
137 -- | Check a flattened expression to see if it is valid to use as a
138 -- function argument. The first argument is the original expression for
139 -- use in the error message.
141 let (args, res) = flat in
143 then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
146 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
147 (b_args, b_res) <- flattenExpr binds bexpr
150 error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
152 let binds' = (b, Left b_res) : binds in
153 flattenExpr binds' expr
155 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
157 flattenExpr binds expr@(Case (Var v) b _ alts) =
159 [alt] -> flattenSingleAltCaseExpr binds v b alt
160 otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
162 flattenSingleAltCaseExpr ::
164 -- A list of bindings in effect
165 -> Var.Var -- The scrutinee
166 -> CoreBndr -- The binder to bind the scrutinee to
167 -> CoreAlt -- The single alternative
168 -> FlattenState ( [SignalMap], SignalMap)
170 flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
171 if not (DataCon.isTupleCon datacon)
173 error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
176 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
177 -- the existing bindings list and get the portname map for each of
179 Left (Tuple tuple_sigs) = Maybe.fromMaybe
180 (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
182 -- TODO include b in the binds list
183 -- Merge our existing binds with the new binds.
184 binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds
186 -- Expand the expression with the new binds list
187 flattenExpr binds' expr
188 flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
193 return ([], Tuple [])
196 Type.Type -- ^ The return type
197 -> Var.Var -- ^ The function to call
198 -> [CoreExpr] -- ^ The function arguments
199 -> HsFunction -- ^ The needed HsFunction
201 appToHsFunction ty f args =
202 HsFunction hsname hsargs hsres
204 hsname = Name.getOccString f
205 hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
206 hsres = useAsPort (mkHsValueMap ty)
208 -- | Filters non-state signals and returns the state number and signal id for
211 SignalId -- | The signal id to look at
212 -> HsValueUse -- | How is this signal used?
213 -> Maybe (StateId, SignalId ) -- | The state num and signal id, if this
214 -- signal was used as state
216 filterState id (State num) =
218 filterState _ _ = Nothing
220 -- | Returns a list of the state number and signal id of all used-as-state
221 -- signals in the given maps.
225 -> [(StateId, SignalId)]
227 stateList uses signals =
228 Maybe.catMaybes $ Foldable.toList $ zipValueMapsWith filterState signals uses
230 -- | Returns pairs of signals that should be mapped to state in this function.
232 HsFunction -- | The function to look at
233 -> FlatFunction -- | The function to look at
234 -> [(StateId, SignalInfo, SignalInfo)]
235 -- | The state signals. The first is the state number, the second the
236 -- signal to assign the current state to, the last is the signal
237 -- that holds the new state.
239 getOwnStates hsfunc flatfunc =
240 [(old_num, old_info, new_info)
241 | (old_num, old_info) <- args_states
242 , (new_num, new_info) <- res_states
243 , old_num == new_num]
245 sigs = flat_sigs flatfunc
246 -- Translate args and res to lists of (statenum, sigid)
247 args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
248 res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
249 -- Replace the second tuple element with the corresponding SignalInfo
250 args_states = map (Arrow.second $ signalInfo sigs) args
251 res_states = map (Arrow.second $ signalInfo sigs) res
254 -- vim: set ts=8 sw=2 sts=2 expandtab: