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 )
44 -- ---------------------------------------------------------------------------
46 -- ---------------------------------------------------------------------------
48 The goal of this pass is to prepare for code generation.
50 1. Saturate constructor and primop applications.
52 2. Convert to A-normal form; that is, function arguments
55 * Use case for strict arguments:
56 f E ==> case E of x -> f x
59 * Use let for non-trivial lazy arguments
60 f E ==> let x = E in f x
61 (were f is lazy and x is non-trivial)
63 3. Similarly, convert any unboxed lets into cases.
64 [I'm experimenting with leaving 'ok-for-speculation'
65 rhss in let-form right up to this point.]
67 4. Ensure that *value* lambdas only occur as the RHS of a binding
68 (The code generator can't deal with anything else.)
69 Type lambdas are ok, however, because the code gen discards them.
71 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
73 6. Clone all local Ids.
74 This means that all such Ids are unique, rather than the
75 weaker guarantee of no clashes which the simplifier provides.
76 And that is what the code generator needs.
78 We don't clone TyVars. The code gen doesn't need that,
79 and doing so would be tiresome because then we'd need
80 to substitute in types.
83 7. Give each dynamic CCall occurrence a fresh unique; this is
84 rather like the cloning step above.
86 8. Inject bindings for the "implicit" Ids:
87 * Constructor wrappers
89 We want curried definitions for all of these in case they
90 aren't inlined by some caller.
92 9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs
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.
101 Here is the syntax of the Core produced by CorePrep:
104 triv ::= lit | var | triv ty | /\a. triv | triv |> co
107 app ::= lit | var | app triv | app ty | app |> co
111 | let(rec) x = rhs in body -- Boxed only
112 | case body of pat -> body
116 Right hand sides (only place where lambdas can occur)
117 rhs ::= /\a.rhs | \x.rhs | body
119 We define a synonym for each of these non-terminals. Functions
120 with the corresponding name produce a result in that syntax.
123 type CpeTriv = CoreExpr -- Non-terminal 'triv'
124 type CpeApp = CoreExpr -- Non-terminal 'app'
125 type CpeBody = CoreExpr -- Non-terminal 'body'
126 type CpeRhs = CoreExpr -- Non-terminal 'rhs'
129 %************************************************************************
133 %************************************************************************
136 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
137 corePrepPgm dflags binds data_tycons = do
138 showPass dflags "CorePrep"
139 us <- mkSplitUniqSupply 's'
141 let implicit_binds = mkDataConWorkers data_tycons
142 -- NB: we must feed mkImplicitBinds through corePrep too
143 -- so that they are suitably cloned and eta-expanded
145 binds_out = initUs_ us $ do
146 floats1 <- corePrepTopBinds binds
147 floats2 <- corePrepTopBinds implicit_binds
148 return (deFloatTop (floats1 `appendFloats` floats2))
150 endPass dflags "CorePrep" Opt_D_dump_prep binds_out []
153 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
154 corePrepExpr dflags expr = do
155 showPass dflags "CorePrep"
156 us <- mkSplitUniqSupply 's'
157 let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr)
158 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
161 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
162 -- Note [Floating out of top level bindings]
163 corePrepTopBinds binds
164 = go emptyCorePrepEnv binds
166 go _ [] = return emptyFloats
167 go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
168 binds' <- go env' binds
169 return (bind' `appendFloats` binds')
171 mkDataConWorkers :: [TyCon] -> [CoreBind]
172 -- See Note [Data constructor workers]
173 mkDataConWorkers data_tycons
174 = [ NonRec id (Var id) -- The ice is thin here, but it works
175 | tycon <- data_tycons, -- CorePrep will eta-expand it
176 data_con <- tyConDataCons tycon,
177 let id = dataConWorkId data_con ]
180 Note [Floating out of top level bindings]
181 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
182 NB: we do need to float out of top-level bindings
183 Consider x = length [True,False]
189 We return a *list* of bindings, because we may start with
191 where x is demanded, in which case we want to finish with
194 And then x will actually end up case-bound
196 Note [CafInfo and floating]
197 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
198 What happens to the CafInfo on the floated bindings? By default, all
199 the CafInfos will be set to MayHaveCafRefs, which is safe.
201 This might be pessimistic, because the floated binding might not refer
202 to any CAFs and the GC will end up doing more traversal than is
203 necessary, but it's still better than not floating the bindings at
204 all, because then the GC would have to traverse the structure in the
205 heap instead. Given this, we decided not to try to get the CafInfo on
206 the floated bindings correct, because it looks difficult.
208 But that means we can't float anything out of a NoCafRefs binding.
210 If f is NoCafRefs, we don't want to convert to
213 where sat conservatively says HasCafRefs, because now f's info
214 is wrong. I don't think this is common, so we simply switch off
215 floating in this case.
217 Note [Data constructor workers]
218 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
219 Create any necessary "implicit" bindings for data con workers. We
220 create the rather strange (non-recursive!) binding
222 $wC = \x y -> $wC x y
224 i.e. a curried constructor that allocates. This means that we can
225 treat the worker for a constructor like any other function in the rest
226 of the compiler. The point here is that CoreToStg will generate a
227 StgConApp for the RHS, rather than a call to the worker (which would
228 give a loop). As Lennart says: the ice is thin here, but it works.
230 Hmm. Should we create bindings for dictionary constructors? They are
231 always fully applied, and the bindings are just there to support
232 partial applications. But it's easier to let them through.
235 %************************************************************************
239 %************************************************************************
242 cpeBind :: TopLevelFlag
243 -> CorePrepEnv -> CoreBind
244 -> UniqSM (CorePrepEnv, Floats)
245 cpeBind top_lvl env (NonRec bndr rhs)
246 = do { (_, bndr1) <- cloneBndr env bndr
247 ; let is_strict = isStrictDmd (idNewDemandInfo bndr)
248 is_unlifted = isUnLiftedType (idType bndr)
249 ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
250 (is_strict || is_unlifted)
252 ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2
254 -- We want bndr'' in the envt, because it records
255 -- the evaluated-ness of the binder
256 ; return (extendCorePrepEnv env bndr bndr2,
257 addFloat floats new_float) }
259 cpeBind top_lvl env (Rec pairs)
260 = do { let (bndrs,rhss) = unzip pairs
261 ; (env', bndrs1) <- cloneBndrs env (map fst pairs)
262 ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
264 ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
265 all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
266 (concatFloats floats_s)
267 ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
268 unitFloat (FloatLet (Rec all_pairs))) }
270 -- Flatten all the floats, and the currrent
271 -- group into a single giant Rec
272 add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
273 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
274 add_float b _ = pprPanic "cpeBind" (ppr b)
277 cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
278 -> CorePrepEnv -> Id -> CoreExpr
279 -> UniqSM (Floats, Id, CoreExpr)
280 -- Used for all bindings
281 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
282 = do { (floats1, rhs1) <- cpeRhsE env rhs
283 ; let (rhs1_bndrs, _) = collectBinders rhs1
285 <- if want_float floats1 rhs1
286 then return (floats1, rhs1)
287 else -- Non-empty floats will wrap rhs1
288 -- But: rhs1 might have lambdas, and we can't
289 -- put them inside a wrapBinds
290 if valBndrCount rhs1_bndrs <= arity
291 then -- Lambdas in rhs1 will be nuked by eta expansion
292 return (emptyFloats, wrapBinds floats1 rhs1)
294 else do { body1 <- rhsToBodyNF rhs1
295 ; return (emptyFloats, wrapBinds floats1 body1) }
297 ; (floats3, rhs') -- Note [Silly extra arguments]
298 <- if manifestArity rhs2 <= arity
299 then return (floats2, cpeEtaExpand arity rhs2)
300 else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
301 (do { v <- newVar (idType bndr)
302 ; let float = mkFloat False False v rhs2
303 ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
305 -- Record if the binder is evaluated
306 ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
309 ; return (floats3, bndr', rhs') }
311 arity = idArity bndr -- We must match this arity
312 want_float floats rhs
313 | isTopLevel top_lvl = wantFloatTop bndr floats
314 | otherwise = wantFloatNested is_rec is_strict_or_unlifted floats rhs
316 {- Note [Silly extra arguments]
317 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
320 We *must* match the arity on the Id, so we have to generate
324 It's a bizarre case: why is the arity on the Id wrong? Reason
325 (in the days of __inline_me__):
326 f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
327 When InlineMe notes go away this won't happen any more. But
328 it seems good for CorePrep to be robust.
331 -- ---------------------------------------------------------------------------
332 -- CpeRhs: produces a result satisfying CpeRhs
333 -- ---------------------------------------------------------------------------
335 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
339 -- e = let bs in e' (semantically, that is!)
342 -- f (g x) ===> ([v = g x], f v)
344 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
345 cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
346 cpeRhsE env expr@(Var {}) = cpeApp env expr
348 cpeRhsE env (Var f `App` _ `App` arg)
349 | f `hasKey` lazyIdKey -- Replace (lazy a) by a
350 = cpeRhsE env arg -- See Note [lazyId magic] in MkId
352 cpeRhsE env expr@(App {}) = cpeApp env expr
354 cpeRhsE env (Let bind expr)
355 = do { (env', new_binds) <- cpeBind NotTopLevel env bind
356 ; (floats, body) <- cpeRhsE env' expr
357 ; return (new_binds `appendFloats` floats, body) }
359 cpeRhsE env (Note note expr)
362 | otherwise -- Just SCCs actually
363 = do { body <- cpeBodyNF env expr
364 ; return (emptyFloats, Note note body) }
366 cpeRhsE env (Cast expr co)
367 = do { (floats, expr') <- cpeRhsE env expr
368 ; return (floats, Cast expr' co) }
370 cpeRhsE env expr@(Lam {})
371 = do { let (bndrs,body) = collectBinders expr
372 ; (env', bndrs') <- cloneBndrs env bndrs
373 ; body' <- cpeBodyNF env' body
374 ; return (emptyFloats, mkLams bndrs' body') }
376 cpeRhsE env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
377 | Just (TickBox {}) <- isTickBoxOp_maybe id
378 = do { body <- cpeBodyNF env expr
379 ; return (emptyFloats, Case (Var id) bndr ty [(DEFAULT,[],body)]) }
381 cpeRhsE env (Case scrut bndr ty alts)
382 = do { (floats, scrut') <- cpeBody env scrut
383 ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
384 -- Record that the case binder is evaluated in the alternatives
385 ; (env', bndr2) <- cloneBndr env bndr1
386 ; alts' <- mapM (sat_alt env') alts
387 ; return (floats, Case scrut' bndr2 ty alts') }
389 sat_alt env (con, bs, rhs)
390 = do { (env2, bs') <- cloneBndrs env bs
391 ; rhs' <- cpeBodyNF env2 rhs
392 ; return (con, bs', rhs') }
394 -- ---------------------------------------------------------------------------
395 -- CpeBody: produces a result satisfying CpeBody
396 -- ---------------------------------------------------------------------------
398 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
400 = do { (floats, body) <- cpeBody env expr
401 ; return (wrapBinds floats body) }
404 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
406 = do { (floats1, rhs) <- cpeRhsE env expr
407 ; (floats2, body) <- rhsToBody rhs
408 ; return (floats1 `appendFloats` floats2, body) }
411 rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
412 rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
413 ; return (wrapBinds floats body) }
416 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
417 -- Remove top level lambdas by let-binding
419 rhsToBody (Note n expr)
420 -- You can get things like
421 -- case e of { p -> coerce t (\s -> ...) }
422 = do { (floats, expr') <- rhsToBody expr
423 ; return (floats, Note n expr') }
425 rhsToBody (Cast e co)
426 = do { (floats, e') <- rhsToBody e
427 ; return (floats, Cast e' co) }
429 rhsToBody expr@(Lam {})
430 | Just no_lam_result <- tryEtaReduce bndrs body
431 = return (emptyFloats, no_lam_result)
432 | all isTyVar bndrs -- Type lambdas are ok
433 = return (emptyFloats, expr)
434 | otherwise -- Some value lambdas
435 = do { fn <- newVar (exprType expr)
436 ; let rhs = cpeEtaExpand (exprArity expr) expr
437 float = FloatLet (NonRec fn rhs)
438 ; return (unitFloat float, Var fn) }
440 (bndrs,body) = collectBinders expr
442 rhsToBody expr = return (emptyFloats, expr)
446 -- ---------------------------------------------------------------------------
447 -- CpeApp: produces a result satisfying CpeApp
448 -- ---------------------------------------------------------------------------
450 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
451 -- May return a CpeRhs because of saturating primops
453 = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
454 ; MASSERT(null ss) -- make sure we used all the strictness info
456 -- Now deal with the function
458 Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
459 ; return (floats, sat_app) }
460 _other -> return (floats, app) }
463 -- Deconstruct and rebuild the application, floating any non-atomic
464 -- arguments to the outside. We collect the type of the expression,
465 -- the head of the application, and the number of actual value arguments,
466 -- all of which are used to possibly saturate this application if it
467 -- has a constructor or primop at the head.
471 -> Int -- Current app depth
472 -> UniqSM (CpeApp, -- The rebuilt expression
473 (CoreExpr,Int), -- The head of the application,
474 -- and no. of args it was applied to
475 Type, -- Type of the whole expr
476 Floats, -- Any floats we pulled out
477 [Demand]) -- Remaining argument demands
479 collect_args (App fun arg@(Type arg_ty)) depth
480 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
481 ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
483 collect_args (App fun arg) depth
484 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
486 (ss1, ss_rest) = case ss of
487 (ss1:ss_rest) -> (ss1, ss_rest)
489 (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
490 splitFunTy_maybe fun_ty
492 ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty
493 ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
495 collect_args (Var v) depth
496 = do { v1 <- fiddleCCall v
497 ; let v2 = lookupCorePrepEnv env v1
498 ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
500 stricts = case idNewStrictness v of
501 StrictSig (DmdType _ demands _)
502 | listLengthCmp demands depth /= GT -> demands
503 -- length demands <= depth
505 -- If depth < length demands, then we have too few args to
506 -- satisfy strictness info so we have to ignore all the
507 -- strictness info, e.g. + (error "urk")
508 -- Here, we can't evaluate the arg strictly, because this
509 -- partial application might be seq'd
511 collect_args (Cast fun co) depth
512 = do { let (_ty1,ty2) = coercionKind co
513 ; (fun', hd, _, floats, ss) <- collect_args fun depth
514 ; return (Cast fun' co, hd, ty2, floats, ss) }
516 collect_args (Note note fun) depth
517 | ignoreNote note -- Drop these notes altogether
518 = collect_args fun depth -- They aren't used by the code generator
520 -- N-variable fun, better let-bind it
521 collect_args fun depth
522 = do { (fun_floats, fun') <- cpeArg env True fun ty
523 -- The True says that it's sure to be evaluated,
524 -- so we'll end up case-binding it
525 ; return (fun', (fun', depth), ty, fun_floats, []) }
529 -- ---------------------------------------------------------------------------
530 -- CpeArg: produces a result satisfying CpeArg
531 -- ---------------------------------------------------------------------------
533 -- This is where we arrange that a non-trivial argument is let-bound
534 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
535 -> UniqSM (Floats, CpeTriv)
536 cpeArg env is_strict arg arg_ty
537 | cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument
538 = cpeBody env arg -- Must still do substitution though
540 = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
541 ; (floats2, arg2) <- if want_float floats1 arg1
542 then return (floats1, arg1)
543 else do { body1 <- rhsToBodyNF arg1
544 ; return (emptyFloats, wrapBinds floats1 body1) }
545 -- Else case: arg1 might have lambdas, and we can't
546 -- put them inside a wrapBinds
549 ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
550 arg_float = mkFloat is_strict is_unlifted v arg3
551 ; return (addFloat floats2 arg_float, Var v) }
553 is_unlifted = isUnLiftedType arg_ty
554 want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
557 Note [Floating unlifted arguments]
558 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
559 Consider C (let v* = expensive in v)
561 where the "*" indicates "will be demanded". Usually v will have been
562 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
565 let v* = expensive in C v
567 because that has different strictness. Hence the use of 'allLazy'.
568 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
571 ------------------------------------------------------------------------------
572 -- Building the saturated syntax
573 -- ---------------------------------------------------------------------------
575 maybeSaturate deals with saturating primops and constructors
576 The type is the type of the entire application
579 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
580 maybeSaturate fn expr n_args
581 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
582 -- A gruesome special case
583 = saturateDataToTag sat_expr
585 | hasNoBinding fn -- There's no binding
591 fn_arity = idArity fn
592 excess_arity = fn_arity - n_args
593 sat_expr = cpeEtaExpand excess_arity expr
596 saturateDataToTag :: CpeApp -> UniqSM CpeApp
597 -- Horrid: ensure that the arg of data2TagOp is evaluated
598 -- (data2tag x) --> (case x of y -> data2tag y)
599 -- (yuk yuk) take into account the lambdas we've now introduced
600 saturateDataToTag sat_expr
601 = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
602 ; eta_body' <- eval_data2tag_arg eta_body
603 ; return (mkLams eta_bndrs eta_body') }
605 eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
606 eval_data2tag_arg app@(fun `App` arg)
607 | exprIsHNF arg -- Includes nullary constructors
608 = return app -- The arg is evaluated
609 | otherwise -- Arg not evaluated, so evaluate it
610 = do { arg_id <- newVar (exprType arg)
611 ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
612 ; return (Case arg arg_id1 (exprType app)
613 [(DEFAULT, [], fun `App` Var arg_id1)]) }
615 eval_data2tag_arg (Note note app) -- Scc notes can appear
616 = do { app' <- eval_data2tag_arg app
617 ; return (Note note app') }
619 eval_data2tag_arg other -- Should not happen
620 = pprPanic "eval_data2tag" (ppr other)
626 %************************************************************************
628 Simple CoreSyn operations
630 %************************************************************************
633 -- We don't ignore SCCs, since they require some code generation
634 ignoreNote :: Note -> Bool
635 -- Tells which notes to drop altogether; they are ignored by code generation
636 -- Do not ignore SCCs!
637 -- It's important that we do drop InlineMe notes; for example
638 -- unzip = __inline_me__ (/\ab. foldr (..) (..))
639 -- Here unzip gets arity 1 so we'll eta-expand it. But we don't
641 -- unzip = /\ab \xs. (__inline_me__ ...) a b xs
642 ignoreNote (CoreNote _) = True
643 ignoreNote _other = False
646 cpe_ExprIsTrivial :: CoreExpr -> Bool
647 -- Version that doesn't consider an scc annotation to be trivial.
648 cpe_ExprIsTrivial (Var _) = True
649 cpe_ExprIsTrivial (Type _) = True
650 cpe_ExprIsTrivial (Lit _) = True
651 cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
652 cpe_ExprIsTrivial (Note (SCC _) _) = False
653 cpe_ExprIsTrivial (Note _ e) = cpe_ExprIsTrivial e
654 cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
655 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
656 cpe_ExprIsTrivial _ = False
659 -- -----------------------------------------------------------------------------
661 -- -----------------------------------------------------------------------------
664 ~~~~~~~~~~~~~~~~~~~~~
665 Eta expand to match the arity claimed by the binder Remember,
666 CorePrep must not change arity
668 Eta expansion might not have happened already, because it is done by
669 the simplifier only when there at least one lambda already.
671 NB1:we could refrain when the RHS is trivial (which can happen
672 for exported things). This would reduce the amount of code
673 generated (a little) and make things a little words for
674 code compiled without -O. The case in point is data constructor
677 NB2: we have to be careful that the result of etaExpand doesn't
678 invalidate any of the assumptions that CorePrep is attempting
679 to establish. One possible cause is eta expanding inside of
680 an SCC note - we're now careful in etaExpand to make sure the
681 SCC is pushed inside any new lambdas that are generated.
683 Note [Eta expansion and the CorePrep invariants]
684 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
685 It turns out to be much much easier to do eta expansion
686 *after* the main CorePrep stuff. But that places constraints
687 on the eta expander: given a CpeRhs, it must return a CpeRhs.
689 For example here is what we do not want:
690 f = /\a -> g (h 3) -- h has arity 2
692 f = /\a -> let s = h 3 in g s
693 and now we do NOT want eta expansion to give
694 f = /\a -> \ y -> (let s = h 3 in g s) y
696 Instead CoreArity.etaExpand gives
697 f = /\a -> \y -> let s = h 3 in g s y
700 cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr
701 cpeEtaExpand arity expr
703 | otherwise = etaExpand arity expr
706 -- -----------------------------------------------------------------------------
708 -- -----------------------------------------------------------------------------
710 Why try eta reduction? Hasn't the simplifier already done eta?
711 But the simplifier only eta reduces if that leaves something
712 trivial (like f, or f Int). But for deLam it would be enough to
713 get to a partial application:
714 case x of { p -> \xs. map f xs }
715 ==> case x of { p -> map f }
718 tryEtaReduce :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
719 tryEtaReduce bndrs expr@(App _ _)
720 | ok_to_eta_reduce f &&
722 and (zipWith ok bndrs last_args) &&
723 not (any (`elemVarSet` fvs_remaining) bndrs)
724 = Just remaining_expr
726 (f, args) = collectArgs expr
727 remaining_expr = mkApps f remaining_args
728 fvs_remaining = exprFreeVars remaining_expr
729 (remaining_args, last_args) = splitAt n_remaining args
730 n_remaining = length args - length bndrs
732 ok bndr (Var arg) = bndr == arg
735 -- we can't eta reduce something which must be saturated.
736 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
737 ok_to_eta_reduce _ = False --safe. ToDo: generalise
739 tryEtaReduce bndrs (Let bind@(NonRec _ r) body)
740 | not (any (`elemVarSet` fvs) bndrs)
741 = case tryEtaReduce bndrs body of
742 Just e -> Just (Let bind e)
747 tryEtaReduce _ _ = Nothing
751 -- -----------------------------------------------------------------------------
753 -- -----------------------------------------------------------------------------
756 type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recursive
759 %************************************************************************
763 %************************************************************************
767 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
768 | FloatCase Id CpeBody Bool -- The bool indicates "ok-for-speculation"
770 data Floats = Floats OkToSpec (OrdList FloatingBind)
772 -- Can we float these binds out of the rhs of a let? We cache this decision
773 -- to avoid having to recompute it in a non-linear way when there are
774 -- deeply nested lets.
776 = NotOkToSpec -- definitely not
778 | IfUnboxedOk -- only if floating an unboxed binding is ok
780 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
781 mkFloat is_strict is_unlifted bndr rhs
782 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
783 | otherwise = FloatLet (NonRec bndr rhs)
785 use_case = is_unlifted || is_strict && not (exprIsHNF rhs)
786 -- Don't make a case for a value binding,
787 -- even if it's strict. Otherwise we get
788 -- case (\x -> e) of ...!
790 emptyFloats :: Floats
791 emptyFloats = Floats OkToSpec nilOL
793 isEmptyFloats :: Floats -> Bool
794 isEmptyFloats (Floats _ bs) = isNilOL bs
796 wrapBinds :: Floats -> CoreExpr -> CoreExpr
797 wrapBinds (Floats _ binds) body
798 = foldrOL mk_bind body binds
800 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
801 mk_bind (FloatLet bind) body = Let bind body
803 addFloat :: Floats -> FloatingBind -> Floats
804 addFloat (Floats ok_to_spec floats) new_float
805 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
807 check (FloatLet _) = OkToSpec
808 check (FloatCase _ _ ok_for_spec)
809 | ok_for_spec = IfUnboxedOk
810 | otherwise = NotOkToSpec
811 -- The ok-for-speculation flag says that it's safe to
812 -- float this Case out of a let, and thereby do it more eagerly
813 -- We need the top-level flag because it's never ok to float
814 -- an unboxed binding to the top level
816 unitFloat :: FloatingBind -> Floats
817 unitFloat = addFloat emptyFloats
819 appendFloats :: Floats -> Floats -> Floats
820 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
821 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
823 concatFloats :: [Floats] -> OrdList FloatingBind
824 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
826 combine :: OkToSpec -> OkToSpec -> OkToSpec
827 combine NotOkToSpec _ = NotOkToSpec
828 combine _ NotOkToSpec = NotOkToSpec
829 combine IfUnboxedOk _ = IfUnboxedOk
830 combine _ IfUnboxedOk = IfUnboxedOk
831 combine _ _ = OkToSpec
833 instance Outputable FloatingBind where
834 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
835 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
837 deFloatTop :: Floats -> [CoreBind]
838 -- For top level only; we don't expect any FloatCases
839 deFloatTop (Floats _ floats)
840 = foldrOL get [] floats
842 get (FloatLet b) bs = b:bs
843 get b _ = pprPanic "corePrepPgm" (ppr b)
845 -------------------------------------------
846 wantFloatTop :: Id -> Floats -> Bool
847 -- Note [CafInfo and floating]
848 wantFloatTop bndr floats = isEmptyFloats floats
849 || (mayHaveCafRefs (idCafInfo bndr)
850 && allLazyTop floats)
852 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
853 wantFloatNested is_rec strict_or_unlifted floats rhs
854 = isEmptyFloats floats
855 || strict_or_unlifted
856 || (allLazyNested is_rec floats && exprIsHNF rhs)
857 -- Why the test for allLazyNested?
858 -- v = f (x `divInt#` y)
859 -- we don't want to float the case, even if f has arity 2,
860 -- because floating the case would make it evaluated too early
862 allLazyTop :: Floats -> Bool
863 allLazyTop (Floats OkToSpec _) = True
866 allLazyNested :: RecFlag -> Floats -> Bool
867 allLazyNested _ (Floats OkToSpec _) = True
868 allLazyNested _ (Floats NotOkToSpec _) = False
869 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
873 %************************************************************************
877 %************************************************************************
880 -- ---------------------------------------------------------------------------
882 -- ---------------------------------------------------------------------------
884 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
886 emptyCorePrepEnv :: CorePrepEnv
887 emptyCorePrepEnv = CPE emptyVarEnv
889 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
890 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
892 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
893 extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs)
895 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
896 lookupCorePrepEnv (CPE env) id
897 = case lookupVarEnv env id of
901 ------------------------------------------------------------------------------
903 -- ---------------------------------------------------------------------------
905 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
906 cloneBndrs env bs = mapAccumLM cloneBndr env bs
908 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
911 = do bndr' <- setVarUnique bndr <$> getUniqueM
912 return (extendCorePrepEnv env bndr bndr', bndr')
914 | otherwise -- Top level things, which we don't want
915 -- to clone, have become GlobalIds by now
916 -- And we don't clone tyvars
920 ------------------------------------------------------------------------------
921 -- Cloning ccall Ids; each must have a unique name,
922 -- to give the code generator a handle to hang it on
923 -- ---------------------------------------------------------------------------
925 fiddleCCall :: Id -> UniqSM Id
927 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
928 | otherwise = return id
930 ------------------------------------------------------------------------------
931 -- Generating new binders
932 -- ---------------------------------------------------------------------------
934 newVar :: Type -> UniqSM Id
936 = seqType ty `seq` do
938 return (mkSysLocal (fsLit "sat") uniq ty)