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 PrelNames ( lazyIdKey, hasKey )
18 import CoreMonad ( endPass, CoreToDo(..) )
42 import Data.List ( mapAccumL )
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 *value* lambdas only occur as the RHS of a binding
70 (The code generator can't deal with anything else.)
71 Type lambdas are ok, however, because the code gen discards them.
73 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
75 6. Clone all local Ids.
76 This means that all such Ids are unique, rather than the
77 weaker guarantee of no clashes which the simplifier provides.
78 And that is what the code generator needs.
80 We don't clone TyVars. The code gen doesn't need that,
81 and doing so would be tiresome because then we'd need
82 to substitute in types.
85 7. Give each dynamic CCall occurrence a fresh unique; this is
86 rather like the cloning step above.
88 8. Inject bindings for the "implicit" Ids:
89 * Constructor wrappers
91 We want curried definitions for all of these in case they
92 aren't inlined by some caller.
94 9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs
96 This is all done modulo type applications and abstractions, so that
97 when type erasure is done for conversion to STG, we don't end up with
98 any trivial or useless bindings.
103 Here is the syntax of the Core produced by CorePrep:
106 triv ::= lit | var | triv ty | /\a. triv | triv |> co
109 app ::= lit | var | app triv | app ty | app |> co
113 | let(rec) x = rhs in body -- Boxed only
114 | case body of pat -> body
118 Right hand sides (only place where lambdas can occur)
119 rhs ::= /\a.rhs | \x.rhs | body
121 We define a synonym for each of these non-terminals. Functions
122 with the corresponding name produce a result in that syntax.
125 type CpeTriv = CoreExpr -- Non-terminal 'triv'
126 type CpeApp = CoreExpr -- Non-terminal 'app'
127 type CpeBody = CoreExpr -- Non-terminal 'body'
128 type CpeRhs = CoreExpr -- Non-terminal 'rhs'
131 %************************************************************************
135 %************************************************************************
138 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
139 corePrepPgm dflags binds data_tycons = do
140 showPass dflags "CorePrep"
141 us <- mkSplitUniqSupply 's'
143 let implicit_binds = mkDataConWorkers data_tycons
144 -- NB: we must feed mkImplicitBinds through corePrep too
145 -- so that they are suitably cloned and eta-expanded
147 binds_out = initUs_ us $ do
148 floats1 <- corePrepTopBinds binds
149 floats2 <- corePrepTopBinds implicit_binds
150 return (deFloatTop (floats1 `appendFloats` floats2))
152 endPass dflags CorePrep binds_out []
155 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
156 corePrepExpr dflags expr = do
157 showPass dflags "CorePrep"
158 us <- mkSplitUniqSupply 's'
159 let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr)
160 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
163 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
164 -- Note [Floating out of top level bindings]
165 corePrepTopBinds binds
166 = go emptyCorePrepEnv binds
168 go _ [] = return emptyFloats
169 go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
170 binds' <- go env' binds
171 return (bind' `appendFloats` binds')
173 mkDataConWorkers :: [TyCon] -> [CoreBind]
174 -- See Note [Data constructor workers]
175 mkDataConWorkers data_tycons
176 = [ NonRec id (Var id) -- The ice is thin here, but it works
177 | tycon <- data_tycons, -- CorePrep will eta-expand it
178 data_con <- tyConDataCons tycon,
179 let id = dataConWorkId data_con ]
182 Note [Floating out of top level bindings]
183 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
184 NB: we do need to float out of top-level bindings
185 Consider x = length [True,False]
191 We return a *list* of bindings, because we may start with
193 where x is demanded, in which case we want to finish with
196 And then x will actually end up case-bound
198 Note [CafInfo and floating]
199 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
200 What happens when we try to float bindings to the top level? At this
201 point all the CafInfo is supposed to be correct, and we must make certain
202 that is true of the new top-level bindings. There are two cases
205 a) The top-level binding is marked asCafRefs. In that case we are
206 basically fine. The floated bindings had better all be lazy lets,
207 so they can float to top level, but they'll all have HasCafRefs
208 (the default) which is safe.
210 b) The top-level binding is marked NoCafRefs. This really happens
211 Example. CoreTidy produces
212 $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...
213 Now CorePrep has to eta-expand to
214 $fApplicativeSTM = let sat = \xy. retry x y
215 in D:Alternative sat ...blah...
217 sat [NoCafRefs] = \xy. retry x y
218 $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...
220 So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
221 *and* substutite the modified 'sat' into the old RHS.
223 It should be the case that 'sat' is itself [NoCafRefs] (a value, no
224 cafs) else the original top-level binding would not itself have been
225 marked [NoCafRefs]. The DEBUG check in CoreToStg for
226 consistentCafInfo will find this.
228 This is all very gruesome and horrible. It would be better to figure
229 out CafInfo later, after CorePrep. We'll do that in due course.
230 Meanwhile this horrible hack works.
233 Note [Data constructor workers]
234 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
235 Create any necessary "implicit" bindings for data con workers. We
236 create the rather strange (non-recursive!) binding
238 $wC = \x y -> $wC x y
240 i.e. a curried constructor that allocates. This means that we can
241 treat the worker for a constructor like any other function in the rest
242 of the compiler. The point here is that CoreToStg will generate a
243 StgConApp for the RHS, rather than a call to the worker (which would
244 give a loop). As Lennart says: the ice is thin here, but it works.
246 Hmm. Should we create bindings for dictionary constructors? They are
247 always fully applied, and the bindings are just there to support
248 partial applications. But it's easier to let them through.
251 %************************************************************************
255 %************************************************************************
258 cpeBind :: TopLevelFlag
259 -> CorePrepEnv -> CoreBind
260 -> UniqSM (CorePrepEnv, Floats)
261 cpeBind top_lvl env (NonRec bndr rhs)
262 = do { (_, bndr1) <- cloneBndr env bndr
263 ; let is_strict = isStrictDmd (idDemandInfo bndr)
264 is_unlifted = isUnLiftedType (idType bndr)
265 ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
266 (is_strict || is_unlifted)
268 ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2
270 -- We want bndr'' in the envt, because it records
271 -- the evaluated-ness of the binder
272 ; return (extendCorePrepEnv env bndr bndr2,
273 addFloat floats new_float) }
275 cpeBind top_lvl env (Rec pairs)
276 = do { let (bndrs,rhss) = unzip pairs
277 ; (env', bndrs1) <- cloneBndrs env (map fst pairs)
278 ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
280 ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
281 all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
282 (concatFloats floats_s)
283 ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
284 unitFloat (FloatLet (Rec all_pairs))) }
286 -- Flatten all the floats, and the currrent
287 -- group into a single giant Rec
288 add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
289 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
290 add_float b _ = pprPanic "cpeBind" (ppr b)
293 cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
294 -> CorePrepEnv -> Id -> CoreExpr
295 -> UniqSM (Floats, Id, CpeRhs)
296 -- Used for all bindings
297 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
298 = do { (floats1, rhs1) <- cpeRhsE env rhs
300 -- See if we are allowed to float this stuff out of the RHS
301 ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
303 -- Make the arity match up
305 <- if manifestArity rhs1 <= arity
306 then return (floats2, cpeEtaExpand arity rhs2)
307 else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
308 -- Note [Silly extra arguments]
309 (do { v <- newVar (idType bndr)
310 ; let float = mkFloat False False v rhs2
311 ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
313 -- Record if the binder is evaluated
314 -- and otherwise trim off the unfolding altogether
315 -- It's not used by the code generator; getting rid of it reduces
316 -- heap usage and, since we may be changing uniques, we'd have
317 -- to substitute to keep it right
318 ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
319 | otherwise = bndr `setIdUnfolding` noUnfolding
321 ; return (floats3, bndr', rhs') }
323 arity = idArity bndr -- We must match this arity
325 ---------------------
326 float_from_rhs floats rhs
327 | isEmptyFloats floats = return (emptyFloats, rhs)
328 | isTopLevel top_lvl = float_top floats rhs
329 | otherwise = float_nested floats rhs
331 ---------------------
332 float_nested floats rhs
333 | wantFloatNested is_rec is_strict_or_unlifted floats rhs
334 = return (floats, rhs)
335 | otherwise = dont_float floats rhs
337 ---------------------
338 float_top floats rhs -- Urhgh! See Note [CafInfo and floating]
339 | mayHaveCafRefs (idCafInfo bndr)
341 = return (floats, rhs)
343 -- So the top-level binding is marked NoCafRefs
344 | Just (floats', rhs') <- canFloatFromNoCaf floats rhs
345 = return (floats', rhs')
348 = dont_float floats rhs
350 ---------------------
351 dont_float floats rhs
352 -- Non-empty floats, but do not want to float from rhs
353 -- So wrap the rhs in the floats
354 -- But: rhs1 might have lambdas, and we can't
355 -- put them inside a wrapBinds
356 = do { body <- rhsToBodyNF rhs
357 ; return (emptyFloats, wrapBinds floats body) }
359 {- Note [Silly extra arguments]
360 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
363 We *must* match the arity on the Id, so we have to generate
367 It's a bizarre case: why is the arity on the Id wrong? Reason
368 (in the days of __inline_me__):
369 f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
370 When InlineMe notes go away this won't happen any more. But
371 it seems good for CorePrep to be robust.
374 -- ---------------------------------------------------------------------------
375 -- CpeRhs: produces a result satisfying CpeRhs
376 -- ---------------------------------------------------------------------------
378 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
382 -- e = let bs in e' (semantically, that is!)
385 -- f (g x) ===> ([v = g x], f v)
387 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
388 cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
389 cpeRhsE env expr@(Var {}) = cpeApp env expr
391 cpeRhsE env (Var f `App` _ `App` arg)
392 | f `hasKey` lazyIdKey -- Replace (lazy a) by a
393 = cpeRhsE env arg -- See Note [lazyId magic] in MkId
395 cpeRhsE env expr@(App {}) = cpeApp env expr
397 cpeRhsE env (Let bind expr)
398 = do { (env', new_binds) <- cpeBind NotTopLevel env bind
399 ; (floats, body) <- cpeRhsE env' expr
400 ; return (new_binds `appendFloats` floats, body) }
402 cpeRhsE env (Note note expr)
405 | otherwise -- Just SCCs actually
406 = do { body <- cpeBodyNF env expr
407 ; return (emptyFloats, Note note body) }
409 cpeRhsE env (Cast expr co)
410 = do { (floats, expr') <- cpeRhsE env expr
411 ; return (floats, Cast expr' co) }
413 cpeRhsE env expr@(Lam {})
414 = do { let (bndrs,body) = collectBinders expr
415 ; (env', bndrs') <- cloneBndrs env bndrs
416 ; body' <- cpeBodyNF env' body
417 ; return (emptyFloats, mkLams bndrs' body') }
419 cpeRhsE env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
420 | Just (TickBox {}) <- isTickBoxOp_maybe id
421 = do { body <- cpeBodyNF env expr
422 ; return (emptyFloats, Case (Var id) bndr ty [(DEFAULT,[],body)]) }
424 cpeRhsE env (Case scrut bndr ty alts)
425 = do { (floats, scrut') <- cpeBody env scrut
426 ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
427 -- Record that the case binder is evaluated in the alternatives
428 ; (env', bndr2) <- cloneBndr env bndr1
429 ; alts' <- mapM (sat_alt env') alts
430 ; return (floats, Case scrut' bndr2 ty alts') }
432 sat_alt env (con, bs, rhs)
433 = do { (env2, bs') <- cloneBndrs env bs
434 ; rhs' <- cpeBodyNF env2 rhs
435 ; return (con, bs', rhs') }
437 -- ---------------------------------------------------------------------------
438 -- CpeBody: produces a result satisfying CpeBody
439 -- ---------------------------------------------------------------------------
441 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
443 = do { (floats, body) <- cpeBody env expr
444 ; return (wrapBinds floats body) }
447 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
449 = do { (floats1, rhs) <- cpeRhsE env expr
450 ; (floats2, body) <- rhsToBody rhs
451 ; return (floats1 `appendFloats` floats2, body) }
454 rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
455 rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
456 ; return (wrapBinds floats body) }
459 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
460 -- Remove top level lambdas by let-binding
462 rhsToBody (Note n expr)
463 -- You can get things like
464 -- case e of { p -> coerce t (\s -> ...) }
465 = do { (floats, expr') <- rhsToBody expr
466 ; return (floats, Note n expr') }
468 rhsToBody (Cast e co)
469 = do { (floats, e') <- rhsToBody e
470 ; return (floats, Cast e' co) }
472 rhsToBody expr@(Lam {})
473 | Just no_lam_result <- tryEtaReducePrep bndrs body
474 = return (emptyFloats, no_lam_result)
475 | all isTyCoVar bndrs -- Type lambdas are ok
476 = return (emptyFloats, expr)
477 | otherwise -- Some value lambdas
478 = do { fn <- newVar (exprType expr)
479 ; let rhs = cpeEtaExpand (exprArity expr) expr
480 float = FloatLet (NonRec fn rhs)
481 ; return (unitFloat float, Var fn) }
483 (bndrs,body) = collectBinders expr
485 rhsToBody expr = return (emptyFloats, expr)
489 -- ---------------------------------------------------------------------------
490 -- CpeApp: produces a result satisfying CpeApp
491 -- ---------------------------------------------------------------------------
493 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
494 -- May return a CpeRhs because of saturating primops
496 = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
497 ; MASSERT(null ss) -- make sure we used all the strictness info
499 -- Now deal with the function
501 Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
502 ; return (floats, sat_app) }
503 _other -> return (floats, app) }
506 -- Deconstruct and rebuild the application, floating any non-atomic
507 -- arguments to the outside. We collect the type of the expression,
508 -- the head of the application, and the number of actual value arguments,
509 -- all of which are used to possibly saturate this application if it
510 -- has a constructor or primop at the head.
514 -> Int -- Current app depth
515 -> UniqSM (CpeApp, -- The rebuilt expression
516 (CoreExpr,Int), -- The head of the application,
517 -- and no. of args it was applied to
518 Type, -- Type of the whole expr
519 Floats, -- Any floats we pulled out
520 [Demand]) -- Remaining argument demands
522 collect_args (App fun arg@(Type arg_ty)) depth
523 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
524 ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
526 collect_args (App fun arg) depth
527 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
529 (ss1, ss_rest) = case ss of
530 (ss1:ss_rest) -> (ss1, ss_rest)
532 (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
533 splitFunTy_maybe fun_ty
535 ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty
536 ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
538 collect_args (Var v) depth
539 = do { v1 <- fiddleCCall v
540 ; let v2 = lookupCorePrepEnv env v1
541 ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
543 stricts = case idStrictness v of
544 StrictSig (DmdType _ demands _)
545 | listLengthCmp demands depth /= GT -> demands
546 -- length demands <= depth
548 -- If depth < length demands, then we have too few args to
549 -- satisfy strictness info so we have to ignore all the
550 -- strictness info, e.g. + (error "urk")
551 -- Here, we can't evaluate the arg strictly, because this
552 -- partial application might be seq'd
554 collect_args (Cast fun co) depth
555 = do { let (_ty1,ty2) = coercionKind co
556 ; (fun', hd, _, floats, ss) <- collect_args fun depth
557 ; return (Cast fun' co, hd, ty2, floats, ss) }
559 collect_args (Note note fun) depth
560 | ignoreNote note -- Drop these notes altogether
561 = collect_args fun depth -- They aren't used by the code generator
563 -- N-variable fun, better let-bind it
564 collect_args fun depth
565 = do { (fun_floats, fun') <- cpeArg env True fun ty
566 -- The True says that it's sure to be evaluated,
567 -- so we'll end up case-binding it
568 ; return (fun', (fun', depth), ty, fun_floats, []) }
572 -- ---------------------------------------------------------------------------
573 -- CpeArg: produces a result satisfying CpeArg
574 -- ---------------------------------------------------------------------------
576 -- This is where we arrange that a non-trivial argument is let-bound
577 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
578 -> UniqSM (Floats, CpeTriv)
579 cpeArg env is_strict arg arg_ty
580 = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
581 ; (floats2, arg2) <- if want_float floats1 arg1
582 then return (floats1, arg1)
583 else do { body1 <- rhsToBodyNF arg1
584 ; return (emptyFloats, wrapBinds floats1 body1) }
585 -- Else case: arg1 might have lambdas, and we can't
586 -- put them inside a wrapBinds
588 ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument
589 then return (floats2, arg2)
592 ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
593 arg_float = mkFloat is_strict is_unlifted v arg3
594 ; return (addFloat floats2 arg_float, Var v) } }
596 is_unlifted = isUnLiftedType arg_ty
597 want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
600 Note [Floating unlifted arguments]
601 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
602 Consider C (let v* = expensive in v)
604 where the "*" indicates "will be demanded". Usually v will have been
605 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
608 let v* = expensive in C v
610 because that has different strictness. Hence the use of 'allLazy'.
611 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
614 ------------------------------------------------------------------------------
615 -- Building the saturated syntax
616 -- ---------------------------------------------------------------------------
618 maybeSaturate deals with saturating primops and constructors
619 The type is the type of the entire application
622 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
623 maybeSaturate fn expr n_args
624 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
625 -- A gruesome special case
626 = saturateDataToTag sat_expr
628 | hasNoBinding fn -- There's no binding
634 fn_arity = idArity fn
635 excess_arity = fn_arity - n_args
636 sat_expr = cpeEtaExpand excess_arity expr
639 saturateDataToTag :: CpeApp -> UniqSM CpeApp
640 -- See Note [dataToTag magic]
641 saturateDataToTag sat_expr
642 = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
643 ; eta_body' <- eval_data2tag_arg eta_body
644 ; return (mkLams eta_bndrs eta_body') }
646 eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
647 eval_data2tag_arg app@(fun `App` arg)
648 | exprIsHNF arg -- Includes nullary constructors
649 = return app -- The arg is evaluated
650 | otherwise -- Arg not evaluated, so evaluate it
651 = do { arg_id <- newVar (exprType arg)
652 ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
653 ; return (Case arg arg_id1 (exprType app)
654 [(DEFAULT, [], fun `App` Var arg_id1)]) }
656 eval_data2tag_arg (Note note app) -- Scc notes can appear
657 = do { app' <- eval_data2tag_arg app
658 ; return (Note note app') }
660 eval_data2tag_arg other -- Should not happen
661 = pprPanic "eval_data2tag" (ppr other)
664 Note [dataToTag magic]
665 ~~~~~~~~~~~~~~~~~~~~~~
666 Horrid: we must ensure that the arg of data2TagOp is evaluated
667 (data2tag x) --> (case x of y -> data2tag y)
668 (yuk yuk) take into account the lambdas we've now introduced
670 How might it not be evaluated? Well, we might have floated it out
671 of the scope of a `seq`, or dropped the `seq` altogether.
674 %************************************************************************
676 Simple CoreSyn operations
678 %************************************************************************
681 -- We don't ignore SCCs, since they require some code generation
682 ignoreNote :: Note -> Bool
683 -- Tells which notes to drop altogether; they are ignored by code generation
684 -- Do not ignore SCCs!
685 -- It's important that we do drop InlineMe notes; for example
686 -- unzip = __inline_me__ (/\ab. foldr (..) (..))
687 -- Here unzip gets arity 1 so we'll eta-expand it. But we don't
689 -- unzip = /\ab \xs. (__inline_me__ ...) a b xs
690 ignoreNote (CoreNote _) = True
691 ignoreNote _other = False
694 cpe_ExprIsTrivial :: CoreExpr -> Bool
695 -- Version that doesn't consider an scc annotation to be trivial.
696 cpe_ExprIsTrivial (Var _) = True
697 cpe_ExprIsTrivial (Type _) = True
698 cpe_ExprIsTrivial (Lit _) = True
699 cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
700 cpe_ExprIsTrivial (Note n e) = notSccNote n && cpe_ExprIsTrivial e
701 cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
702 cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
703 cpe_ExprIsTrivial _ = False
706 -- -----------------------------------------------------------------------------
708 -- -----------------------------------------------------------------------------
711 ~~~~~~~~~~~~~~~~~~~~~
712 Eta expand to match the arity claimed by the binder Remember,
713 CorePrep must not change arity
715 Eta expansion might not have happened already, because it is done by
716 the simplifier only when there at least one lambda already.
718 NB1:we could refrain when the RHS is trivial (which can happen
719 for exported things). This would reduce the amount of code
720 generated (a little) and make things a little words for
721 code compiled without -O. The case in point is data constructor
724 NB2: we have to be careful that the result of etaExpand doesn't
725 invalidate any of the assumptions that CorePrep is attempting
726 to establish. One possible cause is eta expanding inside of
727 an SCC note - we're now careful in etaExpand to make sure the
728 SCC is pushed inside any new lambdas that are generated.
730 Note [Eta expansion and the CorePrep invariants]
731 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
732 It turns out to be much much easier to do eta expansion
733 *after* the main CorePrep stuff. But that places constraints
734 on the eta expander: given a CpeRhs, it must return a CpeRhs.
736 For example here is what we do not want:
737 f = /\a -> g (h 3) -- h has arity 2
739 f = /\a -> let s = h 3 in g s
740 and now we do NOT want eta expansion to give
741 f = /\a -> \ y -> (let s = h 3 in g s) y
743 Instead CoreArity.etaExpand gives
744 f = /\a -> \y -> let s = h 3 in g s y
747 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
748 cpeEtaExpand arity expr
750 | otherwise = etaExpand arity expr
753 -- -----------------------------------------------------------------------------
755 -- -----------------------------------------------------------------------------
757 Why try eta reduction? Hasn't the simplifier already done eta?
758 But the simplifier only eta reduces if that leaves something
759 trivial (like f, or f Int). But for deLam it would be enough to
760 get to a partial application:
761 case x of { p -> \xs. map f xs }
762 ==> case x of { p -> map f }
765 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
766 tryEtaReducePrep bndrs expr@(App _ _)
767 | ok_to_eta_reduce f &&
769 and (zipWith ok bndrs last_args) &&
770 not (any (`elemVarSet` fvs_remaining) bndrs)
771 = Just remaining_expr
773 (f, args) = collectArgs expr
774 remaining_expr = mkApps f remaining_args
775 fvs_remaining = exprFreeVars remaining_expr
776 (remaining_args, last_args) = splitAt n_remaining args
777 n_remaining = length args - length bndrs
779 ok bndr (Var arg) = bndr == arg
782 -- we can't eta reduce something which must be saturated.
783 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
784 ok_to_eta_reduce _ = False --safe. ToDo: generalise
786 tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
787 | not (any (`elemVarSet` fvs) bndrs)
788 = case tryEtaReducePrep bndrs body of
789 Just e -> Just (Let bind e)
794 tryEtaReducePrep _ _ = Nothing
798 -- -----------------------------------------------------------------------------
800 -- -----------------------------------------------------------------------------
803 type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recursive
806 %************************************************************************
810 %************************************************************************
814 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
815 -- They are always of lifted type;
816 -- unlifted ones are done with FloatCase
820 Bool -- The bool indicates "ok-for-speculation"
822 data Floats = Floats OkToSpec (OrdList FloatingBind)
824 instance Outputable FloatingBind where
825 ppr (FloatLet b) = ppr b
826 ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
828 instance Outputable Floats where
829 ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+>
830 braces (vcat (map ppr (fromOL fs)))
832 instance Outputable OkToSpec where
833 ppr OkToSpec = ptext (sLit "OkToSpec")
834 ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk")
835 ppr NotOkToSpec = ptext (sLit "NotOkToSpec")
837 -- Can we float these binds out of the rhs of a let? We cache this decision
838 -- to avoid having to recompute it in a non-linear way when there are
839 -- deeply nested lets.
841 = OkToSpec -- Lazy bindings of lifted type
842 | IfUnboxedOk -- A mixture of lazy lifted bindings and n
843 -- ok-to-speculate unlifted bindings
844 | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
846 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
847 mkFloat is_strict is_unlifted bndr rhs
848 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
849 | otherwise = FloatLet (NonRec bndr rhs)
851 use_case = is_unlifted || is_strict && not (exprIsHNF rhs)
852 -- Don't make a case for a value binding,
853 -- even if it's strict. Otherwise we get
854 -- case (\x -> e) of ...!
856 emptyFloats :: Floats
857 emptyFloats = Floats OkToSpec nilOL
859 isEmptyFloats :: Floats -> Bool
860 isEmptyFloats (Floats _ bs) = isNilOL bs
862 wrapBinds :: Floats -> CpeBody -> CpeBody
863 wrapBinds (Floats _ binds) body
864 = foldrOL mk_bind body binds
866 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
867 mk_bind (FloatLet bind) body = Let bind body
869 addFloat :: Floats -> FloatingBind -> Floats
870 addFloat (Floats ok_to_spec floats) new_float
871 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
873 check (FloatLet _) = OkToSpec
874 check (FloatCase _ _ ok_for_spec)
875 | ok_for_spec = IfUnboxedOk
876 | otherwise = NotOkToSpec
877 -- The ok-for-speculation flag says that it's safe to
878 -- float this Case out of a let, and thereby do it more eagerly
879 -- We need the top-level flag because it's never ok to float
880 -- an unboxed binding to the top level
882 unitFloat :: FloatingBind -> Floats
883 unitFloat = addFloat emptyFloats
885 appendFloats :: Floats -> Floats -> Floats
886 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
887 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
889 concatFloats :: [Floats] -> OrdList FloatingBind
890 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
892 combine :: OkToSpec -> OkToSpec -> OkToSpec
893 combine NotOkToSpec _ = NotOkToSpec
894 combine _ NotOkToSpec = NotOkToSpec
895 combine IfUnboxedOk _ = IfUnboxedOk
896 combine _ IfUnboxedOk = IfUnboxedOk
897 combine _ _ = OkToSpec
899 deFloatTop :: Floats -> [CoreBind]
900 -- For top level only; we don't expect any FloatCases
901 deFloatTop (Floats _ floats)
902 = foldrOL get [] floats
904 get (FloatLet b) bs = b:bs
905 get b _ = pprPanic "corePrepPgm" (ppr b)
907 -------------------------------------------
908 canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
909 -- Note [CafInfo and floating]
910 canFloatFromNoCaf (Floats ok_to_spec fs) rhs
911 | OkToSpec <- ok_to_spec -- Worth trying
912 , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
913 = Just (Floats OkToSpec fs', subst_expr subst rhs)
917 subst_expr = substExpr (text "CorePrep")
919 go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
920 -> Maybe (Subst, OrdList FloatingBind)
922 go (subst, fbs_out) [] = Just (subst, fbs_out)
924 go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
926 = go (subst', fbs_out `snocOL` new_fb) fbs_in
928 (subst', b') = set_nocaf_bndr subst b
929 new_fb = FloatLet (NonRec b' (subst_expr subst r))
931 go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
933 = go (subst', fbs_out `snocOL` new_fb) fbs_in
936 (subst', bs') = mapAccumL set_nocaf_bndr subst bs
937 rs' = map (subst_expr subst') rs
938 new_fb = FloatLet (Rec (bs' `zip` rs'))
940 go _ _ = Nothing -- Encountered a caffy binding
943 set_nocaf_bndr subst bndr
944 = (extendIdSubst subst bndr (Var bndr'), bndr')
946 bndr' = bndr `setIdCafInfo` NoCafRefs
949 rhs_ok :: CoreExpr -> Bool
950 -- We can only float to top level from a NoCaf thing if
951 -- the new binding is static. However it can't mention
952 -- any non-static things or it would *already* be Caffy
953 rhs_ok = rhsIsStatic (\_ -> False)
955 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
956 wantFloatNested is_rec strict_or_unlifted floats rhs
957 = isEmptyFloats floats
958 || strict_or_unlifted
959 || (allLazyNested is_rec floats && exprIsHNF rhs)
960 -- Why the test for allLazyNested?
961 -- v = f (x `divInt#` y)
962 -- we don't want to float the case, even if f has arity 2,
963 -- because floating the case would make it evaluated too early
965 allLazyTop :: Floats -> Bool
966 allLazyTop (Floats OkToSpec _) = True
969 allLazyNested :: RecFlag -> Floats -> Bool
970 allLazyNested _ (Floats OkToSpec _) = True
971 allLazyNested _ (Floats NotOkToSpec _) = False
972 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
976 %************************************************************************
980 %************************************************************************
983 -- ---------------------------------------------------------------------------
985 -- ---------------------------------------------------------------------------
987 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
989 emptyCorePrepEnv :: CorePrepEnv
990 emptyCorePrepEnv = CPE emptyVarEnv
992 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
993 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
995 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
996 extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs)
998 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
999 lookupCorePrepEnv (CPE env) id
1000 = case lookupVarEnv env id of
1004 ------------------------------------------------------------------------------
1006 -- ---------------------------------------------------------------------------
1008 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
1009 cloneBndrs env bs = mapAccumLM cloneBndr env bs
1011 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
1014 = do bndr' <- setVarUnique bndr <$> getUniqueM
1015 return (extendCorePrepEnv env bndr bndr', bndr')
1017 | otherwise -- Top level things, which we don't want
1018 -- to clone, have become GlobalIds by now
1019 -- And we don't clone tyvars
1020 = return (env, bndr)
1023 ------------------------------------------------------------------------------
1024 -- Cloning ccall Ids; each must have a unique name,
1025 -- to give the code generator a handle to hang it on
1026 -- ---------------------------------------------------------------------------
1028 fiddleCCall :: Id -> UniqSM Id
1030 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
1031 | otherwise = return id
1033 ------------------------------------------------------------------------------
1034 -- Generating new binders
1035 -- ---------------------------------------------------------------------------
1037 newVar :: Type -> UniqSM Id
1039 = seqType ty `seq` do
1041 return (mkSysLocal (fsLit "sat") uniq ty)