3 import qualified Control.Monad as Monad
8 import qualified Control.Arrow as Arrow
9 import qualified DataCon
10 import qualified TyCon
11 import qualified Literal
12 import qualified CoreUtils
13 import qualified TysWiredIn
14 import qualified IdInfo
15 import qualified Data.Traversable as Traversable
16 import qualified Data.Foldable as Foldable
17 import Control.Applicative
18 import Outputable ( showSDoc, ppr )
19 import qualified Control.Monad.Trans.State as State
22 import TranslatorTypes
26 -- Extract the arguments from a data constructor application (that is, the
27 -- normal args, leaving out the type args).
28 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
29 dataConAppArgs dc args =
32 tycount = length $ DataCon.dataConAllTyVars dc
36 -> FlattenState SignalMap
39 -- First generate a map with the right structure containing the types, and
40 -- generate signals for each of them.
41 Traversable.mapM (\ty -> genSignalId SigInternal ty) (mkHsValueMap ty)
43 -- | Marks a signal as the given SigUse, if its id is in the list of id's
45 markSignals :: SigUse -> [SignalId] -> (SignalId, SignalInfo) -> (SignalId, SignalInfo)
46 markSignals use ids (id, info) =
49 info' = if id `elem` ids then info { sigUse = use} else info
51 markSignal :: SigUse -> SignalId -> (SignalId, SignalInfo) -> (SignalId, SignalInfo)
52 markSignal use id = markSignals use [id]
54 -- | Flatten a haskell function
56 HsFunction -- ^ The function to flatten
57 -> CoreBind -- ^ The function value
58 -> FlatFunction -- ^ The resulting flat function
60 flattenFunction _ (Rec _) = error "Recursive binders not supported"
61 flattenFunction hsfunc bind@(NonRec var expr) =
62 FlatFunction args res defs sigs
64 init_state = ([], [], 0)
65 (fres, end_state) = State.runState (flattenTopExpr hsfunc expr) init_state
66 (defs, sigs, _) = end_state
72 -> FlattenState ([SignalMap], SignalMap)
74 flattenTopExpr hsfunc expr = do
75 -- Flatten the expression
76 (args, res) <- flattenExpr [] expr
78 -- Join the signal ids and uses together
79 let zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
80 let zipped_res = zipValueMaps res (hsFuncRes hsfunc)
81 -- Set the signal uses for each argument / result, possibly updating
82 -- argument or result signals.
83 args' <- mapM (Traversable.mapM $ hsUseToSigUse args_use) zipped_args
84 res' <- Traversable.mapM (hsUseToSigUse res_use) zipped_res
87 args_use Port = SigPortIn
88 args_use (State n) = SigStateOld n
89 res_use Port = SigPortOut
90 res_use (State n) = SigStateNew n
94 (HsValueUse -> SigUse) -- ^ A function to actually map the use value
95 -> (SignalId, HsValueUse) -- ^ The signal to look at and its use
96 -> FlattenState SignalId -- ^ The resulting signal. This is probably the
97 -- same as the input, but it could be different.
98 hsUseToSigUse f (id, use) = do
99 info <- getSignalInfo id
100 id' <- case sigUse info of
101 -- Internal signals can be marked as different uses freely.
104 -- Signals that already have another use, must be duplicated before
105 -- marking. This prevents signals mapping to the same input or output
106 -- port or state variables and ports overlapping, etc.
109 setSignalInfo id' (info { sigUse = f use})
112 -- | Creates a new internal signal with the same type as the given signal
113 copySignal :: SignalId -> FlattenState SignalId
115 -- Find the type of the original signal
116 info <- getSignalInfo id
118 -- Generate a new signal (which is SigInternal for now, that will be
119 -- sorted out later on).
120 genSignalId SigInternal ty
122 -- | Duplicate the given signal, assigning its value to the new signal.
123 -- Returns the new signal id.
124 duplicateSignal :: SignalId -> FlattenState SignalId
125 duplicateSignal id = do
126 -- Create a new signal
128 -- Assign the old signal to the new signal
129 addDef $ UncondDef (Left id) id'
130 -- Replace the signal with the new signal
136 -> FlattenState ([SignalMap], SignalMap)
138 flattenExpr binds lam@(Lam b expr) = do
139 -- Find the type of the binder
140 let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
141 -- Create signal names for the binder
142 defs <- genSignals arg_ty
143 -- Add name hints to the generated signals
144 let binder_name = Name.getOccString b
145 Traversable.mapM (addNameHint binder_name) defs
146 let binds' = (b, Left defs):binds
147 (args, res) <- flattenExpr binds' expr
148 return (defs : args, res)
150 flattenExpr binds var@(Var id) =
151 case Var.globalIdVarDetails id of
152 IdInfo.NotGlobalId ->
154 bind = Maybe.fromMaybe
155 (error $ "Local value " ++ Name.getOccString id ++ " is unknown")
159 Left sig_use -> return ([], sig_use)
160 Right _ -> error "Higher order functions not supported."
161 IdInfo.DataConWorkId datacon -> do
162 if DataCon.isTupleCon datacon && (null $ DataCon.dataConAllTyVars datacon)
164 -- Empty tuple construction
165 return ([], Tuple [])
167 lit <- dataConToLiteral datacon
168 let ty = CoreUtils.exprType var
169 sig_id <- genSignalId SigInternal ty
170 -- Add a name hint to the signal
171 addNameHint (Name.getOccString id) sig_id
172 addDef (UncondDef (Right $ Literal lit Nothing) sig_id)
173 return ([], Single sig_id)
174 IdInfo.VanillaGlobal ->
175 -- Treat references to globals as an application with zero elements
176 flattenApplicationExpr binds (CoreUtils.exprType var) id []
178 error $ "Ids other than local vars and dataconstructors not supported: " ++ (showSDoc $ ppr id)
180 flattenExpr binds app@(App _ _) = do
181 -- Is this a data constructor application?
182 case CoreUtils.exprIsConApp_maybe app of
183 -- Is this a tuple construction?
184 Just (dc, args) -> if DataCon.isTupleCon dc
186 flattenBuildTupleExpr binds (dataConAppArgs dc args)
188 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
190 -- Normal function application
191 let ((Var f), args) = collectArgs app in
192 let fname = Name.getOccString f in
193 if fname == "fst" || fname == "snd" then do
194 (args', Tuple [a, b]) <- flattenExpr binds (last args)
195 return (args', if fname == "fst" then a else b)
196 else if fname == "patError" then do
197 -- This is essentially don't care, since the program will error out
198 -- here. We'll just define undriven signals here.
199 let (argtys, resty) = Type.splitFunTys $ CoreUtils.exprType app
200 args <- mapM genSignals argtys
201 res <- genSignals resty
202 mapM (Traversable.mapM (addNameHint "NC")) args
203 Traversable.mapM (addNameHint "NC") res
205 else if fname == "==" then do
206 -- Flatten the last two arguments (this skips the type arguments)
207 ([], a) <- flattenExpr binds (last $ init args)
208 ([], b) <- flattenExpr binds (last args)
209 res <- mkEqComparisons a b
211 else if fname == "fromInteger" then do
212 let [to_ty, to_dict, val] = args
213 -- We assume this is an application of the GHC.Integer.smallInteger
214 -- function to a literal
215 let App smallint (Lit lit) = val
216 let (Literal.MachInt int) = lit
217 let ty = CoreUtils.exprType app
218 sig_id <- genSignalId SigInternal ty
219 -- TODO: fromInteger is defined for more types than just SizedWord
220 let len = sized_word_len ty
221 -- TODO: to_stdlogicvector doesn't work here, since SizedWord
222 -- translates to a different type...
223 addDef $ UncondDef (Right $ Literal ("to_stdlogicvector(to_unsigned(" ++ (show int) ++ ", " ++ (show len) ++ "))") Nothing) sig_id
224 return ([], Single sig_id)
226 flattenApplicationExpr binds (CoreUtils.exprType app) f args
228 mkEqComparisons :: SignalMap -> SignalMap -> FlattenState SignalMap
229 mkEqComparisons a b = do
230 let zipped = zipValueMaps a b
231 Traversable.mapM mkEqComparison zipped
233 mkEqComparison :: (SignalId, SignalId) -> FlattenState SignalId
234 mkEqComparison (a, b) = do
235 -- Generate a signal to hold our result
236 res <- genSignalId SigInternal TysWiredIn.boolTy
237 -- Add a name hint to the signal
238 addNameHint ("s" ++ show a ++ "_eq_s" ++ show b) res
239 addDef (UncondDef (Right $ Eq a b) res)
242 flattenBuildTupleExpr binds args = do
243 -- Flatten each of our args
244 flat_args <- (mapM (flattenExpr binds) args)
245 -- Check and split each of the arguments
246 let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
247 let res = Tuple arg_ress
250 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
251 (b_args, b_res) <- flattenExpr binds bexpr
254 error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
256 let binds' = (b, Left b_res) : binds
257 -- Add name hints to the generated signals
258 let binder_name = Name.getOccString b
259 Traversable.mapM (addNameHint binder_name) b_res
260 flattenExpr binds' expr
262 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
264 flattenExpr binds expr@(Case scrut b _ alts) = do
265 -- TODO: Special casing for higher order functions
266 -- Flatten the scrutinee
267 (_, res) <- flattenExpr binds scrut
269 -- TODO include b in the binds list
270 [alt] -> flattenSingleAltCaseExpr binds res b alt
271 -- Reverse the alternatives, so the __DEFAULT alternative ends up last
272 otherwise -> flattenMultipleAltCaseExpr binds res b (reverse alts)
274 flattenSingleAltCaseExpr ::
276 -- A list of bindings in effect
277 -> SignalMap -- The scrutinee
278 -> CoreBndr -- The binder to bind the scrutinee to
279 -> CoreAlt -- The single alternative
280 -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
282 flattenSingleAltCaseExpr binds scrut b alt@(DataAlt datacon, bind_vars, expr) =
283 if DataCon.isTupleCon datacon
285 -- Unpack the scrutinee (which must be a variable bound to a tuple) in
286 -- the existing bindings list and get the portname map for each of
288 let Tuple tuple_sigs = scrut
289 -- Add name hints to the returned signals
290 let binder_name = Name.getOccString b
291 Monad.zipWithM (\name sigs -> Traversable.mapM (addNameHint $ Name.getOccString name) sigs) bind_vars tuple_sigs
292 -- Merge our existing binds with the new binds.
293 let binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds
294 -- Expand the expression with the new binds list
295 flattenExpr binds' expr
299 -- DataAlts without arguments don't need processing
300 -- (flattenMultipleAltCaseExpr will have done this already).
301 flattenExpr binds expr
303 error $ "Dataconstructors other than tuple constructors cannot have binder arguments in case pattern of alternative: " ++ (showSDoc $ ppr alt)
305 flattenSingleAltCaseExpr binds _ _ alt@(DEFAULT, [], expr) =
306 flattenExpr binds expr
308 flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
310 flattenMultipleAltCaseExpr ::
312 -- A list of bindings in effect
313 -> SignalMap -- The scrutinee
314 -> CoreBndr -- The binder to bind the scrutinee to
315 -> [CoreAlt] -- The alternatives
316 -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
318 flattenMultipleAltCaseExpr binds scrut b (a:a':alts) = do
319 (args, res) <- flattenSingleAltCaseExpr binds scrut b a
320 (args', res') <- flattenMultipleAltCaseExpr binds scrut b (a':alts)
322 (DataAlt datacon, bind_vars, expr) -> do
323 lit <- dataConToLiteral datacon
324 -- The scrutinee must be a single signal
325 let Single sig = scrut
326 -- Create a signal that contains a boolean
327 boolsigid <- genSignalId SigInternal TysWiredIn.boolTy
328 addNameHint ("s" ++ show sig ++ "_eq_" ++ lit) boolsigid
329 let expr = EqLit sig lit
330 addDef (UncondDef (Right expr) boolsigid)
331 -- Create conditional assignments of either args/res or
332 -- args'/res based on boolsigid, and return the result.
333 -- TODO: It seems this adds the name hint twice?
334 our_args <- Monad.zipWithM (mkConditionals boolsigid) args args'
335 our_res <- mkConditionals boolsigid res res'
336 return (our_args, our_res)
338 error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr a)
340 -- Select either the first or second signal map depending on the value
341 -- of the first argument (True == first map, False == second map)
342 mkConditionals :: SignalId -> SignalMap -> SignalMap -> FlattenState SignalMap
343 mkConditionals boolsigid true false = do
344 let zipped = zipValueMaps true false
345 Traversable.mapM (mkConditional boolsigid) zipped
347 mkConditional :: SignalId -> (SignalId, SignalId) -> FlattenState SignalId
348 mkConditional boolsigid (true, false) = do
349 -- Create a new signal (true and false should be identically typed,
350 -- so it doesn't matter which one we copy).
351 res <- copySignal true
352 addDef (CondDef boolsigid true false res)
355 flattenMultipleAltCaseExpr binds scrut b (a:alts) =
356 flattenSingleAltCaseExpr binds scrut b a
358 flattenExpr _ expr = do
359 error $ "Unsupported expression: " ++ (showSDoc $ ppr expr)
361 -- | Flatten a normal application expression
362 flattenApplicationExpr binds ty f args = do
363 -- Find the function to call
364 let func = appToHsFunction ty f args
365 -- Flatten each of our args
366 flat_args <- (mapM (flattenExpr binds) args)
367 -- Check and split each of the arguments
368 let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
369 -- Generate signals for our result
371 -- Add name hints to the generated signals
372 let resname = Name.getOccString f ++ "_res"
373 Traversable.mapM (addNameHint resname) res
374 -- Create the function application
382 -- | Check a flattened expression to see if it is valid to use as a
383 -- function argument. The first argument is the original expression for
384 -- use in the error message.
386 let (args, res) = flat in
388 then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
391 -- | Translates a dataconstructor without arguments to the corresponding
393 dataConToLiteral :: DataCon.DataCon -> FlattenState String
394 dataConToLiteral datacon = do
395 let tycon = DataCon.dataConTyCon datacon
396 let tyname = TyCon.tyConName tycon
397 case Name.getOccString tyname of
398 -- TODO: Do something more robust than string matching
400 let dcname = DataCon.dataConName datacon
401 let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
404 let dcname = DataCon.dataConName datacon
405 let lit = case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
408 error $ "Literals of type " ++ (Name.getOccString tyname) ++ " not supported."
411 Type.Type -- ^ The return type
412 -> Var.Var -- ^ The function to call
413 -> [CoreExpr] -- ^ The function arguments
414 -> HsFunction -- ^ The needed HsFunction
416 appToHsFunction ty f args =
417 HsFunction hsname hsargs hsres
419 hsname = Name.getOccString f
420 hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
421 hsres = useAsPort (mkHsValueMap ty)
423 -- | Filters non-state signals and returns the state number and signal id for
426 SignalId -- | The signal id to look at
427 -> HsValueUse -- | How is this signal used?
428 -> Maybe (StateId, SignalId ) -- | The state num and signal id, if this
429 -- signal was used as state
431 filterState id (State num) =
433 filterState _ _ = Nothing
435 -- | Returns a list of the state number and signal id of all used-as-state
436 -- signals in the given maps.
440 -> [(StateId, SignalId)]
442 stateList uses signals =
443 Maybe.catMaybes $ Foldable.toList $ zipValueMapsWith filterState signals uses
445 -- vim: set ts=8 sw=2 sts=2 expandtab: