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 (flattenTopExpr hsfunc expr) init_state
61 (defs, sigs, _) = end_state
67 -> FlattenState ([SignalMap], SignalMap)
69 flattenTopExpr hsfunc expr = do
70 -- Flatten the expression
71 (args, res) <- flattenExpr [] expr
73 -- Join the signal ids and uses together
74 let zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
75 let zipped_res = zipValueMaps res (hsFuncRes hsfunc)
76 -- Set the signal uses for each argument / result, possibly updating
77 -- argument or result signals.
78 args' <- mapM (Traversable.mapM $ hsUseToSigUse args_use) zipped_args
79 res' <- Traversable.mapM (hsUseToSigUse res_use) zipped_res
82 args_use Port = SigPortIn
83 args_use (State n) = SigStateOld n
84 res_use Port = SigPortOut
85 res_use (State n) = SigStateNew n
89 (HsValueUse -> SigUse) -- ^ A function to actually map the use value
90 -> (SignalId, HsValueUse) -- ^ The signal to look at and its use
91 -> FlattenState SignalId -- ^ The resulting signal. This is probably the
92 -- same as the input, but it could be different.
93 hsUseToSigUse f (id, use) = do
94 info <- getSignalInfo id
95 id' <- case sigUse info of
96 -- Internal signals can be marked as different uses freely.
99 -- Signals that already have another use, must be duplicated before
100 -- marking. This prevents signals mapping to the same input or output
101 -- port or state variables and ports overlapping, etc.
104 setSignalInfo id' (info { sigUse = f use})
107 -- | Duplicate the given signal, assigning its value to the new signal.
108 -- Returns the new signal id.
109 duplicateSignal :: SignalId -> FlattenState SignalId
110 duplicateSignal id = do
111 -- Find the type of the original signal
112 info <- getSignalInfo id
114 -- Generate a new signal (which is SigInternal for now, that will be
115 -- sorted out later on).
116 id' <- genSignalId SigInternal ty
117 -- Assign the old signal to the new signal
118 addDef $ UncondDef id id'
119 -- Replace the signal with the new signal
125 -> FlattenState ([SignalMap], SignalMap)
127 flattenExpr binds lam@(Lam b expr) = do
128 -- Find the type of the binder
129 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
130 -- Create signal names for the binder
131 defs <- genSignals arg_ty
132 let binds' = (b, Left defs):binds
133 (args, res) <- flattenExpr binds' expr
134 return (defs : args, res)
136 flattenExpr binds (Var id) =
138 Left sig_use -> return ([], sig_use)
139 Right _ -> error "Higher order functions not supported."
141 bind = Maybe.fromMaybe
142 (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
145 flattenExpr binds app@(App _ _) = do
146 -- Is this a data constructor application?
147 case CoreUtils.exprIsConApp_maybe app of
148 -- Is this a tuple construction?
149 Just (dc, args) -> if DataCon.isTupleCon dc
151 flattenBuildTupleExpr binds (dataConAppArgs dc args)
153 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
155 -- Normal function application
156 let ((Var f), args) = collectArgs app in
157 flattenApplicationExpr binds (CoreUtils.exprType app) f args
159 flattenBuildTupleExpr binds args = do
160 -- Flatten each of our args
161 flat_args <- (State.mapM (flattenExpr binds) args)
162 -- Check and split each of the arguments
163 let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
164 let res = Tuple arg_ress
167 -- | Flatten a normal application expression
168 flattenApplicationExpr binds ty f args = do
169 -- Find the function to call
170 let func = appToHsFunction ty f args
171 -- Flatten each of our args
172 flat_args <- (State.mapM (flattenExpr binds) args)
173 -- Check and split each of the arguments
174 let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
175 -- Generate signals for our result
177 -- Create the function application
185 -- | Check a flattened expression to see if it is valid to use as a
186 -- function argument. The first argument is the original expression for
187 -- use in the error message.
189 let (args, res) = flat in
191 then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
194 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
195 (b_args, b_res) <- flattenExpr binds bexpr
198 error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
200 let binds' = (b, Left b_res) : binds in
201 flattenExpr binds' expr
203 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
205 flattenExpr binds expr@(Case (Var v) b _ alts) =
207 [alt] -> flattenSingleAltCaseExpr binds v b alt
208 otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
210 flattenSingleAltCaseExpr ::
212 -- A list of bindings in effect
213 -> Var.Var -- The scrutinee
214 -> CoreBndr -- The binder to bind the scrutinee to
215 -> CoreAlt -- The single alternative
216 -> FlattenState ( [SignalMap], SignalMap)
218 flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
219 if not (DataCon.isTupleCon datacon)
221 error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
224 -- Lookup the scrutinee (which must be a variable bound to a tuple) in
225 -- the existing bindings list and get the portname map for each of
227 Left (Tuple tuple_sigs) = Maybe.fromMaybe
228 (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
230 -- TODO include b in the binds list
231 -- Merge our existing binds with the new binds.
232 binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds
234 -- Expand the expression with the new binds list
235 flattenExpr binds' expr
236 flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
241 return ([], Tuple [])
244 Type.Type -- ^ The return type
245 -> Var.Var -- ^ The function to call
246 -> [CoreExpr] -- ^ The function arguments
247 -> HsFunction -- ^ The needed HsFunction
249 appToHsFunction ty f args =
250 HsFunction hsname hsargs hsres
252 hsname = Name.getOccString f
253 hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
254 hsres = useAsPort (mkHsValueMap ty)
256 -- | Filters non-state signals and returns the state number and signal id for
259 SignalId -- | The signal id to look at
260 -> HsValueUse -- | How is this signal used?
261 -> Maybe (StateId, SignalId ) -- | The state num and signal id, if this
262 -- signal was used as state
264 filterState id (State num) =
266 filterState _ _ = Nothing
268 -- | Returns a list of the state number and signal id of all used-as-state
269 -- signals in the given maps.
273 -> [(StateId, SignalId)]
275 stateList uses signals =
276 Maybe.catMaybes $ Foldable.toList $ zipValueMapsWith filterState signals uses
278 -- | Returns pairs of signals that should be mapped to state in this function.
280 HsFunction -- | The function to look at
281 -> FlatFunction -- | The function to look at
282 -> [(StateId, SignalInfo, SignalInfo)]
283 -- | The state signals. The first is the state number, the second the
284 -- signal to assign the current state to, the last is the signal
285 -- that holds the new state.
287 getOwnStates hsfunc flatfunc =
288 [(old_num, old_info, new_info)
289 | (old_num, old_info) <- args_states
290 , (new_num, new_info) <- res_states
291 , old_num == new_num]
293 sigs = flat_sigs flatfunc
294 -- Translate args and res to lists of (statenum, sigid)
295 args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
296 res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
297 -- Replace the second tuple element with the corresponding SignalInfo
298 args_states = map (Arrow.second $ signalInfo sigs) args
299 res_states = map (Arrow.second $ signalInfo sigs) res
302 -- vim: set ts=8 sw=2 sts=2 expandtab: