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 )
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
90 We want curried definitions for all of these in case they
91 aren't inlined by some caller.
93 9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs
95 This is all done modulo type applications and abstractions, so that
96 when type erasure is done for conversion to STG, we don't end up with
97 any trivial or useless bindings.
102 Here is the syntax of the Core produced by CorePrep:
105 triv ::= lit | var | triv ty | /\a. triv | triv |> co
108 app ::= lit | var | app triv | app ty | app |> co
112 | let(rec) x = rhs in body -- Boxed only
113 | case body of pat -> body
117 Right hand sides (only place where lambdas can occur)
118 rhs ::= /\a.rhs | \x.rhs | body
120 We define a synonym for each of these non-terminals. Functions
121 with the corresponding name produce a result in that syntax.
124 type CpeTriv = CoreExpr -- Non-terminal 'triv'
125 type CpeApp = CoreExpr -- Non-terminal 'app'
126 type CpeBody = CoreExpr -- Non-terminal 'body'
127 type CpeRhs = CoreExpr -- Non-terminal 'rhs'
130 %************************************************************************
134 %************************************************************************
137 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
138 corePrepPgm dflags binds data_tycons = do
139 showPass dflags "CorePrep"
140 us <- mkSplitUniqSupply 's'
142 let implicit_binds = mkDataConWorkers data_tycons
143 -- NB: we must feed mkImplicitBinds through corePrep too
144 -- so that they are suitably cloned and eta-expanded
146 binds_out = initUs_ us $ do
147 floats1 <- corePrepTopBinds binds
148 floats2 <- corePrepTopBinds implicit_binds
149 return (deFloatTop (floats1 `appendFloats` floats2))
151 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
154 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
155 corePrepExpr dflags expr = do
156 showPass dflags "CorePrep"
157 us <- mkSplitUniqSupply 's'
158 let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr)
159 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
162 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
163 -- Note [Floating out of top level bindings]
164 corePrepTopBinds binds
165 = go emptyCorePrepEnv binds
167 go _ [] = return emptyFloats
168 go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
169 binds' <- go env' binds
170 return (bind' `appendFloats` binds')
172 mkDataConWorkers :: [TyCon] -> [CoreBind]
173 -- See Note [Data constructor workers]
174 mkDataConWorkers data_tycons
175 = [ NonRec id (Var id) -- The ice is thin here, but it works
176 | tycon <- data_tycons, -- CorePrep will eta-expand it
177 data_con <- tyConDataCons tycon,
178 let id = dataConWorkId data_con ]
181 Note [Floating out of top level bindings]
182 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
183 NB: we do need to float out of top-level bindings
184 Consider x = length [True,False]
190 We return a *list* of bindings, because we may start with
192 where x is demanded, in which case we want to finish with
195 And then x will actually end up case-bound
197 Note [CafInfo and floating]
198 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
199 What happens to the CafInfo on the floated bindings? By default, all
200 the CafInfos will be set to MayHaveCafRefs, which is safe.
202 This might be pessimistic, because the floated binding might not refer
203 to any CAFs and the GC will end up doing more traversal than is
204 necessary, but it's still better than not floating the bindings at
205 all, because then the GC would have to traverse the structure in the
206 heap instead. Given this, we decided not to try to get the CafInfo on
207 the floated bindings correct, because it looks difficult.
209 But that means we can't float anything out of a NoCafRefs binding.
211 If f is NoCafRefs, we don't want to convert to
214 where sat conservatively says HasCafRefs, because now f's info
215 is wrong. I don't think this is common, so we simply switch off
216 floating in this case.
218 Note [Data constructor workers]
219 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
220 Create any necessary "implicit" bindings for data con workers. We
221 create the rather strange (non-recursive!) binding
223 $wC = \x y -> $wC x y
225 i.e. a curried constructor that allocates. This means that we can
226 treat the worker for a constructor like any other function in the rest
227 of the compiler. The point here is that CoreToStg will generate a
228 StgConApp for the RHS, rather than a call to the worker (which would
229 give a loop). As Lennart says: the ice is thin here, but it works.
231 Hmm. Should we create bindings for dictionary constructors? They are
232 always fully applied, and the bindings are just there to support
233 partial applications. But it's easier to let them through.
236 %************************************************************************
240 %************************************************************************
243 cpeBind :: TopLevelFlag
244 -> CorePrepEnv -> CoreBind
245 -> UniqSM (CorePrepEnv, Floats)
246 cpeBind top_lvl env (NonRec bndr rhs)
247 = do { (_, bndr1) <- cloneBndr env bndr
248 ; let is_strict = isStrictDmd (idNewDemandInfo bndr)
249 is_unlifted = isUnLiftedType (idType bndr)
250 ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
251 (is_strict || is_unlifted)
253 ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2
255 -- We want bndr'' in the envt, because it records
256 -- the evaluated-ness of the binder
257 ; return (extendCorePrepEnv env bndr bndr2,
258 addFloat floats new_float) }
260 cpeBind top_lvl env (Rec pairs)
261 = do { let (bndrs,rhss) = unzip pairs
262 ; (env', bndrs1) <- cloneBndrs env (map fst pairs)
263 ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
265 ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
266 all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
267 (concatFloats floats_s)
268 ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
269 unitFloat (FloatLet (Rec all_pairs))) }
271 -- Flatten all the floats, and the currrent
272 -- group into a single giant Rec
273 add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
274 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
275 add_float b _ = pprPanic "cpeBind" (ppr b)
278 cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
279 -> CorePrepEnv -> Id -> CoreExpr
280 -> UniqSM (Floats, Id, CoreExpr)
281 -- Used for all bindings
282 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
283 = do { (floats1, rhs1) <- cpeRhsE env rhs
284 ; let (rhs1_bndrs, _) = collectBinders rhs1
286 <- if want_float floats1 rhs1
287 then return (floats1, rhs1)
288 else -- Non-empty floats will wrap rhs1
289 -- But: rhs1 might have lambdas, and we can't
290 -- put them inside a wrapBinds
291 if valBndrCount rhs1_bndrs <= arity
292 then -- Lambdas in rhs1 will be nuked by eta expansion
293 return (emptyFloats, wrapBinds floats1 rhs1)
295 else do { body1 <- rhsToBodyNF rhs1
296 ; return (emptyFloats, wrapBinds floats1 body1) }
298 ; (floats3, rhs') -- Note [Silly extra arguments]
299 <- if manifestArity rhs2 <= arity
300 then return (floats2, cpeEtaExpand arity rhs2)
301 else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
302 (do { v <- newVar (idType bndr)
303 ; let float = mkFloat False False v rhs2
304 ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
306 -- Record if the binder is evaluated
307 ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
310 ; return (floats3, bndr', rhs') }
312 arity = idArity bndr -- We must match this arity
313 want_float floats rhs
314 | isTopLevel top_lvl = wantFloatTop bndr floats
315 | otherwise = wantFloatNested is_rec is_strict_or_unlifted floats rhs
317 {- Note [Silly extra arguments]
318 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
321 We *must* match the arity on the Id, so we have to generate
325 It's a bizarre case: why is the arity on the Id wrong? Reason
326 (in the days of __inline_me__):
327 f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
328 When InlineMe notes go away this won't happen any more. But
329 it seems good for CorePrep to be robust.
332 -- ---------------------------------------------------------------------------
333 -- CpeRhs: produces a result satisfying CpeRhs
334 -- ---------------------------------------------------------------------------
336 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
340 -- e = let bs in e' (semantically, that is!)
343 -- f (g x) ===> ([v = g x], f v)
345 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
346 cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
347 cpeRhsE env expr@(Var {}) = cpeApp env expr
349 cpeRhsE env (Var f `App` _ `App` arg)
350 | f `hasKey` lazyIdKey -- Replace (lazy a) by a
351 = cpeRhsE env arg -- See Note [lazyId magic] in MkId
353 cpeRhsE env expr@(App {}) = cpeApp env expr
355 cpeRhsE env (Let bind expr)
356 = do { (env', new_binds) <- cpeBind NotTopLevel env bind
357 ; (floats, body) <- cpeRhsE env' expr
358 ; return (new_binds `appendFloats` floats, body) }
360 cpeRhsE env (Note note expr)
363 | otherwise -- Just SCCs actually
364 = do { body <- cpeBodyNF env expr
365 ; return (emptyFloats, Note note body) }
367 cpeRhsE env (Cast expr co)
368 = do { (floats, expr') <- cpeRhsE env expr
369 ; return (floats, Cast expr' co) }
371 cpeRhsE env expr@(Lam {})
372 = do { let (bndrs,body) = collectBinders expr
373 ; (env', bndrs') <- cloneBndrs env bndrs
374 ; body' <- cpeBodyNF env' body
375 ; return (emptyFloats, mkLams bndrs' body') }
377 cpeRhsE env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
378 | Just (TickBox {}) <- isTickBoxOp_maybe id
379 = do { body <- cpeBodyNF env expr
380 ; return (emptyFloats, Case (Var id) bndr ty [(DEFAULT,[],body)]) }
382 cpeRhsE env (Case scrut bndr ty alts)
383 = do { (floats, scrut') <- cpeBody env scrut
384 ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
385 -- Record that the case binder is evaluated in the alternatives
386 ; (env', bndr2) <- cloneBndr env bndr1
387 ; alts' <- mapM (sat_alt env') alts
388 ; return (floats, Case scrut' bndr2 ty alts') }
390 sat_alt env (con, bs, rhs)
391 = do { (env2, bs') <- cloneBndrs env bs
392 ; rhs' <- cpeBodyNF env2 rhs
393 ; return (con, bs', rhs') }
395 -- ---------------------------------------------------------------------------
396 -- CpeBody: produces a result satisfying CpeBody
397 -- ---------------------------------------------------------------------------
399 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
401 = do { (floats, body) <- cpeBody env expr
402 ; return (wrapBinds floats body) }
405 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
407 = do { (floats1, rhs) <- cpeRhsE env expr
408 ; (floats2, body) <- rhsToBody rhs
409 ; return (floats1 `appendFloats` floats2, body) }
412 rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
413 rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
414 ; return (wrapBinds floats body) }
417 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
418 -- Remove top level lambdas by let-binding
420 rhsToBody (Note n expr)
421 -- You can get things like
422 -- case e of { p -> coerce t (\s -> ...) }
423 = do { (floats, expr') <- rhsToBody expr
424 ; return (floats, Note n expr') }
426 rhsToBody (Cast e co)
427 = do { (floats, e') <- rhsToBody e
428 ; return (floats, Cast e' co) }
430 rhsToBody expr@(Lam {})
431 | Just no_lam_result <- tryEtaReduce bndrs body
432 = return (emptyFloats, no_lam_result)
433 | all isTyVar bndrs -- Type lambdas are ok
434 = return (emptyFloats, expr)
435 | otherwise -- Some value lambdas
436 = do { fn <- newVar (exprType expr)
437 ; let rhs = cpeEtaExpand (exprArity expr) expr
438 float = FloatLet (NonRec fn rhs)
439 ; return (unitFloat float, Var fn) }
441 (bndrs,body) = collectBinders expr
443 rhsToBody expr = return (emptyFloats, expr)
447 -- ---------------------------------------------------------------------------
448 -- CpeApp: produces a result satisfying CpeApp
449 -- ---------------------------------------------------------------------------
451 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
452 -- May return a CpeRhs because of saturating primops
454 = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
455 ; MASSERT(null ss) -- make sure we used all the strictness info
457 -- Now deal with the function
459 Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
460 ; return (floats, sat_app) }
461 _other -> return (floats, app) }
464 -- Deconstruct and rebuild the application, floating any non-atomic
465 -- arguments to the outside. We collect the type of the expression,
466 -- the head of the application, and the number of actual value arguments,
467 -- all of which are used to possibly saturate this application if it
468 -- has a constructor or primop at the head.
472 -> Int -- Current app depth
473 -> UniqSM (CpeApp, -- The rebuilt expression
474 (CoreExpr,Int), -- The head of the application,
475 -- and no. of args it was applied to
476 Type, -- Type of the whole expr
477 Floats, -- Any floats we pulled out
478 [Demand]) -- Remaining argument demands
480 collect_args (App fun arg@(Type arg_ty)) depth
481 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
482 ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
484 collect_args (App fun arg) depth
485 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
487 (ss1, ss_rest) = case ss of
488 (ss1:ss_rest) -> (ss1, ss_rest)
490 (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
491 splitFunTy_maybe fun_ty
493 ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty
494 ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
496 collect_args (Var v) depth
497 = do { v1 <- fiddleCCall v
498 ; let v2 = lookupCorePrepEnv env v1
499 ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
501 stricts = case idNewStrictness v of
502 StrictSig (DmdType _ demands _)
503 | listLengthCmp demands depth /= GT -> demands
504 -- length demands <= depth
506 -- If depth < length demands, then we have too few args to
507 -- satisfy strictness info so we have to ignore all the
508 -- strictness info, e.g. + (error "urk")
509 -- Here, we can't evaluate the arg strictly, because this
510 -- partial application might be seq'd
512 collect_args (Cast fun co) depth
513 = do { let (_ty1,ty2) = coercionKind co
514 ; (fun', hd, _, floats, ss) <- collect_args fun depth
515 ; return (Cast fun' co, hd, ty2, floats, ss) }
517 collect_args (Note note fun) depth
518 | ignoreNote note -- Drop these notes altogether
519 = collect_args fun depth -- They aren't used by the code generator
521 -- N-variable fun, better let-bind it
522 collect_args fun depth
523 = do { (fun_floats, fun') <- cpeArg env True fun ty
524 -- The True says that it's sure to be evaluated,
525 -- so we'll end up case-binding it
526 ; return (fun', (fun', depth), ty, fun_floats, []) }
530 -- ---------------------------------------------------------------------------
531 -- CpeArg: produces a result satisfying CpeArg
532 -- ---------------------------------------------------------------------------
534 -- This is where we arrange that a non-trivial argument is let-bound
535 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
536 -> UniqSM (Floats, CpeTriv)
537 cpeArg env is_strict arg arg_ty
538 | cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument
539 = cpeBody env arg -- Must still do substitution though
541 = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
542 ; (floats2, arg2) <- if want_float floats1 arg1
543 then return (floats1, arg1)
544 else do { body1 <- rhsToBodyNF arg1
545 ; return (emptyFloats, wrapBinds floats1 body1) }
546 -- Else case: arg1 might have lambdas, and we can't
547 -- put them inside a wrapBinds
550 ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
551 arg_float = mkFloat is_strict is_unlifted v arg3
552 ; return (addFloat floats2 arg_float, Var v) }
554 is_unlifted = isUnLiftedType arg_ty
555 want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
558 Note [Floating unlifted arguments]
559 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
560 Consider C (let v* = expensive in v)
562 where the "*" indicates "will be demanded". Usually v will have been
563 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
566 let v* = expensive in C v
568 because that has different strictness. Hence the use of 'allLazy'.
569 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
572 ------------------------------------------------------------------------------
573 -- Building the saturated syntax
574 -- ---------------------------------------------------------------------------
576 maybeSaturate deals with saturating primops and constructors
577 The type is the type of the entire application
580 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
581 maybeSaturate fn expr n_args
582 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
583 -- A gruesome special case
584 = saturateDataToTag sat_expr
586 | hasNoBinding fn -- There's no binding
592 fn_arity = idArity fn
593 excess_arity = fn_arity - n_args
594 sat_expr = cpeEtaExpand excess_arity expr
597 saturateDataToTag :: CpeApp -> UniqSM CpeApp
598 -- Horrid: ensure that the arg of data2TagOp is evaluated
599 -- (data2tag x) --> (case x of y -> data2tag y)
600 -- (yuk yuk) take into account the lambdas we've now introduced
601 saturateDataToTag sat_expr
602 = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
603 ; eta_body' <- eval_data2tag_arg eta_body
604 ; return (mkLams eta_bndrs eta_body') }
606 eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
607 eval_data2tag_arg app@(fun `App` arg)
608 | exprIsHNF arg -- Includes nullary constructors
609 = return app -- The arg is evaluated
610 | otherwise -- Arg not evaluated, so evaluate it
611 = do { arg_id <- newVar (exprType arg)
612 ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
613 ; return (Case arg arg_id1 (exprType app)
614 [(DEFAULT, [], fun `App` Var arg_id1)]) }
616 eval_data2tag_arg (Note note app) -- Scc notes can appear
617 = do { app' <- eval_data2tag_arg app
618 ; return (Note note app') }
620 eval_data2tag_arg other -- Should not happen
621 = pprPanic "eval_data2tag" (ppr other)
627 %************************************************************************
629 Simple CoreSyn operations
631 %************************************************************************
634 -- We don't ignore SCCs, since they require some code generation
635 ignoreNote :: Note -> Bool
636 -- Tells which notes to drop altogether; they are ignored by code generation
637 -- Do not ignore SCCs!
638 -- It's important that we do drop InlineMe notes; for example
639 -- unzip = __inline_me__ (/\ab. foldr (..) (..))
640 -- Here unzip gets arity 1 so we'll eta-expand it. But we don't
642 -- unzip = /\ab \xs. (__inline_me__ ...) a b xs
643 ignoreNote (CoreNote _) = True
644 ignoreNote InlineMe = True
645 ignoreNote _other = False
648 cpe_ExprIsTrivial :: CoreExpr -> Bool
649 -- Version that doesn't consider an scc annotation to be trivial.
650 cpe_ExprIsTrivial (Var _) = True
651 cpe_ExprIsTrivial (Type _) = True
652 cpe_ExprIsTrivial (Lit _) = True
653 cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
654 cpe_ExprIsTrivial (Note (SCC _) _) = False
655 cpe_ExprIsTrivial (Note _ e) = cpe_ExprIsTrivial e
656 cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
657 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
658 cpe_ExprIsTrivial _ = False
661 -- -----------------------------------------------------------------------------
663 -- -----------------------------------------------------------------------------
666 ~~~~~~~~~~~~~~~~~~~~~
667 Eta expand to match the arity claimed by the binder Remember,
668 CorePrep must not change arity
670 Eta expansion might not have happened already, because it is done by
671 the simplifier only when there at least one lambda already.
673 NB1:we could refrain when the RHS is trivial (which can happen
674 for exported things). This would reduce the amount of code
675 generated (a little) and make things a little words for
676 code compiled without -O. The case in point is data constructor
679 NB2: we have to be careful that the result of etaExpand doesn't
680 invalidate any of the assumptions that CorePrep is attempting
681 to establish. One possible cause is eta expanding inside of
682 an SCC note - we're now careful in etaExpand to make sure the
683 SCC is pushed inside any new lambdas that are generated.
685 Note [Eta expansion and the CorePrep invariants]
686 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
687 It turns out to be much much easier to do eta expansion
688 *after* the main CorePrep stuff. But that places constraints
689 on the eta expander: given a CpeRhs, it must return a CpeRhs.
691 For example here is what we do not want:
692 f = /\a -> g (h 3) -- h has arity 2
694 f = /\a -> let s = h 3 in g s
695 and now we do NOT want eta expansion to give
696 f = /\a -> \ y -> (let s = h 3 in g s) y
698 Instead CoreArity.etaExpand gives
699 f = /\a -> \y -> let s = h 3 in g s y
702 cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr
703 cpeEtaExpand arity expr
705 | otherwise = etaExpand arity expr
708 -- -----------------------------------------------------------------------------
710 -- -----------------------------------------------------------------------------
712 Why try eta reduction? Hasn't the simplifier already done eta?
713 But the simplifier only eta reduces if that leaves something
714 trivial (like f, or f Int). But for deLam it would be enough to
715 get to a partial application:
716 case x of { p -> \xs. map f xs }
717 ==> case x of { p -> map f }
720 tryEtaReduce :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
721 tryEtaReduce bndrs expr@(App _ _)
722 | ok_to_eta_reduce f &&
724 and (zipWith ok bndrs last_args) &&
725 not (any (`elemVarSet` fvs_remaining) bndrs)
726 = Just remaining_expr
728 (f, args) = collectArgs expr
729 remaining_expr = mkApps f remaining_args
730 fvs_remaining = exprFreeVars remaining_expr
731 (remaining_args, last_args) = splitAt n_remaining args
732 n_remaining = length args - length bndrs
734 ok bndr (Var arg) = bndr == arg
737 -- we can't eta reduce something which must be saturated.
738 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
739 ok_to_eta_reduce _ = False --safe. ToDo: generalise
741 tryEtaReduce bndrs (Let bind@(NonRec _ r) body)
742 | not (any (`elemVarSet` fvs) bndrs)
743 = case tryEtaReduce bndrs body of
744 Just e -> Just (Let bind e)
749 tryEtaReduce _ _ = Nothing
753 -- -----------------------------------------------------------------------------
755 -- -----------------------------------------------------------------------------
758 type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recursive
761 %************************************************************************
765 %************************************************************************
769 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
770 | FloatCase Id CpeBody Bool -- The bool indicates "ok-for-speculation"
772 data Floats = Floats OkToSpec (OrdList FloatingBind)
774 -- Can we float these binds out of the rhs of a let? We cache this decision
775 -- to avoid having to recompute it in a non-linear way when there are
776 -- deeply nested lets.
778 = NotOkToSpec -- definitely not
780 | IfUnboxedOk -- only if floating an unboxed binding is ok
782 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
783 mkFloat is_strict is_unlifted bndr rhs
784 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
785 | otherwise = FloatLet (NonRec bndr rhs)
787 use_case = is_unlifted || is_strict && not (exprIsHNF rhs)
788 -- Don't make a case for a value binding,
789 -- even if it's strict. Otherwise we get
790 -- case (\x -> e) of ...!
792 emptyFloats :: Floats
793 emptyFloats = Floats OkToSpec nilOL
795 isEmptyFloats :: Floats -> Bool
796 isEmptyFloats (Floats _ bs) = isNilOL bs
798 wrapBinds :: Floats -> CoreExpr -> CoreExpr
799 wrapBinds (Floats _ binds) body
800 = foldrOL mk_bind body binds
802 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
803 mk_bind (FloatLet bind) body = Let bind body
805 addFloat :: Floats -> FloatingBind -> Floats
806 addFloat (Floats ok_to_spec floats) new_float
807 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
809 check (FloatLet _) = OkToSpec
810 check (FloatCase _ _ ok_for_spec)
811 | ok_for_spec = IfUnboxedOk
812 | otherwise = NotOkToSpec
813 -- The ok-for-speculation flag says that it's safe to
814 -- float this Case out of a let, and thereby do it more eagerly
815 -- We need the top-level flag because it's never ok to float
816 -- an unboxed binding to the top level
818 unitFloat :: FloatingBind -> Floats
819 unitFloat = addFloat emptyFloats
821 appendFloats :: Floats -> Floats -> Floats
822 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
823 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
825 concatFloats :: [Floats] -> OrdList FloatingBind
826 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
828 combine :: OkToSpec -> OkToSpec -> OkToSpec
829 combine NotOkToSpec _ = NotOkToSpec
830 combine _ NotOkToSpec = NotOkToSpec
831 combine IfUnboxedOk _ = IfUnboxedOk
832 combine _ IfUnboxedOk = IfUnboxedOk
833 combine _ _ = OkToSpec
835 instance Outputable FloatingBind where
836 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
837 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
839 deFloatTop :: Floats -> [CoreBind]
840 -- For top level only; we don't expect any FloatCases
841 deFloatTop (Floats _ floats)
842 = foldrOL get [] floats
844 get (FloatLet b) bs = b:bs
845 get b _ = pprPanic "corePrepPgm" (ppr b)
847 -------------------------------------------
848 wantFloatTop :: Id -> Floats -> Bool
849 -- Note [CafInfo and floating]
850 wantFloatTop bndr floats = isEmptyFloats floats
851 || (mayHaveCafRefs (idCafInfo bndr)
852 && allLazyTop floats)
854 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
855 wantFloatNested is_rec strict_or_unlifted floats rhs
856 = isEmptyFloats floats
857 || strict_or_unlifted
858 || (allLazyNested is_rec floats && exprIsHNF rhs)
859 -- Why the test for allLazyNested?
860 -- v = f (x `divInt#` y)
861 -- we don't want to float the case, even if f has arity 2,
862 -- because floating the case would make it evaluated too early
864 allLazyTop :: Floats -> Bool
865 allLazyTop (Floats OkToSpec _) = True
868 allLazyNested :: RecFlag -> Floats -> Bool
869 allLazyNested _ (Floats OkToSpec _) = True
870 allLazyNested _ (Floats NotOkToSpec _) = False
871 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
875 %************************************************************************
879 %************************************************************************
882 -- ---------------------------------------------------------------------------
884 -- ---------------------------------------------------------------------------
886 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
888 emptyCorePrepEnv :: CorePrepEnv
889 emptyCorePrepEnv = CPE emptyVarEnv
891 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
892 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
894 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
895 extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs)
897 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
898 lookupCorePrepEnv (CPE env) id
899 = case lookupVarEnv env id of
903 ------------------------------------------------------------------------------
905 -- ---------------------------------------------------------------------------
907 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
908 cloneBndrs env bs = mapAccumLM cloneBndr env bs
910 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
913 = do bndr' <- setVarUnique bndr <$> getUniqueM
914 return (extendCorePrepEnv env bndr bndr', bndr')
916 | otherwise -- Top level things, which we don't want
917 -- to clone, have become GlobalIds by now
918 -- And we don't clone tyvars
922 ------------------------------------------------------------------------------
923 -- Cloning ccall Ids; each must have a unique name,
924 -- to give the code generator a handle to hang it on
925 -- ---------------------------------------------------------------------------
927 fiddleCCall :: Id -> UniqSM Id
929 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
930 | otherwise = return id
932 ------------------------------------------------------------------------------
933 -- Generating new binders
934 -- ---------------------------------------------------------------------------
936 newVar :: Type -> UniqSM Id
938 = seqType ty `seq` do
940 return (mkSysLocal (fsLit "sat") uniq ty)