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)
38 -- ---------------------------------------------------------------------------
40 -- ---------------------------------------------------------------------------
42 The goal of this pass is to prepare for code generation.
44 1. Saturate constructor and primop applications.
46 2. Convert to A-normal form; that is, function arguments
49 * Use case for strict arguments:
50 f E ==> case E of x -> f x
53 * Use let for non-trivial lazy arguments
54 f E ==> let x = E in f x
55 (were f is lazy and x is non-trivial)
57 3. Similarly, convert any unboxed lets into cases.
58 [I'm experimenting with leaving 'ok-for-speculation'
59 rhss in let-form right up to this point.]
61 4. Ensure that lambdas only occur as the RHS of a binding
62 (The code generator can't deal with anything else.)
64 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
66 6. Clone all local Ids.
67 This means that all such Ids are unique, rather than the
68 weaker guarantee of no clashes which the simplifier provides.
69 And that is what the code generator needs.
71 We don't clone TyVars. The code gen doesn't need that,
72 and doing so would be tiresome because then we'd need
73 to substitute in types.
76 7. Give each dynamic CCall occurrence a fresh unique; this is
77 rather like the cloning step above.
79 8. Inject bindings for the "implicit" Ids:
80 * Constructor wrappers
83 We want curried definitions for all of these in case they
84 aren't inlined by some caller.
86 This is all done modulo type applications and abstractions, so that
87 when type erasure is done for conversion to STG, we don't end up with
88 any trivial or useless bindings.
92 -- -----------------------------------------------------------------------------
94 -- -----------------------------------------------------------------------------
97 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
98 corePrepPgm dflags binds data_tycons
99 = do showPass dflags "CorePrep"
100 us <- mkSplitUniqSupply 's'
102 let implicit_binds = mkDataConWorkers data_tycons
103 -- NB: we must feed mkImplicitBinds through corePrep too
104 -- so that they are suitably cloned and eta-expanded
106 binds_out = initUs_ us (
107 corePrepTopBinds binds `thenUs` \ floats1 ->
108 corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
109 returnUs (deFloatTop (floats1 `appendFloats` floats2))
112 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
115 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
116 corePrepExpr dflags expr
117 = do showPass dflags "CorePrep"
118 us <- mkSplitUniqSupply 's'
119 let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
120 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
125 -- -----------------------------------------------------------------------------
127 -- -----------------------------------------------------------------------------
129 Create any necessary "implicit" bindings for data con workers. We
130 create the rather strange (non-recursive!) binding
132 $wC = \x y -> $wC x y
134 i.e. a curried constructor that allocates. This means that we can
135 treat the worker for a constructor like any other function in the rest
136 of the compiler. The point here is that CoreToStg will generate a
137 StgConApp for the RHS, rather than a call to the worker (which would
138 give a loop). As Lennart says: the ice is thin here, but it works.
140 Hmm. Should we create bindings for dictionary constructors? They are
141 always fully applied, and the bindings are just there to support
142 partial applications. But it's easier to let them through.
145 mkDataConWorkers data_tycons
146 = [ NonRec id (Var id) -- The ice is thin here, but it works
147 | tycon <- data_tycons, -- CorePrep will eta-expand it
148 data_con <- tyConDataCons tycon,
149 let id = dataConWorkId data_con ]
154 -- ---------------------------------------------------------------------------
155 -- Dealing with bindings
156 -- ---------------------------------------------------------------------------
158 data FloatingBind = FloatLet CoreBind
159 | FloatCase Id CoreExpr Bool
160 -- The bool indicates "ok-for-speculation"
162 data Floats = Floats OkToSpec (OrdList FloatingBind)
164 -- Can we float these binds out of the rhs of a let? We cache this decision
165 -- to avoid having to recompute it in a non-linear way when there are
166 -- deeply nested lets.
168 = NotOkToSpec -- definitely not
170 | IfUnboxedOk -- only if floating an unboxed binding is ok
172 emptyFloats :: Floats
173 emptyFloats = Floats OkToSpec nilOL
175 addFloat :: Floats -> FloatingBind -> Floats
176 addFloat (Floats ok_to_spec floats) new_float
177 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
179 check (FloatLet _) = OkToSpec
180 check (FloatCase _ _ ok_for_spec)
181 | ok_for_spec = IfUnboxedOk
182 | otherwise = NotOkToSpec
183 -- The ok-for-speculation flag says that it's safe to
184 -- float this Case out of a let, and thereby do it more eagerly
185 -- We need the top-level flag because it's never ok to float
186 -- an unboxed binding to the top level
188 unitFloat :: FloatingBind -> Floats
189 unitFloat = addFloat emptyFloats
191 appendFloats :: Floats -> Floats -> Floats
192 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
193 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
195 concatFloats :: [Floats] -> Floats
196 concatFloats = foldr appendFloats emptyFloats
198 combine NotOkToSpec _ = NotOkToSpec
199 combine _ NotOkToSpec = NotOkToSpec
200 combine IfUnboxedOk _ = IfUnboxedOk
201 combine _ IfUnboxedOk = IfUnboxedOk
202 combine _ _ = OkToSpec
204 instance Outputable FloatingBind where
205 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
206 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
208 deFloatTop :: Floats -> [CoreBind]
209 -- For top level only; we don't expect any FloatCases
210 deFloatTop (Floats _ floats)
211 = foldrOL get [] floats
213 get (FloatLet b) bs = b:bs
214 get b bs = pprPanic "corePrepPgm" (ppr b)
216 allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
217 allLazy top_lvl is_rec (Floats ok_to_spec _)
221 IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
223 -- ---------------------------------------------------------------------------
225 -- ---------------------------------------------------------------------------
227 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
228 corePrepTopBinds binds
229 = go emptyCorePrepEnv binds
231 go env [] = returnUs emptyFloats
232 go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
233 go env' binds `thenUs` \ binds' ->
234 returnUs (bind' `appendFloats` binds')
236 -- NB: we do need to float out of top-level bindings
237 -- Consider x = length [True,False]
243 -- We return a *list* of bindings, because we may start with
245 -- where x is demanded, in which case we want to finish with
248 -- And then x will actually end up case-bound
250 -- What happens to the CafInfo on the floated bindings? By
251 -- default, all the CafInfos will be set to MayHaveCafRefs,
254 -- This might be pessimistic, because eg. s1 & s2
255 -- might not refer to any CAFs and the GC will end up doing
256 -- more traversal than is necessary, but it's still better
257 -- than not floating the bindings at all, because then
258 -- the GC would have to traverse the structure in the heap
259 -- instead. Given this, we decided not to try to get
260 -- the CafInfo on the floated bindings correct, because
261 -- it looks difficult.
263 --------------------------------
264 corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
265 corePrepTopBind env (NonRec bndr rhs)
266 = cloneBndr env bndr `thenUs` \ (env', bndr') ->
267 corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') ->
268 returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
270 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
272 --------------------------------
273 corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
274 -- This one is used for *local* bindings
275 corePrepBind env (NonRec bndr rhs)
276 = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
277 corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
278 cloneBndr env bndr `thenUs` \ (_, bndr') ->
279 mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') ->
280 -- We want bndr'' in the envt, because it records
281 -- the evaluated-ness of the binder
282 returnUs (extendCorePrepEnv env bndr bndr'', floats')
284 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
286 --------------------------------
287 corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
288 -> [(Id,CoreExpr)] -- Recursive bindings
289 -> UniqSM (CorePrepEnv, Floats)
290 -- Used for all recursive bindings, top level and otherwise
291 corePrepRecPairs lvl env pairs
292 = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') ->
293 mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') ->
294 returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
296 -- Flatten all the floats, and the currrent
297 -- group into a single giant Rec
298 flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
300 get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
301 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
302 get b prs2 = pprPanic "corePrepRecPairs" (ppr b)
304 --------------------------------
305 corePrepRhs :: TopLevelFlag -> RecFlag
306 -> CorePrepEnv -> (Id, CoreExpr)
307 -> UniqSM (Floats, CoreExpr)
308 -- Used for top-level bindings, and local recursive bindings
309 corePrepRhs top_lvl is_rec env (bndr, rhs)
310 = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
311 corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
312 floatRhs top_lvl is_rec bndr floats_w_rhs
315 -- ---------------------------------------------------------------------------
316 -- Making arguments atomic (function args & constructor args)
317 -- ---------------------------------------------------------------------------
319 -- This is where we arrange that a non-trivial argument is let-bound
320 corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
321 -> UniqSM (Floats, CoreArg)
322 corePrepArg env arg dem
323 = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
324 if exprIsTrivial arg'
325 then returnUs (floats, arg')
326 else newVar (exprType arg') `thenUs` \ v ->
327 mkLocalNonRec v dem floats arg' `thenUs` \ (floats', v') ->
328 returnUs (floats', Var v')
330 -- version that doesn't consider an scc annotation to be trivial.
331 exprIsTrivial (Var v) = True
332 exprIsTrivial (Type _) = True
333 exprIsTrivial (Lit lit) = True
334 exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
335 exprIsTrivial (Note (SCC _) e) = False
336 exprIsTrivial (Note _ e) = exprIsTrivial e
337 exprIsTrivial (Cast e co) = exprIsTrivial e
338 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
339 exprIsTrivial other = False
341 -- ---------------------------------------------------------------------------
342 -- Dealing with expressions
343 -- ---------------------------------------------------------------------------
345 corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
346 corePrepAnExpr env expr
347 = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
351 corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
355 -- e = let bs in e' (semantically, that is!)
358 -- f (g x) ===> ([v = g x], f v)
360 corePrepExprFloat env (Var v)
361 = fiddleCCall v `thenUs` \ v1 ->
363 v2 = lookupCorePrepEnv env v1
365 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
367 corePrepExprFloat env expr@(Type _)
368 = returnUs (emptyFloats, expr)
370 corePrepExprFloat env expr@(Lit lit)
371 = returnUs (emptyFloats, expr)
373 corePrepExprFloat env (Let bind body)
374 = corePrepBind env bind `thenUs` \ (env', new_binds) ->
375 corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
376 returnUs (new_binds `appendFloats` floats, new_body)
378 corePrepExprFloat env (Note n@(SCC _) expr)
379 = corePrepAnExpr env expr `thenUs` \ expr1 ->
380 deLamFloat expr1 `thenUs` \ (floats, expr2) ->
381 returnUs (floats, Note n expr2)
383 corePrepExprFloat env (Note other_note expr)
384 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
385 returnUs (floats, Note other_note expr')
387 corePrepExprFloat env (Cast expr co)
388 = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
389 returnUs (floats, Cast expr' co)
391 corePrepExprFloat env expr@(Lam _ _)
392 = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
393 corePrepAnExpr env' body `thenUs` \ body' ->
394 returnUs (emptyFloats, mkLams bndrs' body')
396 (bndrs,body) = collectBinders expr
398 corePrepExprFloat env (Case scrut bndr ty alts)
399 = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
400 deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
402 bndr1 = bndr `setIdUnfolding` evaldUnfolding
403 -- Record that the case binder is evaluated in the alternatives
405 cloneBndr env bndr1 `thenUs` \ (env', bndr2) ->
406 mapUs (sat_alt env') alts `thenUs` \ alts' ->
407 returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
409 sat_alt env (con, bs, rhs)
410 = cloneBndrs env bs `thenUs` \ (env2, bs') ->
411 corePrepAnExpr env2 rhs `thenUs` \ rhs1 ->
412 deLam rhs1 `thenUs` \ rhs2 ->
413 returnUs (con, bs', rhs2)
415 corePrepExprFloat env expr@(App _ _)
416 = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
417 ASSERT(null ss) -- make sure we used all the strictness info
419 -- Now deal with the function
421 Var fn_id -> maybeSaturate fn_id app depth floats ty
422 _other -> returnUs (floats, app)
426 -- Deconstruct and rebuild the application, floating any non-atomic
427 -- arguments to the outside. We collect the type of the expression,
428 -- the head of the application, and the number of actual value arguments,
429 -- all of which are used to possibly saturate this application if it
430 -- has a constructor or primop at the head.
434 -> Int -- current app depth
435 -> UniqSM (CoreExpr, -- the rebuilt expression
436 (CoreExpr,Int), -- the head of the application,
437 -- and no. of args it was applied to
438 Type, -- type of the whole expr
439 Floats, -- any floats we pulled out
440 [Demand]) -- remaining argument demands
442 collect_args (App fun arg@(Type arg_ty)) depth
443 = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
444 returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
446 collect_args (App fun arg) depth
447 = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
449 (ss1, ss_rest) = case ss of
450 (ss1:ss_rest) -> (ss1, ss_rest)
452 (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
453 splitFunTy_maybe fun_ty
455 corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
456 returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
458 collect_args (Var v) depth
459 = fiddleCCall v `thenUs` \ v1 ->
461 v2 = lookupCorePrepEnv env v1
463 returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
465 stricts = case idNewStrictness v of
466 StrictSig (DmdType _ demands _)
467 | listLengthCmp demands depth /= GT -> demands
468 -- length demands <= depth
470 -- If depth < length demands, then we have too few args to
471 -- satisfy strictness info so we have to ignore all the
472 -- strictness info, e.g. + (error "urk")
473 -- Here, we can't evaluate the arg strictly, because this
474 -- partial application might be seq'd
476 collect_args (Cast fun co) depth
477 = let (_ty1,ty2) = coercionKind co in
478 collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
479 returnUs (Cast fun' co, hd, ty2, floats, ss)
481 collect_args (Note note fun) depth
482 | ignore_note note -- Drop these notes altogether
483 -- They aren't used by the code generator
484 = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
485 returnUs (fun', hd, fun_ty, floats, ss)
487 -- N-variable fun, better let-bind it
488 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
489 -- since it is sure to be evaluated.
490 collect_args fun depth
491 = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
492 newVar ty `thenUs` \ fn_id ->
493 mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ (floats, fn_id') ->
494 returnUs (Var fn_id', (Var fn_id', depth), ty, floats, [])
498 ignore_note (CoreNote _) = True
499 ignore_note InlineMe = True
500 ignore_note _other = False
501 -- We don't ignore SCCs, since they require some code generation
503 ------------------------------------------------------------------------------
504 -- Building the saturated syntax
505 -- ---------------------------------------------------------------------------
507 -- maybeSaturate deals with saturating primops and constructors
508 -- The type is the type of the entire application
509 maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
510 maybeSaturate fn expr n_args floats ty
511 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
512 -- A gruesome special case
513 = saturate_it `thenUs` \ sat_expr ->
515 -- OK, now ensure that the arg is evaluated.
516 -- But (sigh) take into account the lambdas we've now introduced
518 (eta_bndrs, eta_body) = collectBinders sat_expr
520 eval_data2tag_arg eta_body `thenUs` \ (eta_floats, eta_body') ->
521 if null eta_bndrs then
522 returnUs (floats `appendFloats` eta_floats, eta_body')
524 mkBinds eta_floats eta_body' `thenUs` \ eta_body'' ->
525 returnUs (floats, mkLams eta_bndrs eta_body'')
527 | hasNoBinding fn = saturate_it `thenUs` \ sat_expr ->
528 returnUs (floats, sat_expr)
530 | otherwise = returnUs (floats, expr)
533 fn_arity = idArity fn
534 excess_arity = fn_arity - n_args
536 saturate_it :: UniqSM CoreExpr
537 saturate_it | excess_arity == 0 = returnUs expr
538 | otherwise = getUniquesUs `thenUs` \ us ->
539 returnUs (etaExpand excess_arity us expr ty)
541 -- Ensure that the argument of DataToTagOp is evaluated
542 eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
543 eval_data2tag_arg app@(fun `App` arg)
544 | exprIsHNF arg -- Includes nullary constructors
545 = returnUs (emptyFloats, app) -- The arg is evaluated
546 | otherwise -- Arg not evaluated, so evaluate it
547 = newVar (exprType arg) `thenUs` \ arg_id ->
549 arg_id1 = setIdUnfolding arg_id evaldUnfolding
551 returnUs (unitFloat (FloatCase arg_id1 arg False ),
552 fun `App` Var arg_id1)
554 eval_data2tag_arg (Note note app) -- Scc notes can appear
555 = eval_data2tag_arg app `thenUs` \ (floats, app') ->
556 returnUs (floats, Note note app')
558 eval_data2tag_arg other -- Should not happen
559 = pprPanic "eval_data2tag" (ppr other)
562 -- ---------------------------------------------------------------------------
563 -- Precipitating the floating bindings
564 -- ---------------------------------------------------------------------------
566 floatRhs :: TopLevelFlag -> RecFlag
568 -> (Floats, CoreExpr) -- Rhs: let binds in body
569 -> UniqSM (Floats, -- Floats out of this bind
570 CoreExpr) -- Final Rhs
572 floatRhs top_lvl is_rec bndr (floats, rhs)
573 | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or
574 allLazy top_lvl is_rec floats -- at top level
575 = -- Why the test for allLazy?
576 -- v = f (x `divInt#` y)
577 -- we don't want to float the case, even if f has arity 2,
578 -- because floating the case would make it evaluated too early
579 returnUs (floats, rhs)
582 -- Don't float; the RHS isn't a value
583 = mkBinds floats rhs `thenUs` \ rhs' ->
584 returnUs (emptyFloats, rhs')
586 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
587 mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
588 -> Floats -> CoreExpr -- Rhs: let binds in body
589 -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding,
590 -- to record that it's been evaluated
592 mkLocalNonRec bndr dem floats rhs
593 | isUnLiftedType (idType bndr)
594 -- If this is an unlifted binding, we always make a case for it.
595 = ASSERT( not (isUnboxedTupleType (idType bndr)) )
597 float = FloatCase bndr rhs (exprOkForSpeculation rhs)
599 returnUs (addFloat floats float, evald_bndr)
602 -- It's a strict let so we definitely float all the bindings
603 = let -- Don't make a case for a value binding,
604 -- even if it's strict. Otherwise we get
605 -- case (\x -> e) of ...!
606 float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
607 | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
609 returnUs (addFloat floats float, evald_bndr)
612 = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
613 returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
614 if exprIsHNF rhs' then evald_bndr else bndr)
617 evald_bndr = bndr `setIdUnfolding` evaldUnfolding
618 -- Record if the binder is evaluated
621 mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
622 mkBinds (Floats _ binds) body
623 | isNilOL binds = returnUs body
624 | otherwise = deLam body `thenUs` \ body' ->
625 -- Lambdas are not allowed as the body of a 'let'
626 returnUs (foldrOL mk_bind body' binds)
628 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
629 mk_bind (FloatLet bind) body = Let bind body
631 etaExpandRhs bndr rhs
632 = -- Eta expand to match the arity claimed by the binder
633 -- Remember, after CorePrep we must not change arity
635 -- Eta expansion might not have happened already,
636 -- because it is done by the simplifier only when
637 -- there at least one lambda already.
639 -- NB1:we could refrain when the RHS is trivial (which can happen
640 -- for exported things). This would reduce the amount of code
641 -- generated (a little) and make things a little words for
642 -- code compiled without -O. The case in point is data constructor
645 -- NB2: we have to be careful that the result of etaExpand doesn't
646 -- invalidate any of the assumptions that CorePrep is attempting
647 -- to establish. One possible cause is eta expanding inside of
648 -- an SCC note - we're now careful in etaExpand to make sure the
649 -- SCC is pushed inside any new lambdas that are generated.
651 -- NB3: It's important to do eta expansion, and *then* ANF-ising
652 -- f = /\a -> g (h 3) -- h has arity 2
653 -- If we ANF first we get
654 -- f = /\a -> let s = h 3 in g s
655 -- and now eta expansion gives
656 -- f = /\a -> \ y -> (let s = h 3 in g s) y
657 -- which is horrible.
658 -- Eta expanding first gives
659 -- f = /\a -> \y -> let s = h 3 in g s y
661 getUniquesUs `thenUs` \ us ->
662 returnUs (etaExpand arity us rhs (idType bndr))
664 -- For a GlobalId, take the Arity from the Id.
665 -- It was set in CoreTidy and must not change
666 -- For all others, just expand at will
667 arity | isGlobalId bndr = idArity bndr
668 | otherwise = exprArity rhs
670 -- ---------------------------------------------------------------------------
671 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
672 -- We arrange that they only show up as the RHS of a let(rec)
673 -- ---------------------------------------------------------------------------
675 deLam :: CoreExpr -> UniqSM CoreExpr
676 -- Takes an expression that may be a lambda,
677 -- and returns one that definitely isn't:
678 -- (\x.e) ==> let f = \x.e in f
680 deLamFloat expr `thenUs` \ (floats, expr) ->
684 deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
685 -- Remove top level lambdas by let-bindinig
687 deLamFloat (Note n expr)
688 = -- You can get things like
689 -- case e of { p -> coerce t (\s -> ...) }
690 deLamFloat expr `thenUs` \ (floats, expr') ->
691 returnUs (floats, Note n expr')
693 deLamFloat (Cast e co)
694 = deLamFloat e `thenUs` \ (floats, e') ->
695 returnUs (floats, Cast e' co)
698 | null bndrs = returnUs (emptyFloats, expr)
700 = case tryEta bndrs body of
701 Just no_lam_result -> returnUs (emptyFloats, no_lam_result)
702 Nothing -> newVar (exprType expr) `thenUs` \ fn ->
703 returnUs (unitFloat (FloatLet (NonRec fn expr)),
706 (bndrs,body) = collectBinders expr
708 -- Why try eta reduction? Hasn't the simplifier already done eta?
709 -- But the simplifier only eta reduces if that leaves something
710 -- trivial (like f, or f Int). But for deLam it would be enough to
711 -- get to a partial application:
712 -- \xs. map f xs ==> map f
714 tryEta bndrs expr@(App _ _)
715 | ok_to_eta_reduce f &&
717 and (zipWith ok bndrs last_args) &&
718 not (any (`elemVarSet` fvs_remaining) bndrs)
719 = Just remaining_expr
721 (f, args) = collectArgs expr
722 remaining_expr = mkApps f remaining_args
723 fvs_remaining = exprFreeVars remaining_expr
724 (remaining_args, last_args) = splitAt n_remaining args
725 n_remaining = length args - length bndrs
727 ok bndr (Var arg) = bndr == arg
728 ok bndr other = False
730 -- we can't eta reduce something which must be saturated.
731 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
732 ok_to_eta_reduce _ = False --safe. ToDo: generalise
734 tryEta bndrs (Let bind@(NonRec b r) body)
735 | not (any (`elemVarSet` fvs) bndrs)
736 = case tryEta bndrs body of
737 Just e -> Just (Let bind e)
742 tryEta bndrs _ = Nothing
746 -- -----------------------------------------------------------------------------
748 -- -----------------------------------------------------------------------------
752 = RhsDemand { isStrict :: Bool, -- True => used at least once
753 isOnceDem :: Bool -- True => used at most once
756 mkDem :: Demand -> Bool -> RhsDemand
757 mkDem strict once = RhsDemand (isStrictDmd strict) once
759 mkDemTy :: Demand -> Type -> RhsDemand
760 mkDemTy strict ty = RhsDemand (isStrictDmd strict)
763 bdrDem :: Id -> RhsDemand
764 bdrDem id = mkDem (idNewDemandInfo id)
767 -- safeDem :: RhsDemand
768 -- safeDem = RhsDemand False False -- always safe to use this
771 onceDem = RhsDemand False True -- used at most once
777 %************************************************************************
781 %************************************************************************
784 -- ---------------------------------------------------------------------------
786 -- ---------------------------------------------------------------------------
788 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
790 emptyCorePrepEnv :: CorePrepEnv
791 emptyCorePrepEnv = CPE emptyVarEnv
793 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
794 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
796 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
797 lookupCorePrepEnv (CPE env) id
798 = case lookupVarEnv env id of
802 ------------------------------------------------------------------------------
804 -- ---------------------------------------------------------------------------
806 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
807 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
809 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
812 = getUniqueUs `thenUs` \ uniq ->
814 bndr' = setVarUnique bndr uniq
816 returnUs (extendCorePrepEnv env bndr bndr', bndr')
818 | otherwise -- Top level things, which we don't want
819 -- to clone, have become GlobalIds by now
820 -- And we don't clone tyvars
821 = returnUs (env, bndr)
824 ------------------------------------------------------------------------------
825 -- Cloning ccall Ids; each must have a unique name,
826 -- to give the code generator a handle to hang it on
827 -- ---------------------------------------------------------------------------
829 fiddleCCall :: Id -> UniqSM Id
831 | isFCallId id = getUniqueUs `thenUs` \ uniq ->
832 returnUs (id `setVarUnique` uniq)
833 | otherwise = returnUs id
835 ------------------------------------------------------------------------------
836 -- Generating new binders
837 -- ---------------------------------------------------------------------------
839 newVar :: Type -> UniqSM Id
842 getUniqueUs `thenUs` \ uniq ->
843 returnUs (mkSysLocal FSLIT("sat") uniq ty)