2 % (c) The University of Glasgow, 1994-2006
5 Core pass to saturate constructors and PrimOps
9 corePrepPgm, corePrepExpr
12 #include "HsVersions.h"
43 -- ---------------------------------------------------------------------------
45 -- ---------------------------------------------------------------------------
47 The goal of this pass is to prepare for code generation.
49 1. Saturate constructor and primop applications.
51 2. Convert to A-normal form; that is, function arguments
54 * Use case for strict arguments:
55 f E ==> case E of x -> f x
58 * Use let for non-trivial lazy arguments
59 f E ==> let x = E in f x
60 (were f is lazy and x is non-trivial)
62 3. Similarly, convert any unboxed lets into cases.
63 [I'm experimenting with leaving 'ok-for-speculation'
64 rhss in let-form right up to this point.]
66 4. Ensure that *value* lambdas only occur as the RHS of a binding
67 (The code generator can't deal with anything else.)
68 Type lambdas are ok, however, because the code gen discards them.
70 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
72 6. Clone all local Ids.
73 This means that all such Ids are unique, rather than the
74 weaker guarantee of no clashes which the simplifier provides.
75 And that is what the code generator needs.
77 We don't clone TyVars. The code gen doesn't need that,
78 and doing so would be tiresome because then we'd need
79 to substitute in types.
82 7. Give each dynamic CCall occurrence a fresh unique; this is
83 rather like the cloning step above.
85 8. Inject bindings for the "implicit" Ids:
86 * Constructor wrappers
89 We want curried definitions for all of these in case they
90 aren't inlined by some caller.
92 This is all done modulo type applications and abstractions, so that
93 when type erasure is done for conversion to STG, we don't end up with
94 any trivial or useless bindings.
99 Here is the syntax of the Core produced by CorePrep:
102 triv ::= lit | var | triv ty | /\a. triv | triv |> co
105 app ::= lit | var | app triv | app ty | app |> co
109 | let(rec) x = rhs in body -- Boxed only
110 | case body of pat -> body
114 Right hand sides (only place where lambdas can occur)
115 rhs ::= /\a.rhs | \x.rhs | body
117 We define a synonym for each of these non-terminals. Functions
118 with the corresponding name produce a result in that syntax.
121 type CpeTriv = CoreExpr -- Non-terminal 'triv'
122 type CpeApp = CoreExpr -- Non-terminal 'app'
123 type CpeBody = CoreExpr -- Non-terminal 'body'
124 type CpeRhs = CoreExpr -- Non-terminal 'rhs'
127 %************************************************************************
131 %************************************************************************
134 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
135 corePrepPgm dflags binds data_tycons = do
136 showPass dflags "CorePrep"
137 us <- mkSplitUniqSupply 's'
139 let implicit_binds = mkDataConWorkers data_tycons
140 -- NB: we must feed mkImplicitBinds through corePrep too
141 -- so that they are suitably cloned and eta-expanded
143 binds_out = initUs_ us $ do
144 floats1 <- corePrepTopBinds binds
145 floats2 <- corePrepTopBinds implicit_binds
146 return (deFloatTop (floats1 `appendFloats` floats2))
148 endPass dflags "CorePrep" Opt_D_dump_prep binds_out
151 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
152 corePrepExpr dflags expr = do
153 showPass dflags "CorePrep"
154 us <- mkSplitUniqSupply 's'
155 let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr)
156 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
159 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
160 -- Note [Floating out of top level bindings]
161 corePrepTopBinds binds
162 = go emptyCorePrepEnv binds
164 go _ [] = return emptyFloats
165 go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
166 binds' <- go env' binds
167 return (bind' `appendFloats` binds')
169 mkDataConWorkers :: [TyCon] -> [CoreBind]
170 -- See Note [Data constructor workers]
171 mkDataConWorkers data_tycons
172 = [ NonRec id (Var id) -- The ice is thin here, but it works
173 | tycon <- data_tycons, -- CorePrep will eta-expand it
174 data_con <- tyConDataCons tycon,
175 let id = dataConWorkId data_con ]
178 Note [Floating out of top level bindings]
179 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
180 NB: we do need to float out of top-level bindings
181 Consider x = length [True,False]
187 We return a *list* of bindings, because we may start with
189 where x is demanded, in which case we want to finish with
192 And then x will actually end up case-bound
194 Note [CafInfo and floating]
195 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
196 What happens to the CafInfo on the floated bindings? By default, all
197 the CafInfos will be set to MayHaveCafRefs, which is safe.
199 This might be pessimistic, because the floated binding might not refer
200 to any CAFs and the GC will end up doing more traversal than is
201 necessary, but it's still better than not floating the bindings at
202 all, because then the GC would have to traverse the structure in the
203 heap instead. Given this, we decided not to try to get the CafInfo on
204 the floated bindings correct, because it looks difficult.
206 But that means we can't float anything out of a NoCafRefs binding.
208 If f is NoCafRefs, we don't want to convert to
211 where sat conservatively says HasCafRefs, because now f's info
212 is wrong. I don't think this is common, so we simply switch off
213 floating in this case.
215 Note [Data constructor workers]
216 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
217 Create any necessary "implicit" bindings for data con workers. We
218 create the rather strange (non-recursive!) binding
220 $wC = \x y -> $wC x y
222 i.e. a curried constructor that allocates. This means that we can
223 treat the worker for a constructor like any other function in the rest
224 of the compiler. The point here is that CoreToStg will generate a
225 StgConApp for the RHS, rather than a call to the worker (which would
226 give a loop). As Lennart says: the ice is thin here, but it works.
228 Hmm. Should we create bindings for dictionary constructors? They are
229 always fully applied, and the bindings are just there to support
230 partial applications. But it's easier to let them through.
233 %************************************************************************
237 %************************************************************************
240 cpeBind :: TopLevelFlag
241 -> CorePrepEnv -> CoreBind
242 -> UniqSM (CorePrepEnv, Floats)
243 cpeBind top_lvl env (NonRec bndr rhs)
244 = do { (_, bndr1) <- cloneBndr env bndr
245 ; let is_strict = isStrictDmd (idNewDemandInfo bndr)
246 is_unlifted = isUnLiftedType (idType bndr)
247 ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
248 (is_strict || is_unlifted)
250 ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2
252 -- We want bndr'' in the envt, because it records
253 -- the evaluated-ness of the binder
254 ; return (extendCorePrepEnv env bndr bndr2,
255 addFloat floats new_float) }
257 cpeBind top_lvl env (Rec pairs)
258 = do { let (bndrs,rhss) = unzip pairs
259 ; (env', bndrs1) <- cloneBndrs env (map fst pairs)
260 ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
262 ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
263 all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
264 (concatFloats floats_s)
265 ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
266 unitFloat (FloatLet (Rec all_pairs))) }
268 -- Flatten all the floats, and the currrent
269 -- group into a single giant Rec
270 add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
271 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
272 add_float b _ = pprPanic "cpeBind" (ppr b)
275 cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
276 -> CorePrepEnv -> Id -> CoreExpr
277 -> UniqSM (Floats, Id, CoreExpr)
278 -- Used for all bindings
279 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
280 = do { (floats1, rhs1) <- cpeRhsE env rhs
281 ; let (rhs1_bndrs, _) = collectBinders rhs1
283 <- if want_float floats1 rhs1
284 then return (floats1, rhs1)
285 else -- Non-empty floats will wrap rhs1
286 -- But: rhs1 might have lambdas, and we can't
287 -- put them inside a wrapBinds
288 if valBndrCount rhs1_bndrs <= arity
289 then -- Lambdas in rhs1 will be nuked by eta expansion
290 return (emptyFloats, wrapBinds floats1 rhs1)
292 else do { body1 <- rhsToBodyNF rhs1
293 ; return (emptyFloats, wrapBinds floats1 body1) }
295 ; (floats3, rhs') -- Note [Silly extra arguments]
296 <- if manifestArity rhs2 <= arity
297 then return (floats2, cpeEtaExpand arity rhs2)
298 else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
299 (do { v <- newVar (idType bndr)
300 ; let float = mkFloat False False v rhs2
301 ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
303 -- Record if the binder is evaluated
304 ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
307 ; return (floats3, bndr', rhs') }
309 arity = idArity bndr -- We must match this arity
310 want_float floats rhs
311 | isTopLevel top_lvl = wantFloatTop bndr floats
312 | otherwise = wantFloatNested is_rec is_strict_or_unlifted floats rhs
314 {- Note [Silly extra arguments]
315 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
318 We *must* match the arity on the Id, so we have to generate
322 It's a bizarre case: why is the arity on the Id wrong? Reason
323 (in the days of __inline_me__):
324 f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
325 When InlineMe notes go away this won't happen any more. But
326 it seems good for CorePrep to be robust.
329 -- ---------------------------------------------------------------------------
330 -- CpeRhs: produces a result satisfying CpeRhs
331 -- ---------------------------------------------------------------------------
333 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
337 -- e = let bs in e' (semantically, that is!)
340 -- f (g x) ===> ([v = g x], f v)
342 cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
343 cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
344 cpeRhsE env expr@(App {}) = cpeApp env expr
345 cpeRhsE env expr@(Var {}) = cpeApp env expr
347 cpeRhsE env (Let bind expr)
348 = do { (env', new_binds) <- cpeBind NotTopLevel env bind
349 ; (floats, body) <- cpeRhsE env' expr
350 ; return (new_binds `appendFloats` floats, body) }
352 cpeRhsE env (Note note expr)
355 | otherwise -- Just SCCs actually
356 = do { body <- cpeBodyNF env expr
357 ; return (emptyFloats, Note note body) }
359 cpeRhsE env (Cast expr co)
360 = do { (floats, expr') <- cpeRhsE env expr
361 ; return (floats, Cast expr' co) }
363 cpeRhsE env expr@(Lam {})
364 = do { let (bndrs,body) = collectBinders expr
365 ; (env', bndrs') <- cloneBndrs env bndrs
366 ; body' <- cpeBodyNF env' body
367 ; return (emptyFloats, mkLams bndrs' body') }
369 cpeRhsE env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
370 | Just (TickBox {}) <- isTickBoxOp_maybe id
371 = do { body <- cpeBodyNF env expr
372 ; return (emptyFloats, Case (Var id) bndr ty [(DEFAULT,[],body)]) }
374 cpeRhsE env (Case scrut bndr ty alts)
375 = do { (floats, scrut') <- cpeBody env scrut
376 ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
377 -- Record that the case binder is evaluated in the alternatives
378 ; (env', bndr2) <- cloneBndr env bndr1
379 ; alts' <- mapM (sat_alt env') alts
380 ; return (floats, Case scrut' bndr2 ty alts') }
382 sat_alt env (con, bs, rhs)
383 = do { (env2, bs') <- cloneBndrs env bs
384 ; rhs' <- cpeBodyNF env2 rhs
385 ; return (con, bs', rhs') }
387 -- ---------------------------------------------------------------------------
388 -- CpeBody: produces a result satisfying CpeBody
389 -- ---------------------------------------------------------------------------
391 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
393 = do { (floats, body) <- cpeBody env expr
394 ; return (wrapBinds floats body) }
397 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
399 = do { (floats1, rhs) <- cpeRhsE env expr
400 ; (floats2, body) <- rhsToBody rhs
401 ; return (floats1 `appendFloats` floats2, body) }
404 rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
405 rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
406 ; return (wrapBinds floats body) }
409 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
410 -- Remove top level lambdas by let-bindinig
412 rhsToBody (Note n expr)
413 -- You can get things like
414 -- case e of { p -> coerce t (\s -> ...) }
415 = do { (floats, expr') <- rhsToBody expr
416 ; return (floats, Note n expr') }
418 rhsToBody (Cast e co)
419 = do { (floats, e') <- rhsToBody e
420 ; return (floats, Cast e' co) }
422 rhsToBody expr@(Lam {})
423 | Just no_lam_result <- tryEtaReduce bndrs body
424 = return (emptyFloats, no_lam_result)
425 | all isTyVar bndrs -- Type lambdas are ok
426 = return (emptyFloats, expr)
427 | otherwise -- Some value lambdas
428 = do { fn <- newVar (exprType expr)
429 ; let rhs = cpeEtaExpand (exprArity expr) expr
430 float = FloatLet (NonRec fn rhs)
431 ; return (unitFloat float, Var fn) }
433 (bndrs,body) = collectBinders expr
435 rhsToBody expr = return (emptyFloats, expr)
439 -- ---------------------------------------------------------------------------
440 -- CpeApp: produces a result satisfying CpeApp
441 -- ---------------------------------------------------------------------------
443 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
444 -- May return a CpeRhs because of saturating primops
446 = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
447 ; MASSERT(null ss) -- make sure we used all the strictness info
449 -- Now deal with the function
451 Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
452 ; return (floats, sat_app) }
453 _other -> return (floats, app) }
456 -- Deconstruct and rebuild the application, floating any non-atomic
457 -- arguments to the outside. We collect the type of the expression,
458 -- the head of the application, and the number of actual value arguments,
459 -- all of which are used to possibly saturate this application if it
460 -- has a constructor or primop at the head.
464 -> Int -- Current app depth
465 -> UniqSM (CpeApp, -- The rebuilt expression
466 (CoreExpr,Int), -- The head of the application,
467 -- and no. of args it was applied to
468 Type, -- Type of the whole expr
469 Floats, -- Any floats we pulled out
470 [Demand]) -- Remaining argument demands
472 collect_args (App fun arg@(Type arg_ty)) depth
473 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
474 ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
476 collect_args (App fun arg) depth
477 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
479 (ss1, ss_rest) = case ss of
480 (ss1:ss_rest) -> (ss1, ss_rest)
482 (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
483 splitFunTy_maybe fun_ty
485 ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty
486 ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
488 collect_args (Var v) depth
489 = do { v1 <- fiddleCCall v
490 ; let v2 = lookupCorePrepEnv env v1
491 ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
493 stricts = case idNewStrictness v of
494 StrictSig (DmdType _ demands _)
495 | listLengthCmp demands depth /= GT -> demands
496 -- length demands <= depth
498 -- If depth < length demands, then we have too few args to
499 -- satisfy strictness info so we have to ignore all the
500 -- strictness info, e.g. + (error "urk")
501 -- Here, we can't evaluate the arg strictly, because this
502 -- partial application might be seq'd
504 collect_args (Cast fun co) depth
505 = do { let (_ty1,ty2) = coercionKind co
506 ; (fun', hd, _, floats, ss) <- collect_args fun depth
507 ; return (Cast fun' co, hd, ty2, floats, ss) }
509 collect_args (Note note fun) depth
510 | ignoreNote note -- Drop these notes altogether
511 = collect_args fun depth -- They aren't used by the code generator
513 -- N-variable fun, better let-bind it
514 -- ToDo: perhaps we can case-bind rather than let-bind this closure,
515 -- since it is sure to be evaluated.
516 collect_args fun depth
517 = do { (fun_floats, fun') <- cpeArg env True fun ty
518 ; return (fun', (fun', depth), ty, fun_floats, []) }
522 -- ---------------------------------------------------------------------------
523 -- CpeArg: produces a result satisfying CpeArg
524 -- ---------------------------------------------------------------------------
526 -- This is where we arrange that a non-trivial argument is let-bound
527 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
528 -> UniqSM (Floats, CpeTriv)
529 cpeArg env is_strict arg arg_ty
530 | cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument
531 = cpeBody env arg -- Must still do substitution though
533 = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
534 ; (floats2, arg2) <- if want_float floats1 arg1
535 then return (floats1, arg1)
536 else do { body1 <- rhsToBodyNF arg1
537 ; return (emptyFloats, wrapBinds floats1 body1) }
538 -- Else case: arg1 might have lambdas, and we can't
539 -- put them inside a wrapBinds
542 ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
543 arg_float = mkFloat is_strict is_unlifted v arg3
544 ; return (addFloat floats2 arg_float, Var v) }
546 is_unlifted = isUnLiftedType arg_ty
547 want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
550 Note [Floating unlifted arguments]
551 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
552 Consider C (let v* = expensive in v)
554 where the "*" indicates "will be demanded". Usually v will have been
555 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
558 let v* = expensive in C v
560 because that has different strictness. Hence the use of 'allLazy'.
561 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
564 ------------------------------------------------------------------------------
565 -- Building the saturated syntax
566 -- ---------------------------------------------------------------------------
568 maybeSaturate deals with saturating primops and constructors
569 The type is the type of the entire application
572 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
573 maybeSaturate fn expr n_args
574 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
575 -- A gruesome special case
576 = saturateDataToTag sat_expr
578 | hasNoBinding fn -- There's no binding
584 fn_arity = idArity fn
585 excess_arity = fn_arity - n_args
586 sat_expr = cpeEtaExpand excess_arity expr
589 saturateDataToTag :: CpeApp -> UniqSM CpeApp
590 -- Horrid: ensure that the arg of data2TagOp is evaluated
591 -- (data2tag x) --> (case x of y -> data2tag y)
592 -- (yuk yuk) take into account the lambdas we've now introduced
593 saturateDataToTag sat_expr
594 = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
595 ; eta_body' <- eval_data2tag_arg eta_body
596 ; return (mkLams eta_bndrs eta_body') }
598 eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
599 eval_data2tag_arg app@(fun `App` arg)
600 | exprIsHNF arg -- Includes nullary constructors
601 = return app -- The arg is evaluated
602 | otherwise -- Arg not evaluated, so evaluate it
603 = do { arg_id <- newVar (exprType arg)
604 ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
605 ; return (Case arg arg_id1 (exprType app)
606 [(DEFAULT, [], fun `App` Var arg_id1)]) }
608 eval_data2tag_arg (Note note app) -- Scc notes can appear
609 = do { app' <- eval_data2tag_arg app
610 ; return (Note note app') }
612 eval_data2tag_arg other -- Should not happen
613 = pprPanic "eval_data2tag" (ppr other)
619 %************************************************************************
621 Simple CoreSyn operations
623 %************************************************************************
626 -- We don't ignore SCCs, since they require some code generation
627 ignoreNote :: Note -> Bool
628 -- Tells which notes to drop altogether; they are ignored by code generation
629 -- Do not ignore SCCs!
630 -- It's important that we do drop InlineMe notes; for example
631 -- unzip = __inline_me__ (/\ab. foldr (..) (..))
632 -- Here unzip gets arity 1 so we'll eta-expand it. But we don't
634 -- unzip = /\ab \xs. (__inline_me__ ...) a b xs
635 ignoreNote (CoreNote _) = True
636 ignoreNote InlineMe = True
637 ignoreNote _other = False
640 cpe_ExprIsTrivial :: CoreExpr -> Bool
641 -- Version that doesn't consider an scc annotation to be trivial.
642 cpe_ExprIsTrivial (Var _) = True
643 cpe_ExprIsTrivial (Type _) = True
644 cpe_ExprIsTrivial (Lit _) = True
645 cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
646 cpe_ExprIsTrivial (Note (SCC _) _) = False
647 cpe_ExprIsTrivial (Note _ e) = cpe_ExprIsTrivial e
648 cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
649 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
650 cpe_ExprIsTrivial _ = False
653 -- -----------------------------------------------------------------------------
655 -- -----------------------------------------------------------------------------
658 ~~~~~~~~~~~~~~~~~~~~~
659 Eta expand to match the arity claimed by the binder Remember,
660 CorePrep must not change arity
662 Eta expansion might not have happened already, because it is done by
663 the simplifier only when there at least one lambda already.
665 NB1:we could refrain when the RHS is trivial (which can happen
666 for exported things). This would reduce the amount of code
667 generated (a little) and make things a little words for
668 code compiled without -O. The case in point is data constructor
671 NB2: we have to be careful that the result of etaExpand doesn't
672 invalidate any of the assumptions that CorePrep is attempting
673 to establish. One possible cause is eta expanding inside of
674 an SCC note - we're now careful in etaExpand to make sure the
675 SCC is pushed inside any new lambdas that are generated.
677 Note [Eta expansion and the CorePrep invariants]
678 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
679 It turns out to be much much easier to do eta expansion
680 *after* the main CorePrep stuff. But that places constraints
681 on the eta expander: given a CpeRhs, it must return a CpeRhs.
683 For example here is what we do not want:
684 f = /\a -> g (h 3) -- h has arity 2
686 f = /\a -> let s = h 3 in g s
687 and now we do NOT want eta expansion to give
688 f = /\a -> \ y -> (let s = h 3 in g s) y
690 Instead CoreArity.etaExpand gives
691 f = /\a -> \y -> let s = h 3 in g s y
694 cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr
695 cpeEtaExpand arity expr
697 | otherwise = etaExpand arity expr
700 -- -----------------------------------------------------------------------------
702 -- -----------------------------------------------------------------------------
704 Why try eta reduction? Hasn't the simplifier already done eta?
705 But the simplifier only eta reduces if that leaves something
706 trivial (like f, or f Int). But for deLam it would be enough to
707 get to a partial application:
708 case x of { p -> \xs. map f xs }
709 ==> case x of { p -> map f }
712 tryEtaReduce :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
713 tryEtaReduce bndrs expr@(App _ _)
714 | ok_to_eta_reduce f &&
716 and (zipWith ok bndrs last_args) &&
717 not (any (`elemVarSet` fvs_remaining) bndrs)
718 = Just remaining_expr
720 (f, args) = collectArgs expr
721 remaining_expr = mkApps f remaining_args
722 fvs_remaining = exprFreeVars remaining_expr
723 (remaining_args, last_args) = splitAt n_remaining args
724 n_remaining = length args - length bndrs
726 ok bndr (Var arg) = bndr == arg
729 -- we can't eta reduce something which must be saturated.
730 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
731 ok_to_eta_reduce _ = False --safe. ToDo: generalise
733 tryEtaReduce bndrs (Let bind@(NonRec _ r) body)
734 | not (any (`elemVarSet` fvs) bndrs)
735 = case tryEtaReduce bndrs body of
736 Just e -> Just (Let bind e)
741 tryEtaReduce _ _ = Nothing
745 -- -----------------------------------------------------------------------------
747 -- -----------------------------------------------------------------------------
750 type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recursive
753 %************************************************************************
757 %************************************************************************
761 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
762 | FloatCase Id CpeBody Bool -- The bool indicates "ok-for-speculation"
764 data Floats = Floats OkToSpec (OrdList FloatingBind)
766 -- Can we float these binds out of the rhs of a let? We cache this decision
767 -- to avoid having to recompute it in a non-linear way when there are
768 -- deeply nested lets.
770 = NotOkToSpec -- definitely not
772 | IfUnboxedOk -- only if floating an unboxed binding is ok
774 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
775 mkFloat is_strict is_unlifted bndr rhs
776 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
777 | otherwise = FloatLet (NonRec bndr rhs)
779 use_case = is_unlifted || is_strict && not (exprIsHNF rhs)
780 -- Don't make a case for a value binding,
781 -- even if it's strict. Otherwise we get
782 -- case (\x -> e) of ...!
784 emptyFloats :: Floats
785 emptyFloats = Floats OkToSpec nilOL
787 isEmptyFloats :: Floats -> Bool
788 isEmptyFloats (Floats _ bs) = isNilOL bs
790 wrapBinds :: Floats -> CoreExpr -> CoreExpr
791 wrapBinds (Floats _ binds) body
792 = foldrOL mk_bind body binds
794 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
795 mk_bind (FloatLet bind) body = Let bind body
797 addFloat :: Floats -> FloatingBind -> Floats
798 addFloat (Floats ok_to_spec floats) new_float
799 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
801 check (FloatLet _) = OkToSpec
802 check (FloatCase _ _ ok_for_spec)
803 | ok_for_spec = IfUnboxedOk
804 | otherwise = NotOkToSpec
805 -- The ok-for-speculation flag says that it's safe to
806 -- float this Case out of a let, and thereby do it more eagerly
807 -- We need the top-level flag because it's never ok to float
808 -- an unboxed binding to the top level
810 unitFloat :: FloatingBind -> Floats
811 unitFloat = addFloat emptyFloats
813 appendFloats :: Floats -> Floats -> Floats
814 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
815 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
817 concatFloats :: [Floats] -> OrdList FloatingBind
818 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
820 combine :: OkToSpec -> OkToSpec -> OkToSpec
821 combine NotOkToSpec _ = NotOkToSpec
822 combine _ NotOkToSpec = NotOkToSpec
823 combine IfUnboxedOk _ = IfUnboxedOk
824 combine _ IfUnboxedOk = IfUnboxedOk
825 combine _ _ = OkToSpec
827 instance Outputable FloatingBind where
828 ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
829 ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
831 deFloatTop :: Floats -> [CoreBind]
832 -- For top level only; we don't expect any FloatCases
833 deFloatTop (Floats _ floats)
834 = foldrOL get [] floats
836 get (FloatLet b) bs = b:bs
837 get b _ = pprPanic "corePrepPgm" (ppr b)
839 -------------------------------------------
840 wantFloatTop :: Id -> Floats -> Bool
841 -- Note [CafInfo and floating]
842 wantFloatTop bndr floats = isEmptyFloats floats
843 || (mayHaveCafRefs (idCafInfo bndr)
844 && allLazyTop floats)
846 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
847 wantFloatNested is_rec strict_or_unlifted floats rhs
848 = isEmptyFloats floats
849 || strict_or_unlifted
850 || (allLazyNested is_rec floats && exprIsHNF rhs)
851 -- Why the test for allLazyNested?
852 -- v = f (x `divInt#` y)
853 -- we don't want to float the case, even if f has arity 2,
854 -- because floating the case would make it evaluated too early
856 allLazyTop :: Floats -> Bool
857 allLazyTop (Floats OkToSpec _) = True
860 allLazyNested :: RecFlag -> Floats -> Bool
861 allLazyNested _ (Floats OkToSpec _) = True
862 allLazyNested _ (Floats NotOkToSpec _) = False
863 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
867 %************************************************************************
871 %************************************************************************
874 -- ---------------------------------------------------------------------------
876 -- ---------------------------------------------------------------------------
878 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
880 emptyCorePrepEnv :: CorePrepEnv
881 emptyCorePrepEnv = CPE emptyVarEnv
883 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
884 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
886 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
887 extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs)
889 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
890 lookupCorePrepEnv (CPE env) id
891 = case lookupVarEnv env id of
895 ------------------------------------------------------------------------------
897 -- ---------------------------------------------------------------------------
899 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
900 cloneBndrs env bs = mapAccumLM cloneBndr env bs
902 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
905 = do bndr' <- setVarUnique bndr <$> getUniqueM
906 return (extendCorePrepEnv env bndr bndr', bndr')
908 | otherwise -- Top level things, which we don't want
909 -- to clone, have become GlobalIds by now
910 -- And we don't clone tyvars
914 ------------------------------------------------------------------------------
915 -- Cloning ccall Ids; each must have a unique name,
916 -- to give the code generator a handle to hang it on
917 -- ---------------------------------------------------------------------------
919 fiddleCCall :: Id -> UniqSM Id
921 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
922 | otherwise = return id
924 ------------------------------------------------------------------------------
925 -- Generating new binders
926 -- ---------------------------------------------------------------------------
928 newVar :: Type -> UniqSM Id
930 = seqType ty `seq` do
932 return (mkSysLocal (fsLit "sat") uniq ty)