2 % (c) The University of Glasgow, 1994-2006
5 Core pass to saturate constructors and PrimOps
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 corePrepPgm, corePrepExpr
19 #include "HsVersions.h"
21 import CoreUtils hiding (exprIsTrivial)
46 -- ---------------------------------------------------------------------------
48 -- ---------------------------------------------------------------------------
50 The goal of this pass is to prepare for code generation.
52 1. Saturate constructor and primop applications.
54 2. Convert to A-normal form; that is, function arguments
57 * Use case for strict arguments:
58 f E ==> case E of x -> f x
61 * Use let for non-trivial lazy arguments
62 f E ==> let x = E in f x
63 (were f is lazy and x is non-trivial)
65 3. Similarly, convert any unboxed lets into cases.
66 [I'm experimenting with leaving 'ok-for-speculation'
67 rhss in let-form right up to this point.]
69 4. Ensure that lambdas only occur as the RHS of a binding
70 (The code generator can't deal with anything else.)
72 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
74 6. Clone all local Ids.
75 This means that all such Ids are unique, rather than the
76 weaker guarantee of no clashes which the simplifier provides.
77 And that is what the code generator needs.
79 We don't clone TyVars. The code gen doesn't need that,
80 and doing so would be tiresome because then we'd need
81 to substitute in types.
84 7. Give each dynamic CCall occurrence a fresh unique; this is
85 rather like the cloning step above.
87 8. Inject bindings for the "implicit" Ids:
88 * Constructor wrappers
91 We want curried definitions for all of these in case they
92 aren't inlined by some caller.
94 This is all done modulo type applications and abstractions, so that
95 when type erasure is done for conversion to STG, we don't end up with
96 any trivial or useless bindings.
100 -- -----------------------------------------------------------------------------
102 -- -----------------------------------------------------------------------------
105 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
106 corePrepPgm dflags binds data_tycons
107 = do showPass dflags "CorePrep"
108 us <- mkSplitUniqSupply 's'
110 let implicit_binds = mkDataConWorkers data_tycons
111 -- NB: we must feed mkImplicitBinds through corePrep too
112 -- so that they are suitably cloned and eta-expanded
114 binds_out = initUs_ us (
115 corePrepTopBinds binds `thenUs` \ floats1 ->
116 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
117 returnUs (deFloatTop (floats1 `appendFloats` floats2))
120 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
123 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
124 corePrepExpr dflags expr
125 = do showPass dflags "CorePrep"
126 us <- mkSplitUniqSupply 's'
127 let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
128 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
133 -- -----------------------------------------------------------------------------
135 -- -----------------------------------------------------------------------------
137 Create any necessary "implicit" bindings for data con workers. We
138 create the rather strange (non-recursive!) binding
140 $wC = \x y -> $wC x y
142 i.e. a curried constructor that allocates. This means that we can
143 treat the worker for a constructor like any other function in the rest
144 of the compiler. The point here is that CoreToStg will generate a
145 StgConApp for the RHS, rather than a call to the worker (which would
146 give a loop). As Lennart says: the ice is thin here, but it works.
148 Hmm. Should we create bindings for dictionary constructors? They are
149 always fully applied, and the bindings are just there to support
150 partial applications. But it's easier to let them through.
153 mkDataConWorkers data_tycons
154 = [ NonRec id (Var id) -- The ice is thin here, but it works
155 | tycon <- data_tycons, -- CorePrep will eta-expand it
156 data_con <- tyConDataCons tycon,
157 let id = dataConWorkId data_con ]
162 -- ---------------------------------------------------------------------------
163 -- Dealing with bindings
164 -- ---------------------------------------------------------------------------
166 data FloatingBind = FloatLet CoreBind
167 | FloatCase Id CoreExpr Bool
168 -- The bool indicates "ok-for-speculation"
170 data Floats = Floats OkToSpec (OrdList FloatingBind)
172 -- Can we float these binds out of the rhs of a let? We cache this decision
173 -- to avoid having to recompute it in a non-linear way when there are
174 -- deeply nested lets.
176 = NotOkToSpec -- definitely not
178 | IfUnboxedOk -- only if floating an unboxed binding is ok
180 emptyFloats :: Floats
181 emptyFloats = Floats OkToSpec nilOL
183 addFloat :: Floats -> FloatingBind -> Floats
184 addFloat (Floats ok_to_spec floats) new_float
185 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
187 check (FloatLet _) = OkToSpec
188 check (FloatCase _ _ ok_for_spec)
189 | ok_for_spec = IfUnboxedOk
190 | otherwise = NotOkToSpec
191 -- The ok-for-speculation flag says that it's safe to
192 -- float this Case out of a let, and thereby do it more eagerly
193 -- We need the top-level flag because it's never ok to float
194 -- an unboxed binding to the top level
196 unitFloat :: FloatingBind -> Floats
197 unitFloat = addFloat emptyFloats
199 appendFloats :: Floats -> Floats -> Floats
200 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
201 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
203 concatFloats :: [Floats] -> Floats
204 concatFloats = foldr appendFloats emptyFloats
206 combine NotOkToSpec _ = NotOkToSpec
207 combine _ NotOkToSpec = NotOkToSpec
208 combine IfUnboxedOk _ = IfUnboxedOk
209 combine _ IfUnboxedOk = IfUnboxedOk
210 combine _ _ = OkToSpec
212 instance Outputable FloatingBind where
213 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
214 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
216 deFloatTop :: Floats -> [CoreBind]
217 -- For top level only; we don't expect any FloatCases
218 deFloatTop (Floats _ floats)
219 = foldrOL get [] floats
221 get (FloatLet b) bs = b:bs
222 get b bs = pprPanic "corePrepPgm" (ppr b)
224 allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
225 allLazy top_lvl is_rec (Floats ok_to_spec _)
229 IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
231 -- ---------------------------------------------------------------------------
233 -- ---------------------------------------------------------------------------
235 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
236 corePrepTopBinds binds
237 = go emptyCorePrepEnv binds
239 go env [] = returnUs emptyFloats
240 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
241 go env' binds `thenUs` \ binds' ->
242 returnUs (bind' `appendFloats` binds')
244 -- NB: we do need to float out of top-level bindings
245 -- Consider x = length [True,False]
251 -- We return a *list* of bindings, because we may start with
253 -- where x is demanded, in which case we want to finish with
256 -- And then x will actually end up case-bound
258 -- What happens to the CafInfo on the floated bindings? By
259 -- default, all the CafInfos will be set to MayHaveCafRefs,
262 -- This might be pessimistic, because eg. s1 & s2
263 -- might not refer to any CAFs and the GC will end up doing
264 -- more traversal than is necessary, but it's still better
265 -- than not floating the bindings at all, because then
266 -- the GC would have to traverse the structure in the heap
267 -- instead. Given this, we decided not to try to get
268 -- the CafInfo on the floated bindings correct, because
269 -- it looks difficult.
271 --------------------------------
272 corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
273 corePrepTopBind env (NonRec bndr rhs)
274 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
275 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
276 returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
278 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
280 --------------------------------
281 corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
282 -- This one is used for *local* bindings
283 corePrepBind env (NonRec bndr rhs)
284 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
285 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
286 cloneBndr env bndr `thenUs` \ (_, bndr') ->
287 mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') ->
288 -- We want bndr'' in the envt, because it records
289 -- the evaluated-ness of the binder
290 returnUs (extendCorePrepEnv env bndr bndr'', floats')
292 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
294 --------------------------------
295 corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
296 -> [(Id,CoreExpr)] -- Recursive bindings
297 -> UniqSM (CorePrepEnv, Floats)
298 -- Used for all recursive bindings, top level and otherwise
299 corePrepRecPairs lvl env pairs
300 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
301 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
302 returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
304 -- Flatten all the floats, and the currrent
305 -- group into a single giant Rec
306 flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
308 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
309 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
310 get b prs2 = pprPanic "corePrepRecPairs" (ppr b)
312 --------------------------------
313 corePrepRhs :: TopLevelFlag -> RecFlag
314 -> CorePrepEnv -> (Id, CoreExpr)
315 -> UniqSM (Floats, CoreExpr)
316 -- Used for top-level bindings, and local recursive bindings
317 corePrepRhs top_lvl is_rec env (bndr, rhs)
318 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
319 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
320 floatRhs top_lvl is_rec bndr floats_w_rhs
323 -- ---------------------------------------------------------------------------
324 -- Making arguments atomic (function args & constructor args)
325 -- ---------------------------------------------------------------------------
327 -- This is where we arrange that a non-trivial argument is let-bound
328 corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
329 -> UniqSM (Floats, CoreArg)
330 corePrepArg env arg dem
331 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
332 if exprIsTrivial arg'
333 then returnUs (floats, arg')
334 else newVar (exprType arg') `thenUs` \ v ->
335 mkLocalNonRec v dem floats arg' `thenUs` \ (floats', v') ->
336 returnUs (floats', Var v')
338 -- version that doesn't consider an scc annotation to be trivial.
339 exprIsTrivial (Var v) = True
340 exprIsTrivial (Type _) = True
341 exprIsTrivial (Lit lit) = True
342 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
343 exprIsTrivial (Note (SCC _) e) = False
344 exprIsTrivial (Note _ e) = exprIsTrivial e
345 exprIsTrivial (Cast e co) = exprIsTrivial e
346 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
347 exprIsTrivial other = False
349 -- ---------------------------------------------------------------------------
350 -- Dealing with expressions
351 -- ---------------------------------------------------------------------------
353 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
354 corePrepAnExpr env expr
355 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
359 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
363 -- e = let bs in e' (semantically, that is!)
366 -- f (g x) ===> ([v = g x], f v)
368 corePrepExprFloat env (Var v)
369 = fiddleCCall v `thenUs` \ v1 ->
371 v2 = lookupCorePrepEnv env v1
373 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
375 corePrepExprFloat env expr@(Type _)
376 = returnUs (emptyFloats, expr)
378 corePrepExprFloat env expr@(Lit lit)
379 = returnUs (emptyFloats, expr)
381 corePrepExprFloat env (Let bind body)
382 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
383 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
384 returnUs (new_binds `appendFloats` floats, new_body)
386 corePrepExprFloat env (Note n@(SCC _) expr)
387 = corePrepAnExpr env expr `thenUs` \ expr1 ->
388 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
389 returnUs (floats, Note n expr2)
391 corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
392 | Just (TickBox {}) <- isTickBoxOp_maybe id
393 = corePrepAnExpr env expr `thenUs` \ expr1 ->
394 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
395 return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
397 corePrepExprFloat env (Note other_note expr)
398 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
399 returnUs (floats, Note other_note expr')
401 corePrepExprFloat env (Cast expr co)
402 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
403 returnUs (floats, Cast expr' co)
405 corePrepExprFloat env expr@(Lam _ _)
406 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
407 corePrepAnExpr env' body `thenUs` \ body' ->
408 returnUs (emptyFloats, mkLams bndrs' body')
410 (bndrs,body) = collectBinders expr
412 corePrepExprFloat env (Case scrut bndr ty alts)
413 = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
414 deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
416 bndr1 = bndr `setIdUnfolding` evaldUnfolding
417 -- Record that the case binder is evaluated in the alternatives
419 cloneBndr env bndr1 `thenUs` \ (env', bndr2) ->
420 mapUs (sat_alt env') alts `thenUs` \ alts' ->
421 returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
423 sat_alt env (con, bs, rhs)
424 = cloneBndrs env bs `thenUs` \ (env2, bs') ->
425 corePrepAnExpr env2 rhs `thenUs` \ rhs1 ->
426 deLam rhs1 `thenUs` \ rhs2 ->
427 returnUs (con, bs', rhs2)
429 corePrepExprFloat env expr@(App _ _)
430 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
431 ASSERT(null ss) -- make sure we used all the strictness info
433 -- Now deal with the function
435 Var fn_id -> maybeSaturate fn_id app depth floats ty
436 _other -> returnUs (floats, app)
440 -- Deconstruct and rebuild the application, floating any non-atomic
441 -- arguments to the outside. We collect the type of the expression,
442 -- the head of the application, and the number of actual value arguments,
443 -- all of which are used to possibly saturate this application if it
444 -- has a constructor or primop at the head.
448 -> Int -- current app depth
449 -> UniqSM (CoreExpr, -- the rebuilt expression
450 (CoreExpr,Int), -- the head of the application,
451 -- and no. of args it was applied to
452 Type, -- type of the whole expr
453 Floats, -- any floats we pulled out
454 [Demand]) -- remaining argument demands
456 collect_args (App fun arg@(Type arg_ty)) depth
457 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
458 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
460 collect_args (App fun arg) depth
461 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
463 (ss1, ss_rest) = case ss of
464 (ss1:ss_rest) -> (ss1, ss_rest)
466 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
467 splitFunTy_maybe fun_ty
469 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
470 returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
472 collect_args (Var v) depth
473 = fiddleCCall v `thenUs` \ v1 ->
475 v2 = lookupCorePrepEnv env v1
477 returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
479 stricts = case idNewStrictness v of
480 StrictSig (DmdType _ demands _)
481 | listLengthCmp demands depth /= GT -> demands
482 -- length demands <= depth
484 -- If depth < length demands, then we have too few args to
485 -- satisfy strictness info so we have to ignore all the
486 -- strictness info, e.g. + (error "urk")
487 -- Here, we can't evaluate the arg strictly, because this
488 -- partial application might be seq'd
490 collect_args (Cast fun co) depth
491 = let (_ty1,ty2) = coercionKind co in
492 collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
493 returnUs (Cast fun' co, hd, ty2, floats, ss)
495 collect_args (Note note fun) depth
496 | ignore_note note -- Drop these notes altogether
497 -- They aren't used by the code generator
498 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
499 returnUs (fun', hd, fun_ty, floats, ss)
501 -- N-variable fun, better let-bind it
502 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
503 -- since it is sure to be evaluated.
504 collect_args fun depth
505 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
506 newVar ty `thenUs` \ fn_id ->
507 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ (floats, fn_id') ->
508 returnUs (Var fn_id', (Var fn_id', depth), ty, floats, [])
512 ignore_note (CoreNote _) = True
513 ignore_note InlineMe = True
514 ignore_note _other = False
515 -- We don't ignore SCCs, since they require some code generation
517 ------------------------------------------------------------------------------
518 -- Building the saturated syntax
519 -- ---------------------------------------------------------------------------
521 -- maybeSaturate deals with saturating primops and constructors
522 -- The type is the type of the entire application
523 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
524 maybeSaturate fn expr n_args floats ty
525 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
526 -- A gruesome special case
527 = saturate_it `thenUs` \ sat_expr ->
529 -- OK, now ensure that the arg is evaluated.
530 -- But (sigh) take into account the lambdas we've now introduced
532 (eta_bndrs, eta_body) = collectBinders sat_expr
534 eval_data2tag_arg eta_body `thenUs` \ (eta_floats, eta_body') ->
535 if null eta_bndrs then
536 returnUs (floats `appendFloats` eta_floats, eta_body')
538 mkBinds eta_floats eta_body' `thenUs` \ eta_body'' ->
539 returnUs (floats, mkLams eta_bndrs eta_body'')
541 | hasNoBinding fn = saturate_it `thenUs` \ sat_expr ->
542 returnUs (floats, sat_expr)
544 | otherwise = returnUs (floats, expr)
547 fn_arity = idArity fn
548 excess_arity = fn_arity - n_args
550 saturate_it :: UniqSM CoreExpr
551 saturate_it | excess_arity == 0 = returnUs expr
552 | otherwise = getUniquesUs `thenUs` \ us ->
553 returnUs (etaExpand excess_arity us expr ty)
555 -- Ensure that the argument of DataToTagOp is evaluated
556 eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
557 eval_data2tag_arg app@(fun `App` arg)
558 | exprIsHNF arg -- Includes nullary constructors
559 = returnUs (emptyFloats, app) -- The arg is evaluated
560 | otherwise -- Arg not evaluated, so evaluate it
561 = newVar (exprType arg) `thenUs` \ arg_id ->
563 arg_id1 = setIdUnfolding arg_id evaldUnfolding
565 returnUs (unitFloat (FloatCase arg_id1 arg False ),
566 fun `App` Var arg_id1)
568 eval_data2tag_arg (Note note app) -- Scc notes can appear
569 = eval_data2tag_arg app `thenUs` \ (floats, app') ->
570 returnUs (floats, Note note app')
572 eval_data2tag_arg other -- Should not happen
573 = pprPanic "eval_data2tag" (ppr other)
576 -- ---------------------------------------------------------------------------
577 -- Precipitating the floating bindings
578 -- ---------------------------------------------------------------------------
580 floatRhs :: TopLevelFlag -> RecFlag
582 -> (Floats, CoreExpr) -- Rhs: let binds in body
583 -> UniqSM (Floats, -- Floats out of this bind
584 CoreExpr) -- Final Rhs
586 floatRhs top_lvl is_rec bndr (floats, rhs)
587 | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
588 allLazy top_lvl is_rec floats -- at top level
589 = -- Why the test for allLazy?
590 -- v = f (x `divInt#` y)
591 -- we don't want to float the case, even if f has arity 2,
592 -- because floating the case would make it evaluated too early
593 returnUs (floats, rhs)
596 -- Don't float; the RHS isn't a value
597 = mkBinds floats rhs `thenUs` \ rhs' ->
598 returnUs (emptyFloats, rhs')
600 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
601 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
602 -> Floats -> CoreExpr -- Rhs: let binds in body
603 -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
604 -- to record that it's been evaluated
606 mkLocalNonRec bndr dem floats rhs
607 | isUnLiftedType (idType bndr)
608 -- If this is an unlifted binding, we always make a case for it.
609 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
611 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
613 returnUs (addFloat floats float, evald_bndr)
616 -- It's a strict let so we definitely float all the bindings
617 = let -- Don't make a case for a value binding,
618 -- even if it's strict. Otherwise we get
619 -- case (\x -> e) of ...!
620 float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
621 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
623 returnUs (addFloat floats float, evald_bndr)
626 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
627 returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
628 if exprIsHNF rhs' then evald_bndr else bndr)
631 evald_bndr = bndr `setIdUnfolding` evaldUnfolding
632 -- Record if the binder is evaluated
635 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
636 mkBinds (Floats _ binds) body
637 | isNilOL binds = returnUs body
638 | otherwise = deLam body `thenUs` \ body' ->
639 -- Lambdas are not allowed as the body of a 'let'
640 returnUs (foldrOL mk_bind body' binds)
642 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
643 mk_bind (FloatLet bind) body = Let bind body
645 etaExpandRhs bndr rhs
646 = -- Eta expand to match the arity claimed by the binder
647 -- Remember, after CorePrep we must not change arity
649 -- Eta expansion might not have happened already,
650 -- because it is done by the simplifier only when
651 -- there at least one lambda already.
653 -- NB1:we could refrain when the RHS is trivial (which can happen
654 -- for exported things). This would reduce the amount of code
655 -- generated (a little) and make things a little words for
656 -- code compiled without -O. The case in point is data constructor
659 -- NB2: we have to be careful that the result of etaExpand doesn't
660 -- invalidate any of the assumptions that CorePrep is attempting
661 -- to establish. One possible cause is eta expanding inside of
662 -- an SCC note - we're now careful in etaExpand to make sure the
663 -- SCC is pushed inside any new lambdas that are generated.
665 -- NB3: It's important to do eta expansion, and *then* ANF-ising
666 -- f = /\a -> g (h 3) -- h has arity 2
667 -- If we ANF first we get
668 -- f = /\a -> let s = h 3 in g s
669 -- and now eta expansion gives
670 -- f = /\a -> \ y -> (let s = h 3 in g s) y
671 -- which is horrible.
672 -- Eta expanding first gives
673 -- f = /\a -> \y -> let s = h 3 in g s y
675 getUniquesUs `thenUs` \ us ->
676 returnUs (etaExpand arity us rhs (idType bndr))
678 -- For a GlobalId, take the Arity from the Id.
679 -- It was set in CoreTidy and must not change
680 -- For all others, just expand at will
681 arity | isGlobalId bndr = idArity bndr
682 | otherwise = exprArity rhs
684 -- ---------------------------------------------------------------------------
685 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
686 -- We arrange that they only show up as the RHS of a let(rec)
687 -- ---------------------------------------------------------------------------
689 deLam :: CoreExpr -> UniqSM CoreExpr
690 -- Takes an expression that may be a lambda,
691 -- and returns one that definitely isn't:
692 -- (\x.e) ==> let f = \x.e in f
694 deLamFloat expr `thenUs` \ (floats, expr) ->
698 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
699 -- Remove top level lambdas by let-bindinig
701 deLamFloat (Note n expr)
702 = -- You can get things like
703 -- case e of { p -> coerce t (\s -> ...) }
704 deLamFloat expr `thenUs` \ (floats, expr') ->
705 returnUs (floats, Note n expr')
707 deLamFloat (Cast e co)
708 = deLamFloat e `thenUs` \ (floats, e') ->
709 returnUs (floats, Cast e' co)
712 | null bndrs = returnUs (emptyFloats, expr)
714 = case tryEta bndrs body of
715 Just no_lam_result -> returnUs (emptyFloats, no_lam_result)
716 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
717 returnUs (unitFloat (FloatLet (NonRec fn expr)),
720 (bndrs,body) = collectBinders expr
722 -- Why try eta reduction? Hasn't the simplifier already done eta?
723 -- But the simplifier only eta reduces if that leaves something
724 -- trivial (like f, or f Int). But for deLam it would be enough to
725 -- get to a partial application:
726 -- \xs. map f xs ==> map f
728 tryEta bndrs expr@(App _ _)
729 | ok_to_eta_reduce f &&
731 and (zipWith ok bndrs last_args) &&
732 not (any (`elemVarSet` fvs_remaining) bndrs)
733 = Just remaining_expr
735 (f, args) = collectArgs expr
736 remaining_expr = mkApps f remaining_args
737 fvs_remaining = exprFreeVars remaining_expr
738 (remaining_args, last_args) = splitAt n_remaining args
739 n_remaining = length args - length bndrs
741 ok bndr (Var arg) = bndr == arg
742 ok bndr other = False
744 -- we can't eta reduce something which must be saturated.
745 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
746 ok_to_eta_reduce _ = False --safe. ToDo: generalise
748 tryEta bndrs (Let bind@(NonRec b r) body)
749 | not (any (`elemVarSet` fvs) bndrs)
750 = case tryEta bndrs body of
751 Just e -> Just (Let bind e)
756 tryEta bndrs _ = Nothing
760 -- -----------------------------------------------------------------------------
762 -- -----------------------------------------------------------------------------
766 = RhsDemand { isStrict :: Bool, -- True => used at least once
767 isOnceDem :: Bool -- True => used at most once
770 mkDem :: Demand -> Bool -> RhsDemand
771 mkDem strict once = RhsDemand (isStrictDmd strict) once
773 mkDemTy :: Demand -> Type -> RhsDemand
774 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
777 bdrDem :: Id -> RhsDemand
778 bdrDem id = mkDem (idNewDemandInfo id)
781 -- safeDem :: RhsDemand
782 -- safeDem = RhsDemand False False -- always safe to use this
785 onceDem = RhsDemand False True -- used at most once
791 %************************************************************************
795 %************************************************************************
798 -- ---------------------------------------------------------------------------
800 -- ---------------------------------------------------------------------------
802 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
804 emptyCorePrepEnv :: CorePrepEnv
805 emptyCorePrepEnv = CPE emptyVarEnv
807 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
808 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
810 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
811 lookupCorePrepEnv (CPE env) id
812 = case lookupVarEnv env id of
816 ------------------------------------------------------------------------------
818 -- ---------------------------------------------------------------------------
820 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
821 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
823 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
826 = getUniqueUs `thenUs` \ uniq ->
828 bndr' = setVarUnique bndr uniq
830 returnUs (extendCorePrepEnv env bndr bndr', bndr')
832 | otherwise -- Top level things, which we don't want
833 -- to clone, have become GlobalIds by now
834 -- And we don't clone tyvars
835 = returnUs (env, bndr)
838 ------------------------------------------------------------------------------
839 -- Cloning ccall Ids; each must have a unique name,
840 -- to give the code generator a handle to hang it on
841 -- ---------------------------------------------------------------------------
843 fiddleCCall :: Id -> UniqSM Id
845 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
846 returnUs (id `setVarUnique` uniq)
847 | otherwise = returnUs id
849 ------------------------------------------------------------------------------
850 -- Generating new binders
851 -- ---------------------------------------------------------------------------
853 newVar :: Type -> UniqSM Id
856 getUniqueUs `thenUs` \ uniq ->
857 returnUs (mkSysLocal FSLIT("sat") uniq ty)