2 % (c) The University of Glasgow, 1994-2006
5 Core pass to saturate constructors and PrimOps
9 corePrepPgm, corePrepExpr
12 #include "HsVersions.h"
43 -- ---------------------------------------------------------------------------
45 -- ---------------------------------------------------------------------------
47 The goal of this pass is to prepare for code generation.
49 1. Saturate constructor and primop applications.
51 2. Convert to A-normal form; that is, function arguments
54 * Use case for strict arguments:
55 f E ==> case E of x -> f x
58 * Use let for non-trivial lazy arguments
59 f E ==> let x = E in f x
60 (were f is lazy and x is non-trivial)
62 3. Similarly, convert any unboxed lets into cases.
63 [I'm experimenting with leaving 'ok-for-speculation'
64 rhss in let-form right up to this point.]
66 4. Ensure that *value* lambdas only occur as the RHS of a binding
67 (The code generator can't deal with anything else.)
68 Type lambdas are ok, however, because the code gen discards them.
70 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
72 6. Clone all local Ids.
73 This means that all such Ids are unique, rather than the
74 weaker guarantee of no clashes which the simplifier provides.
75 And that is what the code generator needs.
77 We don't clone TyVars. The code gen doesn't need that,
78 and doing so would be tiresome because then we'd need
79 to substitute in types.
82 7. Give each dynamic CCall occurrence a fresh unique; this is
83 rather like the cloning step above.
85 8. Inject bindings for the "implicit" Ids:
86 * Constructor wrappers
89 We want curried definitions for all of these in case they
90 aren't inlined by some caller.
92 This is all done modulo type applications and abstractions, so that
93 when type erasure is done for conversion to STG, we don't end up with
94 any trivial or useless bindings.
99 Here is the syntax of the Core produced by CorePrep:
102 triv ::= lit | var | triv ty | /\a. triv | triv |> co
105 app ::= lit | var | app triv | app ty | app |> co
109 | let(rec) x = rhs in body -- Boxed only
110 | case body of pat -> body
114 Right hand sides (only place where lambdas can occur)
115 rhs ::= /\a.rhs | \x.rhs | body
117 We define a synonym for each of these non-terminals. Functions
118 with the corresponding name produce a result in that syntax.
121 type CpeTriv = CoreExpr -- Non-terminal 'triv'
122 type CpeApp = CoreExpr -- Non-terminal 'app'
123 type CpeBody = CoreExpr -- Non-terminal 'body'
124 type CpeRhs = CoreExpr -- Non-terminal 'rhs'
127 %************************************************************************
131 %************************************************************************
134 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
135 corePrepPgm dflags binds data_tycons = do
136 showPass dflags "CorePrep"
137 us <- mkSplitUniqSupply 's'
139 let implicit_binds = mkDataConWorkers data_tycons
140 -- NB: we must feed mkImplicitBinds through corePrep too
141 -- so that they are suitably cloned and eta-expanded
143 binds_out = initUs_ us $ do
144 floats1 <- corePrepTopBinds binds
145 floats2 <- corePrepTopBinds implicit_binds
146 return (deFloatTop (floats1 `appendFloats` floats2))
148 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
151 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
152 corePrepExpr dflags expr = do
153 showPass dflags "CorePrep"
154 us <- mkSplitUniqSupply 's'
155 let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr)
156 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
159 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
160 -- Note [Floating out of top level bindings]
161 corePrepTopBinds binds
162 = go emptyCorePrepEnv binds
164 go _ [] = return emptyFloats
165 go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
166 binds' <- go env' binds
167 return (bind' `appendFloats` binds')
169 mkDataConWorkers :: [TyCon] -> [CoreBind]
170 -- See Note [Data constructor workers]
171 mkDataConWorkers data_tycons
172 = [ NonRec id (Var id) -- The ice is thin here, but it works
173 | tycon <- data_tycons, -- CorePrep will eta-expand it
174 data_con <- tyConDataCons tycon,
175 let id = dataConWorkId data_con ]
178 Note [Floating out of top level bindings]
179 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
180 NB: we do need to float out of top-level bindings
181 Consider x = length [True,False]
187 We return a *list* of bindings, because we may start with
189 where x is demanded, in which case we want to finish with
192 And then x will actually end up case-bound
194 Note [CafInfo and floating]
195 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
196 What happens to the CafInfo on the floated bindings? By default, all
197 the CafInfos will be set to MayHaveCafRefs, which is safe.
199 This might be pessimistic, because the floated binding might not refer
200 to any CAFs and the GC will end up doing more traversal than is
201 necessary, but it's still better than not floating the bindings at
202 all, because then the GC would have to traverse the structure in the
203 heap instead. Given this, we decided not to try to get the CafInfo on
204 the floated bindings correct, because it looks difficult.
206 But that means we can't float anything out of a NoCafRefs binding.
208 If f is NoCafRefs, we don't want to convert to
211 where sat conservatively says HasCafRefs, because now f's info
212 is wrong. I don't think this is common, so we simply switch off
213 floating in this case.
215 Note [Data constructor workers]
216 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
217 Create any necessary "implicit" bindings for data con workers. We
218 create the rather strange (non-recursive!) binding
220 $wC = \x y -> $wC x y
222 i.e. a curried constructor that allocates. This means that we can
223 treat the worker for a constructor like any other function in the rest
224 of the compiler. The point here is that CoreToStg will generate a
225 StgConApp for the RHS, rather than a call to the worker (which would
226 give a loop). As Lennart says: the ice is thin here, but it works.
228 Hmm. Should we create bindings for dictionary constructors? They are
229 always fully applied, and the bindings are just there to support
230 partial applications. But it's easier to let them through.
233 %************************************************************************
237 %************************************************************************
240 cpeBind :: TopLevelFlag
241 -> CorePrepEnv -> CoreBind
242 -> UniqSM (CorePrepEnv, Floats)
243 cpeBind top_lvl env (NonRec bndr rhs)
244 = do { (_, bndr1) <- cloneBndr env bndr
245 ; let is_strict = isStrictDmd (idNewDemandInfo bndr)
246 is_unlifted = isUnLiftedType (idType bndr)
247 ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
248 (is_strict || is_unlifted)
250 ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2
252 -- We want bndr'' in the envt, because it records
253 -- the evaluated-ness of the binder
254 ; return (extendCorePrepEnv env bndr bndr2,
255 addFloat floats new_float) }
257 cpeBind top_lvl env (Rec pairs)
258 = do { let (bndrs,rhss) = unzip pairs
259 ; (env', bndrs1) <- cloneBndrs env (map fst pairs)
260 ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
262 ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
263 all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
264 (concatFloats floats_s)
265 ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
266 unitFloat (FloatLet (Rec all_pairs))) }
268 -- Flatten all the floats, and the currrent
269 -- group into a single giant Rec
270 add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
271 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
272 add_float b _ = pprPanic "cpeBind" (ppr b)
275 cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
276 -> CorePrepEnv -> Id -> CoreExpr
277 -> UniqSM (Floats, Id, CoreExpr)
278 -- Used for all bindings
279 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
280 = do { (floats, rhs') <- cpeRhs want_float (idArity bndr) env rhs
282 -- Record if the binder is evaluated
283 ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
286 ; return (floats, bndr', rhs') }
288 want_float floats rhs
289 | isTopLevel top_lvl = wantFloatTop bndr floats
290 | otherwise = wantFloatNested is_rec is_strict_or_unlifted floats rhs
294 -- ---------------------------------------------------------------------------
295 -- CpeRhs: produces a result satisfying CpeRhs
296 -- ---------------------------------------------------------------------------
298 cpeRhs :: (Floats -> CpeRhs -> Bool) -- Float the floats out
299 -> Arity -- Guarantees an Rhs with this manifest arity
301 -> CoreExpr -- Expression and its type
302 -> UniqSM (Floats, CpeRhs)
303 cpeRhs want_float arity env expr
304 = do { (floats, rhs) <- cpeRhsE env expr
305 ; if want_float floats rhs
306 then return (floats, cpeEtaExpand arity rhs)
307 else return (emptyFloats, cpeEtaExpand arity (wrapBinds floats rhs)) }
309 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
313 -- e = let bs in e' (semantically, that is!)
316 -- f (g x) ===> ([v = g x], f v)
318 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
319 cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
320 cpeRhsE env expr@(App {}) = cpeApp env expr
321 cpeRhsE env expr@(Var {}) = cpeApp env expr
323 cpeRhsE env (Let bind expr)
324 = do { (env', new_binds) <- cpeBind NotTopLevel env bind
325 ; (floats, body) <- cpeRhsE env' expr
326 ; return (new_binds `appendFloats` floats, body) }
328 cpeRhsE env (Note note expr)
331 | otherwise -- Just SCCs actually
332 = do { body <- cpeBodyNF env expr
333 ; return (emptyFloats, Note note body) }
335 cpeRhsE env (Cast expr co)
336 = do { (floats, expr') <- cpeRhsE env expr
337 ; return (floats, Cast expr' co) }
339 cpeRhsE env expr@(Lam {})
340 = do { let (bndrs,body) = collectBinders expr
341 ; (env', bndrs') <- cloneBndrs env bndrs
342 ; body' <- cpeBodyNF env' body
343 ; return (emptyFloats, mkLams bndrs' body') }
345 cpeRhsE env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
346 | Just (TickBox {}) <- isTickBoxOp_maybe id
347 = do { body <- cpeBodyNF env expr
348 ; return (emptyFloats, Case (Var id) bndr ty [(DEFAULT,[],body)]) }
350 cpeRhsE env (Case scrut bndr ty alts)
351 = do { (floats, scrut') <- cpeBody env scrut
352 ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
353 -- Record that the case binder is evaluated in the alternatives
354 ; (env', bndr2) <- cloneBndr env bndr1
355 ; alts' <- mapM (sat_alt env') alts
356 ; return (floats, Case scrut' bndr2 ty alts') }
358 sat_alt env (con, bs, rhs)
359 = do { (env2, bs') <- cloneBndrs env bs
360 ; rhs' <- cpeBodyNF env2 rhs
361 ; return (con, bs', rhs') }
363 -- ---------------------------------------------------------------------------
364 -- CpeBody: produces a result satisfying CpeBody
365 -- ---------------------------------------------------------------------------
367 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
369 = do { (floats, body) <- cpeBody env expr
370 ; return (wrapBinds floats body) }
373 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
375 = do { (floats1, rhs) <- cpeRhsE env expr
376 ; (floats2, body) <- rhsToBody rhs
377 ; return (floats1 `appendFloats` floats2, body) }
380 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
381 -- Remove top level lambdas by let-bindinig
383 rhsToBody (Note n expr)
384 -- You can get things like
385 -- case e of { p -> coerce t (\s -> ...) }
386 = do { (floats, expr') <- rhsToBody expr
387 ; return (floats, Note n expr') }
389 rhsToBody (Cast e co)
390 = do { (floats, e') <- rhsToBody e
391 ; return (floats, Cast e' co) }
393 rhsToBody expr@(Lam {})
394 | Just no_lam_result <- tryEtaReduce bndrs body
395 = return (emptyFloats, no_lam_result)
396 | all isTyVar bndrs -- Type lambdas are ok
397 = return (emptyFloats, expr)
398 | otherwise -- Some value lambdas
399 = do { fn <- newVar (exprType expr)
400 ; let rhs = cpeEtaExpand (exprArity expr) expr
401 float = FloatLet (NonRec fn rhs)
402 ; return (unitFloat float, Var fn) }
404 (bndrs,body) = collectBinders expr
406 rhsToBody expr = return (emptyFloats, expr)
410 -- ---------------------------------------------------------------------------
411 -- CpeApp: produces a result satisfying CpeApp
412 -- ---------------------------------------------------------------------------
414 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
415 -- May return a CpeRhs because of saturating primops
417 = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
418 ; MASSERT(null ss) -- make sure we used all the strictness info
420 -- Now deal with the function
422 Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
423 ; return (floats, sat_app) }
424 _other -> return (floats, app) }
427 -- Deconstruct and rebuild the application, floating any non-atomic
428 -- arguments to the outside. We collect the type of the expression,
429 -- the head of the application, and the number of actual value arguments,
430 -- all of which are used to possibly saturate this application if it
431 -- has a constructor or primop at the head.
435 -> Int -- Current app depth
436 -> UniqSM (CpeApp, -- The rebuilt expression
437 (CoreExpr,Int), -- The head of the application,
438 -- and no. of args it was applied to
439 Type, -- Type of the whole expr
440 Floats, -- Any floats we pulled out
441 [Demand]) -- Remaining argument demands
443 collect_args (App fun arg@(Type arg_ty)) depth
444 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
445 ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
447 collect_args (App fun arg) depth
448 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
450 (ss1, ss_rest) = case ss of
451 (ss1:ss_rest) -> (ss1, ss_rest)
453 (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
454 splitFunTy_maybe fun_ty
456 ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty
457 ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
459 collect_args (Var v) depth
460 = do { v1 <- fiddleCCall v
461 ; let v2 = lookupCorePrepEnv env v1
462 ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
464 stricts = case idNewStrictness v of
465 StrictSig (DmdType _ demands _)
466 | listLengthCmp demands depth /= GT -> demands
467 -- length demands <= depth
469 -- If depth < length demands, then we have too few args to
470 -- satisfy strictness info so we have to ignore all the
471 -- strictness info, e.g. + (error "urk")
472 -- Here, we can't evaluate the arg strictly, because this
473 -- partial application might be seq'd
475 collect_args (Cast fun co) depth
476 = do { let (_ty1,ty2) = coercionKind co
477 ; (fun', hd, _, floats, ss) <- collect_args fun depth
478 ; return (Cast fun' co, hd, ty2, floats, ss) }
480 collect_args (Note note fun) depth
481 | ignoreNote note -- Drop these notes altogether
482 = collect_args fun depth -- They aren't used by the code generator
484 -- N-variable fun, better let-bind it
485 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
486 -- since it is sure to be evaluated.
487 collect_args fun depth
488 = do { (fun_floats, fun') <- cpeArg env True fun ty
489 ; return (fun', (fun', depth), ty, fun_floats, []) }
493 -- ---------------------------------------------------------------------------
494 -- CpeArg: produces a result satisfying CpeArg
495 -- ---------------------------------------------------------------------------
497 -- This is where we arrange that a non-trivial argument is let-bound
498 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
499 -> UniqSM (Floats, CpeTriv)
500 cpeArg env is_strict arg arg_ty
501 | cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument
502 = cpeBody env arg -- Must still do substitution though
504 = do { (floats, arg') <- cpeRhs want_float
505 (exprArity arg) env arg
507 ; let arg_float = mkFloat is_strict is_unlifted v arg'
508 ; return (addFloat floats arg_float, Var v) }
510 is_unlifted = isUnLiftedType arg_ty
511 want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
514 Note [Floating unlifted arguments]
515 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
516 Consider C (let v* = expensive in v)
518 where the "*" indicates "will be demanded". Usually v will have been
519 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
522 let v* = expensive in C v
524 because that has different strictness. Hence the use of 'allLazy'.
525 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
528 ------------------------------------------------------------------------------
529 -- Building the saturated syntax
530 -- ---------------------------------------------------------------------------
532 maybeSaturate deals with saturating primops and constructors
533 The type is the type of the entire application
536 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
537 maybeSaturate fn expr n_args
538 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
539 -- A gruesome special case
540 = saturateDataToTag sat_expr
542 | hasNoBinding fn -- There's no binding
548 fn_arity = idArity fn
549 excess_arity = fn_arity - n_args
550 sat_expr = cpeEtaExpand excess_arity expr
553 saturateDataToTag :: CpeApp -> UniqSM CpeApp
554 -- Horrid: ensure that the arg of data2TagOp is evaluated
555 -- (data2tag x) --> (case x of y -> data2tag y)
556 -- (yuk yuk) take into account the lambdas we've now introduced
557 saturateDataToTag sat_expr
558 = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
559 ; eta_body' <- eval_data2tag_arg eta_body
560 ; return (mkLams eta_bndrs eta_body') }
562 eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
563 eval_data2tag_arg app@(fun `App` arg)
564 | exprIsHNF arg -- Includes nullary constructors
565 = return app -- The arg is evaluated
566 | otherwise -- Arg not evaluated, so evaluate it
567 = do { arg_id <- newVar (exprType arg)
568 ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
569 ; return (Case arg arg_id1 (exprType app)
570 [(DEFAULT, [], fun `App` Var arg_id1)]) }
572 eval_data2tag_arg (Note note app) -- Scc notes can appear
573 = do { app' <- eval_data2tag_arg app
574 ; return (Note note app') }
576 eval_data2tag_arg other -- Should not happen
577 = pprPanic "eval_data2tag" (ppr other)
583 %************************************************************************
585 Simple CoreSyn operations
587 %************************************************************************
590 -- We don't ignore SCCs, since they require some code generation
591 ignoreNote :: Note -> Bool
592 -- Tells which notes to drop altogether; they are ignored by code generation
593 -- Do not ignore SCCs!
594 -- It's important that we do drop InlineMe notes; for example
595 -- unzip = __inline_me__ (/\ab. foldr (..) (..))
596 -- Here unzip gets arity 1 so we'll eta-expand it. But we don't
598 -- unzip = /\ab \xs. (__inline_me__ ...) a b xs
599 ignoreNote (CoreNote _) = True
600 ignoreNote InlineMe = True
601 ignoreNote _other = False
604 cpe_ExprIsTrivial :: CoreExpr -> Bool
605 -- Version that doesn't consider an scc annotation to be trivial.
606 cpe_ExprIsTrivial (Var _) = True
607 cpe_ExprIsTrivial (Type _) = True
608 cpe_ExprIsTrivial (Lit _) = True
609 cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
610 cpe_ExprIsTrivial (Note (SCC _) _) = False
611 cpe_ExprIsTrivial (Note _ e) = cpe_ExprIsTrivial e
612 cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
613 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
614 cpe_ExprIsTrivial _ = False
617 -- -----------------------------------------------------------------------------
619 -- -----------------------------------------------------------------------------
622 ~~~~~~~~~~~~~~~~~~~~~
623 Eta expand to match the arity claimed by the binder Remember,
624 CorePrep must not change arity
626 Eta expansion might not have happened already, because it is done by
627 the simplifier only when there at least one lambda already.
629 NB1:we could refrain when the RHS is trivial (which can happen
630 for exported things). This would reduce the amount of code
631 generated (a little) and make things a little words for
632 code compiled without -O. The case in point is data constructor
635 NB2: we have to be careful that the result of etaExpand doesn't
636 invalidate any of the assumptions that CorePrep is attempting
637 to establish. One possible cause is eta expanding inside of
638 an SCC note - we're now careful in etaExpand to make sure the
639 SCC is pushed inside any new lambdas that are generated.
641 Note [Eta expansion and the CorePrep invariants]
642 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
643 It turns out to be much much easier to do eta expansion
644 *after* the main CorePrep stuff. But that places constraints
645 on the eta expander: given a CpeRhs, it must return a CpeRhs.
647 For example here is what we do not want:
648 f = /\a -> g (h 3) -- h has arity 2
650 f = /\a -> let s = h 3 in g s
651 and now we do NOT want eta expansion to give
652 f = /\a -> \ y -> (let s = h 3 in g s) y
654 Instead CoreArity.etaExpand gives
655 f = /\a -> \y -> let s = h 3 in g s y
658 cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr
659 cpeEtaExpand arity expr
661 | otherwise = etaExpand arity expr
664 -- -----------------------------------------------------------------------------
666 -- -----------------------------------------------------------------------------
668 Why try eta reduction? Hasn't the simplifier already done eta?
669 But the simplifier only eta reduces if that leaves something
670 trivial (like f, or f Int). But for deLam it would be enough to
671 get to a partial application:
672 case x of { p -> \xs. map f xs }
673 ==> case x of { p -> map f }
676 tryEtaReduce :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
677 tryEtaReduce bndrs expr@(App _ _)
678 | ok_to_eta_reduce f &&
680 and (zipWith ok bndrs last_args) &&
681 not (any (`elemVarSet` fvs_remaining) bndrs)
682 = Just remaining_expr
684 (f, args) = collectArgs expr
685 remaining_expr = mkApps f remaining_args
686 fvs_remaining = exprFreeVars remaining_expr
687 (remaining_args, last_args) = splitAt n_remaining args
688 n_remaining = length args - length bndrs
690 ok bndr (Var arg) = bndr == arg
693 -- we can't eta reduce something which must be saturated.
694 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
695 ok_to_eta_reduce _ = False --safe. ToDo: generalise
697 tryEtaReduce bndrs (Let bind@(NonRec _ r) body)
698 | not (any (`elemVarSet` fvs) bndrs)
699 = case tryEtaReduce bndrs body of
700 Just e -> Just (Let bind e)
705 tryEtaReduce _ _ = Nothing
709 -- -----------------------------------------------------------------------------
711 -- -----------------------------------------------------------------------------
714 type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recursive
717 %************************************************************************
721 %************************************************************************
725 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
726 | FloatCase Id CpeBody Bool -- The bool indicates "ok-for-speculation"
728 data Floats = Floats OkToSpec (OrdList FloatingBind)
730 -- Can we float these binds out of the rhs of a let? We cache this decision
731 -- to avoid having to recompute it in a non-linear way when there are
732 -- deeply nested lets.
734 = NotOkToSpec -- definitely not
736 | IfUnboxedOk -- only if floating an unboxed binding is ok
738 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
739 mkFloat is_strict is_unlifted bndr rhs
740 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
741 | otherwise = FloatLet (NonRec bndr rhs)
743 use_case = is_unlifted || is_strict && not (exprIsHNF rhs)
744 -- Don't make a case for a value binding,
745 -- even if it's strict. Otherwise we get
746 -- case (\x -> e) of ...!
748 emptyFloats :: Floats
749 emptyFloats = Floats OkToSpec nilOL
751 wrapBinds :: Floats -> CoreExpr -> CoreExpr
752 wrapBinds (Floats _ binds) body
753 = foldrOL mk_bind body binds
755 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
756 mk_bind (FloatLet bind) body = Let bind body
758 addFloat :: Floats -> FloatingBind -> Floats
759 addFloat (Floats ok_to_spec floats) new_float
760 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
762 check (FloatLet _) = OkToSpec
763 check (FloatCase _ _ ok_for_spec)
764 | ok_for_spec = IfUnboxedOk
765 | otherwise = NotOkToSpec
766 -- The ok-for-speculation flag says that it's safe to
767 -- float this Case out of a let, and thereby do it more eagerly
768 -- We need the top-level flag because it's never ok to float
769 -- an unboxed binding to the top level
771 unitFloat :: FloatingBind -> Floats
772 unitFloat = addFloat emptyFloats
774 appendFloats :: Floats -> Floats -> Floats
775 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
776 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
778 concatFloats :: [Floats] -> OrdList FloatingBind
779 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
781 combine :: OkToSpec -> OkToSpec -> OkToSpec
782 combine NotOkToSpec _ = NotOkToSpec
783 combine _ NotOkToSpec = NotOkToSpec
784 combine IfUnboxedOk _ = IfUnboxedOk
785 combine _ IfUnboxedOk = IfUnboxedOk
786 combine _ _ = OkToSpec
788 instance Outputable FloatingBind where
789 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
790 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
792 deFloatTop :: Floats -> [CoreBind]
793 -- For top level only; we don't expect any FloatCases
794 deFloatTop (Floats _ floats)
795 = foldrOL get [] floats
797 get (FloatLet b) bs = b:bs
798 get b _ = pprPanic "corePrepPgm" (ppr b)
800 -------------------------------------------
801 wantFloatTop :: Id -> Floats -> Bool
802 -- Note [CafInfo and floating]
803 wantFloatTop bndr floats = mayHaveCafRefs (idCafInfo bndr)
806 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
807 wantFloatNested is_rec strict_or_unlifted floats rhs
809 || (allLazyNested is_rec floats && exprIsHNF rhs)
810 -- Why the test for allLazyNested?
811 -- v = f (x `divInt#` y)
812 -- we don't want to float the case, even if f has arity 2,
813 -- because floating the case would make it evaluated too early
815 allLazyTop :: Floats -> Bool
816 allLazyTop (Floats OkToSpec _) = True
819 allLazyNested :: RecFlag -> Floats -> Bool
820 allLazyNested _ (Floats OkToSpec _) = True
821 allLazyNested _ (Floats NotOkToSpec _) = False
822 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
826 %************************************************************************
830 %************************************************************************
833 -- ---------------------------------------------------------------------------
835 -- ---------------------------------------------------------------------------
837 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
839 emptyCorePrepEnv :: CorePrepEnv
840 emptyCorePrepEnv = CPE emptyVarEnv
842 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
843 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
845 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
846 extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs)
848 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
849 lookupCorePrepEnv (CPE env) id
850 = case lookupVarEnv env id of
854 ------------------------------------------------------------------------------
856 -- ---------------------------------------------------------------------------
858 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
859 cloneBndrs env bs = mapAccumLM cloneBndr env bs
861 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
864 = do bndr' <- setVarUnique bndr <$> getUniqueM
865 return (extendCorePrepEnv env bndr bndr', bndr')
867 | otherwise -- Top level things, which we don't want
868 -- to clone, have become GlobalIds by now
869 -- And we don't clone tyvars
873 ------------------------------------------------------------------------------
874 -- Cloning ccall Ids; each must have a unique name,
875 -- to give the code generator a handle to hang it on
876 -- ---------------------------------------------------------------------------
878 fiddleCCall :: Id -> UniqSM Id
880 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
881 | otherwise = return id
883 ------------------------------------------------------------------------------
884 -- Generating new binders
885 -- ---------------------------------------------------------------------------
887 newVar :: Type -> UniqSM Id
889 = seqType ty `seq` do
891 return (mkSysLocal (fsLit "sat") uniq ty)