8 import qualified Control.Arrow as Arrow
9 import qualified DataCon
10 import qualified TyCon
11 import qualified CoreUtils
12 import qualified TysWiredIn
13 import qualified Data.Traversable as Traversable
14 import qualified Data.Foldable as Foldable
15 import Control.Applicative
16 import Outputable ( showSDoc, ppr )
17 import qualified Control.Monad.State as State
20 import TranslatorTypes
23 -- Extract the arguments from a data constructor application (that is, the
24 -- normal args, leaving out the type args).
25 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
26 dataConAppArgs dc args =
29 tycount = length $ DataCon.dataConAllTyVars dc
33 -> FlattenState SignalMap
36 -- First generate a map with the right structure containing the types, and
37 -- generate signals for each of them.
38 Traversable.mapM (\ty -> genSignalId SigInternal ty) (mkHsValueMap ty)
40 -- | Marks a signal as the given SigUse, if its id is in the list of id's
42 markSignals :: SigUse -> [SignalId] -> (SignalId, SignalInfo) -> (SignalId, SignalInfo)
43 markSignals use ids (id, info) =
46 info' = if id `elem` ids then info { sigUse = use} else info
48 markSignal :: SigUse -> SignalId -> (SignalId, SignalInfo) -> (SignalId, SignalInfo)
49 markSignal use id = markSignals use [id]
51 -- | Flatten a haskell function
53 HsFunction -- ^ The function to flatten
54 -> CoreBind -- ^ The function value
55 -> FlatFunction -- ^ The resulting flat function
57 flattenFunction _ (Rec _) = error "Recursive binders not supported"
58 flattenFunction hsfunc bind@(NonRec var expr) =
59 FlatFunction args res defs sigs
61 init_state = ([], [], 0)
62 (fres, end_state) = State.runState (flattenTopExpr hsfunc expr) init_state
63 (defs, sigs, _) = end_state
69 -> FlattenState ([SignalMap], SignalMap)
71 flattenTopExpr hsfunc expr = do
72 -- Flatten the expression
73 (args, res) <- flattenExpr [] expr
75 -- Join the signal ids and uses together
76 let zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
77 let zipped_res = zipValueMaps res (hsFuncRes hsfunc)
78 -- Set the signal uses for each argument / result, possibly updating
79 -- argument or result signals.
80 args' <- mapM (Traversable.mapM $ hsUseToSigUse args_use) zipped_args
81 res' <- Traversable.mapM (hsUseToSigUse res_use) zipped_res
84 args_use Port = SigPortIn
85 args_use (State n) = SigStateOld n
86 res_use Port = SigPortOut
87 res_use (State n) = SigStateNew n
91 (HsValueUse -> SigUse) -- ^ A function to actually map the use value
92 -> (SignalId, HsValueUse) -- ^ The signal to look at and its use
93 -> FlattenState SignalId -- ^ The resulting signal. This is probably the
94 -- same as the input, but it could be different.
95 hsUseToSigUse f (id, use) = do
96 info <- getSignalInfo id
97 id' <- case sigUse info of
98 -- Internal signals can be marked as different uses freely.
101 -- Signals that already have another use, must be duplicated before
102 -- marking. This prevents signals mapping to the same input or output
103 -- port or state variables and ports overlapping, etc.
106 setSignalInfo id' (info { sigUse = f use})
109 -- | Creates a new internal signal with the same type as the given signal
110 copySignal :: SignalId -> FlattenState SignalId
112 -- Find the type of the original signal
113 info <- getSignalInfo id
115 -- Generate a new signal (which is SigInternal for now, that will be
116 -- sorted out later on).
117 genSignalId SigInternal ty
119 -- | Duplicate the given signal, assigning its value to the new signal.
120 -- Returns the new signal id.
121 duplicateSignal :: SignalId -> FlattenState SignalId
122 duplicateSignal id = do
123 -- Create a new signal
125 -- Assign the old signal to the new signal
126 addDef $ UncondDef (Left id) id'
127 -- Replace the signal with the new signal
133 -> FlattenState ([SignalMap], SignalMap)
135 flattenExpr binds lam@(Lam b expr) = do
136 -- Find the type of the binder
137 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
138 -- Create signal names for the binder
139 defs <- genSignals arg_ty
140 let binds' = (b, Left defs):binds
141 (args, res) <- flattenExpr binds' expr
142 return (defs : args, res)
144 flattenExpr binds (Var id) =
146 Left sig_use -> return ([], sig_use)
147 Right _ -> error "Higher order functions not supported."
149 bind = Maybe.fromMaybe
150 (error $ "Argument " ++ Name.getOccString id ++ " is unknown")
153 flattenExpr binds app@(App _ _) = do
154 -- Is this a data constructor application?
155 case CoreUtils.exprIsConApp_maybe app of
156 -- Is this a tuple construction?
157 Just (dc, args) -> if DataCon.isTupleCon dc
159 flattenBuildTupleExpr binds (dataConAppArgs dc args)
161 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
163 -- Normal function application
164 let ((Var f), args) = collectArgs app in
165 flattenApplicationExpr binds (CoreUtils.exprType app) f args
167 flattenBuildTupleExpr binds args = do
168 -- Flatten each of our args
169 flat_args <- (State.mapM (flattenExpr binds) args)
170 -- Check and split each of the arguments
171 let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
172 let res = Tuple arg_ress
175 -- | Flatten a normal application expression
176 flattenApplicationExpr binds ty f args = do
177 -- Find the function to call
178 let func = appToHsFunction ty f args
179 -- Flatten each of our args
180 flat_args <- (State.mapM (flattenExpr binds) args)
181 -- Check and split each of the arguments
182 let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
183 -- Generate signals for our result
185 -- Create the function application
193 -- | Check a flattened expression to see if it is valid to use as a
194 -- function argument. The first argument is the original expression for
195 -- use in the error message.
197 let (args, res) = flat in
199 then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
202 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
203 (b_args, b_res) <- flattenExpr binds bexpr
206 error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
208 let binds' = (b, Left b_res) : binds in
209 flattenExpr binds' expr
211 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
213 flattenExpr binds expr@(Case (Var v) b _ alts) =
215 [alt] -> flattenSingleAltCaseExpr binds var b alt
216 otherwise -> flattenMultipleAltCaseExpr binds var b alts
218 var = Maybe.fromMaybe
219 (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
222 flattenSingleAltCaseExpr ::
224 -- A list of bindings in effect
225 -> BindValue -- The scrutinee
226 -> CoreBndr -- The binder to bind the scrutinee to
227 -> CoreAlt -- The single alternative
228 -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
230 flattenSingleAltCaseExpr binds var b alt@(DataAlt datacon, bind_vars, expr) =
231 if DataCon.isTupleCon datacon
234 -- Unpack the scrutinee (which must be a variable bound to a tuple) in
235 -- the existing bindings list and get the portname map for each of
237 Left (Tuple tuple_sigs) = var
238 -- TODO include b in the binds list
239 -- Merge our existing binds with the new binds.
240 binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds
242 -- Expand the expression with the new binds list
243 flattenExpr binds' expr
247 -- DataAlts without arguments don't need processing
248 -- (flattenMultipleAltCaseExpr will have done this already).
249 flattenExpr binds expr
251 error $ "Dataconstructors other than tuple constructors cannot have binder arguments in case pattern of alternative: " ++ (showSDoc $ ppr alt)
252 flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
254 flattenMultipleAltCaseExpr ::
256 -- A list of bindings in effect
257 -> BindValue -- The scrutinee
258 -> CoreBndr -- The binder to bind the scrutinee to
259 -> [CoreAlt] -- The alternatives
260 -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
262 flattenMultipleAltCaseExpr binds var b (a:a':alts) = do
263 (args, res) <- flattenSingleAltCaseExpr binds var b a
264 (args', res') <- flattenMultipleAltCaseExpr binds var b (a':alts)
266 (DataAlt datacon, bind_vars, expr) -> do
267 let tycon = DataCon.dataConTyCon datacon
268 let tyname = TyCon.tyConName tycon
269 case Name.getOccString tyname of
270 -- TODO: Do something more robust than string matching
272 -- The scrutinee must be a single signal
273 let Left (Single sig) = var
274 let dcname = DataCon.dataConName datacon
275 let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
276 -- Create a signal that contains a boolean
277 boolsigid <- genSignalId SigInternal TysWiredIn.boolTy
278 let expr = EqLit sig lit
279 addDef (UncondDef (Right expr) boolsigid)
280 -- Create conditional assignments of either args/res or
281 -- args'/res based on boolsigid, and return the result.
282 our_args <- zipWithM (mkConditionals boolsigid) args args'
283 our_res <- mkConditionals boolsigid res res'
284 return (our_args, our_res)
286 error $ "Type " ++ (Name.getOccString tyname) ++ " not supported in multiple alternative case expressions."
288 error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr a)
290 -- Select either the first or second signal map depending on the value
291 -- of the first argument (True == first map, False == second map)
292 mkConditionals :: SignalId -> SignalMap -> SignalMap -> FlattenState SignalMap
293 mkConditionals boolsigid true false = do
294 let zipped = zipValueMaps true false
295 Traversable.mapM (mkConditional boolsigid) zipped
297 mkConditional :: SignalId -> (SignalId, SignalId) -> FlattenState SignalId
298 mkConditional boolsigid (true, false) = do
299 -- Create a new signal (true and false should be identically typed,
300 -- so it doesn't matter which one we copy).
301 res <- copySignal true
302 addDef (CondDef boolsigid true false res)
305 flattenMultipleAltCaseExpr binds var b (a:alts) =
306 flattenSingleAltCaseExpr binds var b a
311 return ([], Tuple [])
314 Type.Type -- ^ The return type
315 -> Var.Var -- ^ The function to call
316 -> [CoreExpr] -- ^ The function arguments
317 -> HsFunction -- ^ The needed HsFunction
319 appToHsFunction ty f args =
320 HsFunction hsname hsargs hsres
322 hsname = Name.getOccString f
323 hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
324 hsres = useAsPort (mkHsValueMap ty)
326 -- | Filters non-state signals and returns the state number and signal id for
329 SignalId -- | The signal id to look at
330 -> HsValueUse -- | How is this signal used?
331 -> Maybe (StateId, SignalId ) -- | The state num and signal id, if this
332 -- signal was used as state
334 filterState id (State num) =
336 filterState _ _ = Nothing
338 -- | Returns a list of the state number and signal id of all used-as-state
339 -- signals in the given maps.
343 -> [(StateId, SignalId)]
345 stateList uses signals =
346 Maybe.catMaybes $ Foldable.toList $ zipValueMapsWith filterState signals uses
348 -- | Returns pairs of signals that should be mapped to state in this function.
350 HsFunction -- | The function to look at
351 -> FlatFunction -- | The function to look at
352 -> [(StateId, SignalInfo, SignalInfo)]
353 -- | The state signals. The first is the state number, the second the
354 -- signal to assign the current state to, the last is the signal
355 -- that holds the new state.
357 getOwnStates hsfunc flatfunc =
358 [(old_num, old_info, new_info)
359 | (old_num, old_info) <- args_states
360 , (new_num, new_info) <- res_states
361 , old_num == new_num]
363 sigs = flat_sigs flatfunc
364 -- Translate args and res to lists of (statenum, sigid)
365 args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
366 res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
367 -- Replace the second tuple element with the corresponding SignalInfo
368 args_states = map (Arrow.second $ signalInfo sigs) args
369 res_states = map (Arrow.second $ signalInfo sigs) res
372 -- vim: set ts=8 sw=2 sts=2 expandtab: