2 % (c) The University of Glasgow, 1994-2006
5 Core pass to saturate constructors and PrimOps
9 corePrepPgm, corePrepExpr
12 #include "HsVersions.h"
14 import CoreUtils hiding (exprIsTrivial)
39 -- ---------------------------------------------------------------------------
41 -- ---------------------------------------------------------------------------
43 The goal of this pass is to prepare for code generation.
45 1. Saturate constructor and primop applications.
47 2. Convert to A-normal form; that is, function arguments
50 * Use case for strict arguments:
51 f E ==> case E of x -> f x
54 * Use let for non-trivial lazy arguments
55 f E ==> let x = E in f x
56 (were f is lazy and x is non-trivial)
58 3. Similarly, convert any unboxed lets into cases.
59 [I'm experimenting with leaving 'ok-for-speculation'
60 rhss in let-form right up to this point.]
62 4. Ensure that lambdas only occur as the RHS of a binding
63 (The code generator can't deal with anything else.)
65 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
67 6. Clone all local Ids.
68 This means that all such Ids are unique, rather than the
69 weaker guarantee of no clashes which the simplifier provides.
70 And that is what the code generator needs.
72 We don't clone TyVars. The code gen doesn't need that,
73 and doing so would be tiresome because then we'd need
74 to substitute in types.
77 7. Give each dynamic CCall occurrence a fresh unique; this is
78 rather like the cloning step above.
80 8. Inject bindings for the "implicit" Ids:
81 * Constructor wrappers
84 We want curried definitions for all of these in case they
85 aren't inlined by some caller.
87 This is all done modulo type applications and abstractions, so that
88 when type erasure is done for conversion to STG, we don't end up with
89 any trivial or useless bindings.
93 -- -----------------------------------------------------------------------------
95 -- -----------------------------------------------------------------------------
98 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
99 corePrepPgm dflags binds data_tycons
100 = do showPass dflags "CorePrep"
101 us <- mkSplitUniqSupply 's'
103 let implicit_binds = mkDataConWorkers data_tycons
104 -- NB: we must feed mkImplicitBinds through corePrep too
105 -- so that they are suitably cloned and eta-expanded
107 binds_out = initUs_ us (
108 corePrepTopBinds binds `thenUs` \ floats1 ->
109 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
110 returnUs (deFloatTop (floats1 `appendFloats` floats2))
113 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
116 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
117 corePrepExpr dflags expr
118 = do showPass dflags "CorePrep"
119 us <- mkSplitUniqSupply 's'
120 let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
121 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
126 -- -----------------------------------------------------------------------------
128 -- -----------------------------------------------------------------------------
130 Create any necessary "implicit" bindings for data con workers. We
131 create the rather strange (non-recursive!) binding
133 $wC = \x y -> $wC x y
135 i.e. a curried constructor that allocates. This means that we can
136 treat the worker for a constructor like any other function in the rest
137 of the compiler. The point here is that CoreToStg will generate a
138 StgConApp for the RHS, rather than a call to the worker (which would
139 give a loop). As Lennart says: the ice is thin here, but it works.
141 Hmm. Should we create bindings for dictionary constructors? They are
142 always fully applied, and the bindings are just there to support
143 partial applications. But it's easier to let them through.
146 mkDataConWorkers data_tycons
147 = [ NonRec id (Var id) -- The ice is thin here, but it works
148 | tycon <- data_tycons, -- CorePrep will eta-expand it
149 data_con <- tyConDataCons tycon,
150 let id = dataConWorkId data_con ]
155 -- ---------------------------------------------------------------------------
156 -- Dealing with bindings
157 -- ---------------------------------------------------------------------------
159 data FloatingBind = FloatLet CoreBind
160 | FloatCase Id CoreExpr Bool
161 -- The bool indicates "ok-for-speculation"
163 data Floats = Floats OkToSpec (OrdList FloatingBind)
165 -- Can we float these binds out of the rhs of a let? We cache this decision
166 -- to avoid having to recompute it in a non-linear way when there are
167 -- deeply nested lets.
169 = NotOkToSpec -- definitely not
171 | IfUnboxedOk -- only if floating an unboxed binding is ok
173 emptyFloats :: Floats
174 emptyFloats = Floats OkToSpec nilOL
176 addFloat :: Floats -> FloatingBind -> Floats
177 addFloat (Floats ok_to_spec floats) new_float
178 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
180 check (FloatLet _) = OkToSpec
181 check (FloatCase _ _ ok_for_spec)
182 | ok_for_spec = IfUnboxedOk
183 | otherwise = NotOkToSpec
184 -- The ok-for-speculation flag says that it's safe to
185 -- float this Case out of a let, and thereby do it more eagerly
186 -- We need the top-level flag because it's never ok to float
187 -- an unboxed binding to the top level
189 unitFloat :: FloatingBind -> Floats
190 unitFloat = addFloat emptyFloats
192 appendFloats :: Floats -> Floats -> Floats
193 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
194 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
196 concatFloats :: [Floats] -> Floats
197 concatFloats = foldr appendFloats emptyFloats
199 combine NotOkToSpec _ = NotOkToSpec
200 combine _ NotOkToSpec = NotOkToSpec
201 combine IfUnboxedOk _ = IfUnboxedOk
202 combine _ IfUnboxedOk = IfUnboxedOk
203 combine _ _ = OkToSpec
205 instance Outputable FloatingBind where
206 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
207 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
209 deFloatTop :: Floats -> [CoreBind]
210 -- For top level only; we don't expect any FloatCases
211 deFloatTop (Floats _ floats)
212 = foldrOL get [] floats
214 get (FloatLet b) bs = b:bs
215 get b bs = pprPanic "corePrepPgm" (ppr b)
217 allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
218 allLazy top_lvl is_rec (Floats ok_to_spec _)
222 IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
224 -- ---------------------------------------------------------------------------
226 -- ---------------------------------------------------------------------------
228 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
229 corePrepTopBinds binds
230 = go emptyCorePrepEnv binds
232 go env [] = returnUs emptyFloats
233 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
234 go env' binds `thenUs` \ binds' ->
235 returnUs (bind' `appendFloats` binds')
237 -- NB: we do need to float out of top-level bindings
238 -- Consider x = length [True,False]
244 -- We return a *list* of bindings, because we may start with
246 -- where x is demanded, in which case we want to finish with
249 -- And then x will actually end up case-bound
251 -- What happens to the CafInfo on the floated bindings? By
252 -- default, all the CafInfos will be set to MayHaveCafRefs,
255 -- This might be pessimistic, because eg. s1 & s2
256 -- might not refer to any CAFs and the GC will end up doing
257 -- more traversal than is necessary, but it's still better
258 -- than not floating the bindings at all, because then
259 -- the GC would have to traverse the structure in the heap
260 -- instead. Given this, we decided not to try to get
261 -- the CafInfo on the floated bindings correct, because
262 -- it looks difficult.
264 --------------------------------
265 corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
266 corePrepTopBind env (NonRec bndr rhs)
267 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
268 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
269 returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
271 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
273 --------------------------------
274 corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
275 -- This one is used for *local* bindings
276 corePrepBind env (NonRec bndr rhs)
277 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
278 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
279 cloneBndr env bndr `thenUs` \ (_, bndr') ->
280 mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') ->
281 -- We want bndr'' in the envt, because it records
282 -- the evaluated-ness of the binder
283 returnUs (extendCorePrepEnv env bndr bndr'', floats')
285 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
287 --------------------------------
288 corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
289 -> [(Id,CoreExpr)] -- Recursive bindings
290 -> UniqSM (CorePrepEnv, Floats)
291 -- Used for all recursive bindings, top level and otherwise
292 corePrepRecPairs lvl env pairs
293 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
294 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
295 returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
297 -- Flatten all the floats, and the currrent
298 -- group into a single giant Rec
299 flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
301 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
302 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
303 get b prs2 = pprPanic "corePrepRecPairs" (ppr b)
305 --------------------------------
306 corePrepRhs :: TopLevelFlag -> RecFlag
307 -> CorePrepEnv -> (Id, CoreExpr)
308 -> UniqSM (Floats, CoreExpr)
309 -- Used for top-level bindings, and local recursive bindings
310 corePrepRhs top_lvl is_rec env (bndr, rhs)
311 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
312 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
313 floatRhs top_lvl is_rec bndr floats_w_rhs
316 -- ---------------------------------------------------------------------------
317 -- Making arguments atomic (function args & constructor args)
318 -- ---------------------------------------------------------------------------
320 -- This is where we arrange that a non-trivial argument is let-bound
321 corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
322 -> UniqSM (Floats, CoreArg)
323 corePrepArg env arg dem
324 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
325 if exprIsTrivial arg'
326 then returnUs (floats, arg')
327 else newVar (exprType arg') `thenUs` \ v ->
328 mkLocalNonRec v dem floats arg' `thenUs` \ (floats', v') ->
329 returnUs (floats', Var v')
331 -- version that doesn't consider an scc annotation to be trivial.
332 exprIsTrivial (Var v) = True
333 exprIsTrivial (Type _) = True
334 exprIsTrivial (Lit lit) = True
335 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
336 exprIsTrivial (Note (SCC _) e) = False
337 exprIsTrivial (Note (TickBox {}) e) = False
338 exprIsTrivial (Note (BinaryTickBox {}) e) = False
339 exprIsTrivial (Note _ e) = exprIsTrivial e
340 exprIsTrivial (Cast e co) = exprIsTrivial e
341 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
342 exprIsTrivial other = False
344 -- ---------------------------------------------------------------------------
345 -- Dealing with expressions
346 -- ---------------------------------------------------------------------------
348 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
349 corePrepAnExpr env expr
350 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
354 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
358 -- e = let bs in e' (semantically, that is!)
361 -- f (g x) ===> ([v = g x], f v)
363 corePrepExprFloat env (Var v)
364 = fiddleCCall v `thenUs` \ v1 ->
366 v2 = lookupCorePrepEnv env v1
368 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
370 corePrepExprFloat env expr@(Type _)
371 = returnUs (emptyFloats, expr)
373 corePrepExprFloat env expr@(Lit lit)
374 = returnUs (emptyFloats, expr)
376 corePrepExprFloat env (Let bind body)
377 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
378 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
379 returnUs (new_binds `appendFloats` floats, new_body)
381 corePrepExprFloat env (Note n@(SCC _) expr)
382 = corePrepAnExpr env expr `thenUs` \ expr1 ->
383 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
384 returnUs (floats, Note n expr2)
386 corePrepExprFloat env (Note note@(TickBox {}) expr)
387 = corePrepAnExpr env expr `thenUs` \ expr1 ->
388 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
389 return (floats, Note note expr2)
391 corePrepExprFloat env (Note note@(BinaryTickBox m t e) expr)
392 = corePrepAnExpr env expr `thenUs` \ expr1 ->
393 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
394 getUniqueUs `thenUs` \ u ->
395 let bndr = mkSysLocal FSLIT("t") u boolTy in
396 return (floats, Case expr2
399 [ (DataAlt falseDataCon, [], Note (TickBox m e) (Var falseDataConId))
400 , (DataAlt trueDataCon, [], Note (TickBox m t) (Var trueDataConId))
403 corePrepExprFloat env (Note other_note expr)
404 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
405 returnUs (floats, Note other_note expr')
407 corePrepExprFloat env (Cast expr co)
408 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
409 returnUs (floats, Cast expr' co)
411 corePrepExprFloat env expr@(Lam _ _)
412 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
413 corePrepAnExpr env' body `thenUs` \ body' ->
414 returnUs (emptyFloats, mkLams bndrs' body')
416 (bndrs,body) = collectBinders expr
418 corePrepExprFloat env (Case (Note note@(TickBox m n) expr) bndr ty alts)
419 = corePrepExprFloat env (Note note (Case expr bndr ty alts))
421 corePrepExprFloat env (Case (Note note@(BinaryTickBox m t e) expr) bndr ty alts)
422 = do { ASSERT(exprType expr `coreEqType` boolTy)
423 corePrepExprFloat env $
425 [ (DataAlt falseDataCon, [], Note (TickBox m e) falseBranch)
426 , (DataAlt trueDataCon, [], Note (TickBox m t) trueBranch)
430 (_,_,trueBranch) = findAlt (DataAlt trueDataCon) alts
431 (_,_,falseBranch) = findAlt (DataAlt falseDataCon) alts
433 corePrepExprFloat env (Case scrut bndr ty alts)
434 = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
435 deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
437 bndr1 = bndr `setIdUnfolding` evaldUnfolding
438 -- Record that the case binder is evaluated in the alternatives
440 cloneBndr env bndr1 `thenUs` \ (env', bndr2) ->
441 mapUs (sat_alt env') alts `thenUs` \ alts' ->
442 returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
444 sat_alt env (con, bs, rhs)
445 = cloneBndrs env bs `thenUs` \ (env2, bs') ->
446 corePrepAnExpr env2 rhs `thenUs` \ rhs1 ->
447 deLam rhs1 `thenUs` \ rhs2 ->
448 returnUs (con, bs', rhs2)
450 corePrepExprFloat env expr@(App _ _)
451 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
452 ASSERT(null ss) -- make sure we used all the strictness info
454 -- Now deal with the function
456 Var fn_id -> maybeSaturate fn_id app depth floats ty
457 _other -> returnUs (floats, app)
461 -- Deconstruct and rebuild the application, floating any non-atomic
462 -- arguments to the outside. We collect the type of the expression,
463 -- the head of the application, and the number of actual value arguments,
464 -- all of which are used to possibly saturate this application if it
465 -- has a constructor or primop at the head.
469 -> Int -- current app depth
470 -> UniqSM (CoreExpr, -- the rebuilt expression
471 (CoreExpr,Int), -- the head of the application,
472 -- and no. of args it was applied to
473 Type, -- type of the whole expr
474 Floats, -- any floats we pulled out
475 [Demand]) -- remaining argument demands
477 collect_args (App fun arg@(Type arg_ty)) depth
478 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
479 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
481 collect_args (App fun arg) depth
482 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
484 (ss1, ss_rest) = case ss of
485 (ss1:ss_rest) -> (ss1, ss_rest)
487 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
488 splitFunTy_maybe fun_ty
490 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
491 returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
493 collect_args (Var v) depth
494 = fiddleCCall v `thenUs` \ v1 ->
496 v2 = lookupCorePrepEnv env v1
498 returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
500 stricts = case idNewStrictness v of
501 StrictSig (DmdType _ demands _)
502 | listLengthCmp demands depth /= GT -> demands
503 -- length demands <= depth
505 -- If depth < length demands, then we have too few args to
506 -- satisfy strictness info so we have to ignore all the
507 -- strictness info, e.g. + (error "urk")
508 -- Here, we can't evaluate the arg strictly, because this
509 -- partial application might be seq'd
511 collect_args (Cast fun co) depth
512 = let (_ty1,ty2) = coercionKind co in
513 collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
514 returnUs (Cast fun' co, hd, ty2, floats, ss)
516 collect_args (Note note fun) depth
517 | ignore_note note -- Drop these notes altogether
518 -- They aren't used by the code generator
519 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
520 returnUs (fun', hd, fun_ty, floats, ss)
522 -- N-variable fun, better let-bind it
523 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
524 -- since it is sure to be evaluated.
525 collect_args fun depth
526 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
527 newVar ty `thenUs` \ fn_id ->
528 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ (floats, fn_id') ->
529 returnUs (Var fn_id', (Var fn_id', depth), ty, floats, [])
533 ignore_note (CoreNote _) = True
534 ignore_note InlineMe = True
535 ignore_note _other = False
536 -- We don't ignore SCCs, since they require some code generation
538 ------------------------------------------------------------------------------
539 -- Building the saturated syntax
540 -- ---------------------------------------------------------------------------
542 -- maybeSaturate deals with saturating primops and constructors
543 -- The type is the type of the entire application
544 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
545 maybeSaturate fn expr n_args floats ty
546 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
547 -- A gruesome special case
548 = saturate_it `thenUs` \ sat_expr ->
550 -- OK, now ensure that the arg is evaluated.
551 -- But (sigh) take into account the lambdas we've now introduced
553 (eta_bndrs, eta_body) = collectBinders sat_expr
555 eval_data2tag_arg eta_body `thenUs` \ (eta_floats, eta_body') ->
556 if null eta_bndrs then
557 returnUs (floats `appendFloats` eta_floats, eta_body')
559 mkBinds eta_floats eta_body' `thenUs` \ eta_body'' ->
560 returnUs (floats, mkLams eta_bndrs eta_body'')
562 | hasNoBinding fn = saturate_it `thenUs` \ sat_expr ->
563 returnUs (floats, sat_expr)
565 | otherwise = returnUs (floats, expr)
568 fn_arity = idArity fn
569 excess_arity = fn_arity - n_args
571 saturate_it :: UniqSM CoreExpr
572 saturate_it | excess_arity == 0 = returnUs expr
573 | otherwise = getUniquesUs `thenUs` \ us ->
574 returnUs (etaExpand excess_arity us expr ty)
576 -- Ensure that the argument of DataToTagOp is evaluated
577 eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
578 eval_data2tag_arg app@(fun `App` arg)
579 | exprIsHNF arg -- Includes nullary constructors
580 = returnUs (emptyFloats, app) -- The arg is evaluated
581 | otherwise -- Arg not evaluated, so evaluate it
582 = newVar (exprType arg) `thenUs` \ arg_id ->
584 arg_id1 = setIdUnfolding arg_id evaldUnfolding
586 returnUs (unitFloat (FloatCase arg_id1 arg False ),
587 fun `App` Var arg_id1)
589 eval_data2tag_arg (Note note app) -- Scc notes can appear
590 = eval_data2tag_arg app `thenUs` \ (floats, app') ->
591 returnUs (floats, Note note app')
593 eval_data2tag_arg other -- Should not happen
594 = pprPanic "eval_data2tag" (ppr other)
597 -- ---------------------------------------------------------------------------
598 -- Precipitating the floating bindings
599 -- ---------------------------------------------------------------------------
601 floatRhs :: TopLevelFlag -> RecFlag
603 -> (Floats, CoreExpr) -- Rhs: let binds in body
604 -> UniqSM (Floats, -- Floats out of this bind
605 CoreExpr) -- Final Rhs
607 floatRhs top_lvl is_rec bndr (floats, rhs)
608 | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
609 allLazy top_lvl is_rec floats -- at top level
610 = -- Why the test for allLazy?
611 -- v = f (x `divInt#` y)
612 -- we don't want to float the case, even if f has arity 2,
613 -- because floating the case would make it evaluated too early
614 returnUs (floats, rhs)
617 -- Don't float; the RHS isn't a value
618 = mkBinds floats rhs `thenUs` \ rhs' ->
619 returnUs (emptyFloats, rhs')
621 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
622 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
623 -> Floats -> CoreExpr -- Rhs: let binds in body
624 -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
625 -- to record that it's been evaluated
627 mkLocalNonRec bndr dem floats rhs
628 | isUnLiftedType (idType bndr)
629 -- If this is an unlifted binding, we always make a case for it.
630 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
632 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
634 returnUs (addFloat floats float, evald_bndr)
637 -- It's a strict let so we definitely float all the bindings
638 = let -- Don't make a case for a value binding,
639 -- even if it's strict. Otherwise we get
640 -- case (\x -> e) of ...!
641 float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
642 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
644 returnUs (addFloat floats float, evald_bndr)
647 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
648 returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
649 if exprIsHNF rhs' then evald_bndr else bndr)
652 evald_bndr = bndr `setIdUnfolding` evaldUnfolding
653 -- Record if the binder is evaluated
656 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
657 mkBinds (Floats _ binds) body
658 | isNilOL binds = returnUs body
659 | otherwise = deLam body `thenUs` \ body' ->
660 -- Lambdas are not allowed as the body of a 'let'
661 returnUs (foldrOL mk_bind body' binds)
663 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
664 mk_bind (FloatLet bind) body = Let bind body
666 etaExpandRhs bndr rhs
667 = -- Eta expand to match the arity claimed by the binder
668 -- Remember, after CorePrep we must not change arity
670 -- Eta expansion might not have happened already,
671 -- because it is done by the simplifier only when
672 -- there at least one lambda already.
674 -- NB1:we could refrain when the RHS is trivial (which can happen
675 -- for exported things). This would reduce the amount of code
676 -- generated (a little) and make things a little words for
677 -- code compiled without -O. The case in point is data constructor
680 -- NB2: we have to be careful that the result of etaExpand doesn't
681 -- invalidate any of the assumptions that CorePrep is attempting
682 -- to establish. One possible cause is eta expanding inside of
683 -- an SCC note - we're now careful in etaExpand to make sure the
684 -- SCC is pushed inside any new lambdas that are generated.
686 -- NB3: It's important to do eta expansion, and *then* ANF-ising
687 -- f = /\a -> g (h 3) -- h has arity 2
688 -- If we ANF first we get
689 -- f = /\a -> let s = h 3 in g s
690 -- and now eta expansion gives
691 -- f = /\a -> \ y -> (let s = h 3 in g s) y
692 -- which is horrible.
693 -- Eta expanding first gives
694 -- f = /\a -> \y -> let s = h 3 in g s y
696 getUniquesUs `thenUs` \ us ->
697 returnUs (etaExpand arity us rhs (idType bndr))
699 -- For a GlobalId, take the Arity from the Id.
700 -- It was set in CoreTidy and must not change
701 -- For all others, just expand at will
702 arity | isGlobalId bndr = idArity bndr
703 | otherwise = exprArity rhs
705 -- ---------------------------------------------------------------------------
706 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
707 -- We arrange that they only show up as the RHS of a let(rec)
708 -- ---------------------------------------------------------------------------
710 deLam :: CoreExpr -> UniqSM CoreExpr
711 -- Takes an expression that may be a lambda,
712 -- and returns one that definitely isn't:
713 -- (\x.e) ==> let f = \x.e in f
715 deLamFloat expr `thenUs` \ (floats, expr) ->
719 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
720 -- Remove top level lambdas by let-bindinig
722 deLamFloat (Note n expr)
723 = -- You can get things like
724 -- case e of { p -> coerce t (\s -> ...) }
725 deLamFloat expr `thenUs` \ (floats, expr') ->
726 returnUs (floats, Note n expr')
728 deLamFloat (Cast e co)
729 = deLamFloat e `thenUs` \ (floats, e') ->
730 returnUs (floats, Cast e' co)
733 | null bndrs = returnUs (emptyFloats, expr)
735 = case tryEta bndrs body of
736 Just no_lam_result -> returnUs (emptyFloats, no_lam_result)
737 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
738 returnUs (unitFloat (FloatLet (NonRec fn expr)),
741 (bndrs,body) = collectBinders expr
743 -- Why try eta reduction? Hasn't the simplifier already done eta?
744 -- But the simplifier only eta reduces if that leaves something
745 -- trivial (like f, or f Int). But for deLam it would be enough to
746 -- get to a partial application:
747 -- \xs. map f xs ==> map f
749 tryEta bndrs expr@(App _ _)
750 | ok_to_eta_reduce f &&
752 and (zipWith ok bndrs last_args) &&
753 not (any (`elemVarSet` fvs_remaining) bndrs)
754 = Just remaining_expr
756 (f, args) = collectArgs expr
757 remaining_expr = mkApps f remaining_args
758 fvs_remaining = exprFreeVars remaining_expr
759 (remaining_args, last_args) = splitAt n_remaining args
760 n_remaining = length args - length bndrs
762 ok bndr (Var arg) = bndr == arg
763 ok bndr other = False
765 -- we can't eta reduce something which must be saturated.
766 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
767 ok_to_eta_reduce _ = False --safe. ToDo: generalise
769 tryEta bndrs (Let bind@(NonRec b r) body)
770 | not (any (`elemVarSet` fvs) bndrs)
771 = case tryEta bndrs body of
772 Just e -> Just (Let bind e)
777 tryEta bndrs _ = Nothing
781 -- -----------------------------------------------------------------------------
783 -- -----------------------------------------------------------------------------
787 = RhsDemand { isStrict :: Bool, -- True => used at least once
788 isOnceDem :: Bool -- True => used at most once
791 mkDem :: Demand -> Bool -> RhsDemand
792 mkDem strict once = RhsDemand (isStrictDmd strict) once
794 mkDemTy :: Demand -> Type -> RhsDemand
795 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
798 bdrDem :: Id -> RhsDemand
799 bdrDem id = mkDem (idNewDemandInfo id)
802 -- safeDem :: RhsDemand
803 -- safeDem = RhsDemand False False -- always safe to use this
806 onceDem = RhsDemand False True -- used at most once
812 %************************************************************************
816 %************************************************************************
819 -- ---------------------------------------------------------------------------
821 -- ---------------------------------------------------------------------------
823 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
825 emptyCorePrepEnv :: CorePrepEnv
826 emptyCorePrepEnv = CPE emptyVarEnv
828 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
829 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
831 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
832 lookupCorePrepEnv (CPE env) id
833 = case lookupVarEnv env id of
837 ------------------------------------------------------------------------------
839 -- ---------------------------------------------------------------------------
841 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
842 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
844 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
847 = getUniqueUs `thenUs` \ uniq ->
849 bndr' = setVarUnique bndr uniq
851 returnUs (extendCorePrepEnv env bndr bndr', bndr')
853 | otherwise -- Top level things, which we don't want
854 -- to clone, have become GlobalIds by now
855 -- And we don't clone tyvars
856 = returnUs (env, bndr)
859 ------------------------------------------------------------------------------
860 -- Cloning ccall Ids; each must have a unique name,
861 -- to give the code generator a handle to hang it on
862 -- ---------------------------------------------------------------------------
864 fiddleCCall :: Id -> UniqSM Id
866 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
867 returnUs (id `setVarUnique` uniq)
868 | otherwise = returnUs id
870 ------------------------------------------------------------------------------
871 -- Generating new binders
872 -- ---------------------------------------------------------------------------
874 newVar :: Type -> UniqSM Id
877 getUniqueUs `thenUs` \ uniq ->
878 returnUs (mkSysLocal FSLIT("sat") uniq ty)