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(..) )
21 import OccurAnal ( occurAnalyseExpr )
44 import Data.List ( mapAccumL )
48 -- ---------------------------------------------------------------------------
50 -- ---------------------------------------------------------------------------
52 The goal of this pass is to prepare for code generation.
54 1. Saturate constructor and primop applications.
56 2. Convert to A-normal form; that is, function arguments
59 * Use case for strict arguments:
60 f E ==> case E of x -> f x
63 * Use let for non-trivial lazy arguments
64 f E ==> let x = E in f x
65 (were f is lazy and x is non-trivial)
67 3. Similarly, convert any unboxed lets into cases.
68 [I'm experimenting with leaving 'ok-for-speculation'
69 rhss in let-form right up to this point.]
71 4. Ensure that *value* lambdas only occur as the RHS of a binding
72 (The code generator can't deal with anything else.)
73 Type lambdas are ok, however, because the code gen discards them.
75 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
77 6. Clone all local Ids.
78 This means that all such Ids are unique, rather than the
79 weaker guarantee of no clashes which the simplifier provides.
80 And that is what the code generator needs.
82 We don't clone TyVars or CoVars. The code gen doesn't need that,
83 and doing so would be tiresome because then we'd need
84 to substitute in types and coercions.
87 7. Give each dynamic CCall occurrence a fresh unique; this is
88 rather like the cloning step above.
90 8. Inject bindings for the "implicit" Ids:
91 * Constructor wrappers
93 We want curried definitions for all of these in case they
94 aren't inlined by some caller.
96 9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs
98 This is all done modulo type applications and abstractions, so that
99 when type erasure is done for conversion to STG, we don't end up with
100 any trivial or useless bindings.
105 Here is the syntax of the Core produced by CorePrep:
109 | triv ty | /\a. triv
110 | truv co | /\c. triv | triv |> co
113 app ::= lit | var | app triv | app ty | app co | app |> co
117 | let(rec) x = rhs in body -- Boxed only
118 | case body of pat -> body
119 | /\a. body | /\c. body
122 Right hand sides (only place where value lambdas can occur)
123 rhs ::= /\a.rhs | \x.rhs | body
125 We define a synonym for each of these non-terminals. Functions
126 with the corresponding name produce a result in that syntax.
129 type CpeTriv = CoreExpr -- Non-terminal 'triv'
130 type CpeApp = CoreExpr -- Non-terminal 'app'
131 type CpeBody = CoreExpr -- Non-terminal 'body'
132 type CpeRhs = CoreExpr -- Non-terminal 'rhs'
135 %************************************************************************
139 %************************************************************************
142 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
143 corePrepPgm dflags binds data_tycons = do
144 showPass dflags "CorePrep"
145 us <- mkSplitUniqSupply 's'
147 let implicit_binds = mkDataConWorkers data_tycons
148 -- NB: we must feed mkImplicitBinds through corePrep too
149 -- so that they are suitably cloned and eta-expanded
151 binds_out = initUs_ us $ do
152 floats1 <- corePrepTopBinds binds
153 floats2 <- corePrepTopBinds implicit_binds
154 return (deFloatTop (floats1 `appendFloats` floats2))
156 endPass dflags CorePrep binds_out []
159 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
160 corePrepExpr dflags expr = do
161 showPass dflags "CorePrep"
162 us <- mkSplitUniqSupply 's'
163 let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr)
164 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
167 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
168 -- Note [Floating out of top level bindings]
169 corePrepTopBinds binds
170 = go emptyCorePrepEnv binds
172 go _ [] = return emptyFloats
173 go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
174 binds' <- go env' binds
175 return (bind' `appendFloats` binds')
177 mkDataConWorkers :: [TyCon] -> [CoreBind]
178 -- See Note [Data constructor workers]
179 mkDataConWorkers data_tycons
180 = [ NonRec id (Var id) -- The ice is thin here, but it works
181 | tycon <- data_tycons, -- CorePrep will eta-expand it
182 data_con <- tyConDataCons tycon,
183 let id = dataConWorkId data_con ]
186 Note [Floating out of top level bindings]
187 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
188 NB: we do need to float out of top-level bindings
189 Consider x = length [True,False]
195 We return a *list* of bindings, because we may start with
197 where x is demanded, in which case we want to finish with
200 And then x will actually end up case-bound
202 Note [CafInfo and floating]
203 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
204 What happens when we try to float bindings to the top level? At this
205 point all the CafInfo is supposed to be correct, and we must make certain
206 that is true of the new top-level bindings. There are two cases
209 a) The top-level binding is marked asCafRefs. In that case we are
210 basically fine. The floated bindings had better all be lazy lets,
211 so they can float to top level, but they'll all have HasCafRefs
212 (the default) which is safe.
214 b) The top-level binding is marked NoCafRefs. This really happens
215 Example. CoreTidy produces
216 $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...
217 Now CorePrep has to eta-expand to
218 $fApplicativeSTM = let sat = \xy. retry x y
219 in D:Alternative sat ...blah...
221 sat [NoCafRefs] = \xy. retry x y
222 $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...
224 So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
225 *and* substutite the modified 'sat' into the old RHS.
227 It should be the case that 'sat' is itself [NoCafRefs] (a value, no
228 cafs) else the original top-level binding would not itself have been
229 marked [NoCafRefs]. The DEBUG check in CoreToStg for
230 consistentCafInfo will find this.
232 This is all very gruesome and horrible. It would be better to figure
233 out CafInfo later, after CorePrep. We'll do that in due course.
234 Meanwhile this horrible hack works.
237 Note [Data constructor workers]
238 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
239 Create any necessary "implicit" bindings for data con workers. We
240 create the rather strange (non-recursive!) binding
242 $wC = \x y -> $wC x y
244 i.e. a curried constructor that allocates. This means that we can
245 treat the worker for a constructor like any other function in the rest
246 of the compiler. The point here is that CoreToStg will generate a
247 StgConApp for the RHS, rather than a call to the worker (which would
248 give a loop). As Lennart says: the ice is thin here, but it works.
250 Hmm. Should we create bindings for dictionary constructors? They are
251 always fully applied, and the bindings are just there to support
252 partial applications. But it's easier to let them through.
255 Note [Dead code in CorePrep]
256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
257 Imagine that we got an input program like this:
259 f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
260 f x = (g True (Just x) + g () (Just x), g)
262 g :: Show a => a -> Maybe Int -> Int
264 g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
266 After specialisation and SpecConstr, we would get something like this:
268 f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
269 f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
271 {-# RULES g $dBool = g$Bool
272 g $dUnit = g$Unit #-}
274 {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
276 {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
278 g$Bool_True_Just = ...
279 g$Unit_Unit_Just = ...
281 Note that the g$Bool and g$Unit functions are actually dead code: they are only kept
282 alive by the occurrence analyser because they are referred to by the rules of g,
283 which is being kept alive by the fact that it is used (unspecialised) in the returned pair.
285 However, at the CorePrep stage there is no way that the rules for g will ever fire,
286 and it really seems like a shame to produce an output program that goes to the trouble
287 of allocating a closure for the unreachable g$Bool and g$Unit functions.
289 The way we fix this is to:
290 * In cloneBndr, drop all unfoldings/rules
291 * In deFloatTop, run the occurrence analyser on each top-level RHS to drop
292 the dead local bindings
294 The reason we don't just OccAnal the whole output of CorePrep is that the tidier
295 ensures that all top-level binders are GlobalIds, so they don't show up in the free
296 variables any longer. So if you run the occurrence analyser on the output of CoreTidy
297 (or later) you e.g. turn this program:
307 (Since f is not considered to be free in its own RHS.)
310 %************************************************************************
314 %************************************************************************
317 cpeBind :: TopLevelFlag
318 -> CorePrepEnv -> CoreBind
319 -> UniqSM (CorePrepEnv, Floats)
320 cpeBind top_lvl env (NonRec bndr rhs)
321 = do { (_, bndr1) <- cloneBndr env bndr
322 ; let is_strict = isStrictDmd (idDemandInfo bndr)
323 is_unlifted = isUnLiftedType (idType bndr)
324 ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
325 (is_strict || is_unlifted)
327 ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2
329 -- We want bndr'' in the envt, because it records
330 -- the evaluated-ness of the binder
331 ; return (extendCorePrepEnv env bndr bndr2,
332 addFloat floats new_float) }
334 cpeBind top_lvl env (Rec pairs)
335 = do { let (bndrs,rhss) = unzip pairs
336 ; (env', bndrs1) <- cloneBndrs env (map fst pairs)
337 ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
339 ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
340 all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
341 (concatFloats floats_s)
342 ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
343 unitFloat (FloatLet (Rec all_pairs))) }
345 -- Flatten all the floats, and the currrent
346 -- group into a single giant Rec
347 add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
348 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
349 add_float b _ = pprPanic "cpeBind" (ppr b)
352 cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
353 -> CorePrepEnv -> Id -> CoreExpr
354 -> UniqSM (Floats, Id, CpeRhs)
355 -- Used for all bindings
356 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
357 = do { (floats1, rhs1) <- cpeRhsE env rhs
359 -- See if we are allowed to float this stuff out of the RHS
360 ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
362 -- Make the arity match up
364 <- if manifestArity rhs1 <= arity
365 then return (floats2, cpeEtaExpand arity rhs2)
366 else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
367 -- Note [Silly extra arguments]
368 (do { v <- newVar (idType bndr)
369 ; let float = mkFloat False False v rhs2
370 ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
372 -- Record if the binder is evaluated
373 -- and otherwise trim off the unfolding altogether
374 -- It's not used by the code generator; getting rid of it reduces
375 -- heap usage and, since we may be changing uniques, we'd have
376 -- to substitute to keep it right
377 ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
378 | otherwise = bndr `setIdUnfolding` noUnfolding
380 ; return (floats3, bndr', rhs') }
382 arity = idArity bndr -- We must match this arity
384 ---------------------
385 float_from_rhs floats rhs
386 | isEmptyFloats floats = return (emptyFloats, rhs)
387 | isTopLevel top_lvl = float_top floats rhs
388 | otherwise = float_nested floats rhs
390 ---------------------
391 float_nested floats rhs
392 | wantFloatNested is_rec is_strict_or_unlifted floats rhs
393 = return (floats, rhs)
394 | otherwise = dont_float floats rhs
396 ---------------------
397 float_top floats rhs -- Urhgh! See Note [CafInfo and floating]
398 | mayHaveCafRefs (idCafInfo bndr)
400 = return (floats, rhs)
402 -- So the top-level binding is marked NoCafRefs
403 | Just (floats', rhs') <- canFloatFromNoCaf floats rhs
404 = return (floats', rhs')
407 = dont_float floats rhs
409 ---------------------
410 dont_float floats rhs
411 -- Non-empty floats, but do not want to float from rhs
412 -- So wrap the rhs in the floats
413 -- But: rhs1 might have lambdas, and we can't
414 -- put them inside a wrapBinds
415 = do { body <- rhsToBodyNF rhs
416 ; return (emptyFloats, wrapBinds floats body) }
418 {- Note [Silly extra arguments]
419 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
422 We *must* match the arity on the Id, so we have to generate
426 It's a bizarre case: why is the arity on the Id wrong? Reason
427 (in the days of __inline_me__):
428 f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
429 When InlineMe notes go away this won't happen any more. But
430 it seems good for CorePrep to be robust.
433 -- ---------------------------------------------------------------------------
434 -- CpeRhs: produces a result satisfying CpeRhs
435 -- ---------------------------------------------------------------------------
437 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
441 -- e = let bs in e' (semantically, that is!)
444 -- f (g x) ===> ([v = g x], f v)
446 cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
447 cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
448 cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
449 cpeRhsE env expr@(Var {}) = cpeApp env expr
451 cpeRhsE env (Var f `App` _ `App` arg)
452 | f `hasKey` lazyIdKey -- Replace (lazy a) by a
453 = cpeRhsE env arg -- See Note [lazyId magic] in MkId
455 cpeRhsE env expr@(App {}) = cpeApp env expr
457 cpeRhsE env (Let bind expr)
458 = do { (env', new_binds) <- cpeBind NotTopLevel env bind
459 ; (floats, body) <- cpeRhsE env' expr
460 ; return (new_binds `appendFloats` floats, body) }
462 cpeRhsE env (Note note expr)
465 | otherwise -- Just SCCs actually
466 = do { body <- cpeBodyNF env expr
467 ; return (emptyFloats, Note note body) }
469 cpeRhsE env (Cast expr co)
470 = do { (floats, expr') <- cpeRhsE env expr
471 ; return (floats, Cast expr' co) }
473 cpeRhsE env expr@(Lam {})
474 = do { let (bndrs,body) = collectBinders expr
475 ; (env', bndrs') <- cloneBndrs env bndrs
476 ; body' <- cpeBodyNF env' body
477 ; return (emptyFloats, mkLams bndrs' body') }
479 cpeRhsE env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
480 | Just (TickBox {}) <- isTickBoxOp_maybe id
481 = do { body <- cpeBodyNF env expr
482 ; return (emptyFloats, Case (Var id) bndr ty [(DEFAULT,[],body)]) }
484 cpeRhsE env (Case scrut bndr ty alts)
485 = do { (floats, scrut') <- cpeBody env scrut
486 ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
487 -- Record that the case binder is evaluated in the alternatives
488 ; (env', bndr2) <- cloneBndr env bndr1
489 ; alts' <- mapM (sat_alt env') alts
490 ; return (floats, Case scrut' bndr2 ty alts') }
492 sat_alt env (con, bs, rhs)
493 = do { (env2, bs') <- cloneBndrs env bs
494 ; rhs' <- cpeBodyNF env2 rhs
495 ; return (con, bs', rhs') }
497 -- ---------------------------------------------------------------------------
498 -- CpeBody: produces a result satisfying CpeBody
499 -- ---------------------------------------------------------------------------
501 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
503 = do { (floats, body) <- cpeBody env expr
504 ; return (wrapBinds floats body) }
507 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
509 = do { (floats1, rhs) <- cpeRhsE env expr
510 ; (floats2, body) <- rhsToBody rhs
511 ; return (floats1 `appendFloats` floats2, body) }
514 rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
515 rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
516 ; return (wrapBinds floats body) }
519 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
520 -- Remove top level lambdas by let-binding
522 rhsToBody (Note n expr)
523 -- You can get things like
524 -- case e of { p -> coerce t (\s -> ...) }
525 = do { (floats, expr') <- rhsToBody expr
526 ; return (floats, Note n expr') }
528 rhsToBody (Cast e co)
529 = do { (floats, e') <- rhsToBody e
530 ; return (floats, Cast e' co) }
532 rhsToBody expr@(Lam {})
533 | Just no_lam_result <- tryEtaReducePrep bndrs body
534 = return (emptyFloats, no_lam_result)
535 | all isTyVar bndrs -- Type lambdas are ok
536 = return (emptyFloats, expr)
537 | otherwise -- Some value lambdas
538 = do { fn <- newVar (exprType expr)
539 ; let rhs = cpeEtaExpand (exprArity expr) expr
540 float = FloatLet (NonRec fn rhs)
541 ; return (unitFloat float, Var fn) }
543 (bndrs,body) = collectBinders expr
545 rhsToBody expr = return (emptyFloats, expr)
549 -- ---------------------------------------------------------------------------
550 -- CpeApp: produces a result satisfying CpeApp
551 -- ---------------------------------------------------------------------------
553 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
554 -- May return a CpeRhs because of saturating primops
556 = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
557 ; MASSERT(null ss) -- make sure we used all the strictness info
559 -- Now deal with the function
561 Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
562 ; return (floats, sat_app) }
563 _other -> return (floats, app) }
566 -- Deconstruct and rebuild the application, floating any non-atomic
567 -- arguments to the outside. We collect the type of the expression,
568 -- the head of the application, and the number of actual value arguments,
569 -- all of which are used to possibly saturate this application if it
570 -- has a constructor or primop at the head.
574 -> Int -- Current app depth
575 -> UniqSM (CpeApp, -- The rebuilt expression
576 (CoreExpr,Int), -- The head of the application,
577 -- and no. of args it was applied to
578 Type, -- Type of the whole expr
579 Floats, -- Any floats we pulled out
580 [Demand]) -- Remaining argument demands
582 collect_args (App fun arg@(Type arg_ty)) depth
583 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
584 ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
586 collect_args (App fun arg@(Coercion arg_co)) depth
587 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
588 ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
590 collect_args (App fun arg) depth
591 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
593 (ss1, ss_rest) = case ss of
594 (ss1:ss_rest) -> (ss1, ss_rest)
596 (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
597 splitFunTy_maybe fun_ty
599 ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty
600 ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
602 collect_args (Var v) depth
603 = do { v1 <- fiddleCCall v
604 ; let v2 = lookupCorePrepEnv env v1
605 ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
607 stricts = case idStrictness v of
608 StrictSig (DmdType _ demands _)
609 | listLengthCmp demands depth /= GT -> demands
610 -- length demands <= depth
612 -- If depth < length demands, then we have too few args to
613 -- satisfy strictness info so we have to ignore all the
614 -- strictness info, e.g. + (error "urk")
615 -- Here, we can't evaluate the arg strictly, because this
616 -- partial application might be seq'd
618 collect_args (Cast fun co) depth
619 = do { let Pair _ty1 ty2 = coercionKind co
620 ; (fun', hd, _, floats, ss) <- collect_args fun depth
621 ; return (Cast fun' co, hd, ty2, floats, ss) }
623 collect_args (Note note fun) depth
624 | ignoreNote note -- Drop these notes altogether
625 = collect_args fun depth -- They aren't used by the code generator
627 -- N-variable fun, better let-bind it
628 collect_args fun depth
629 = do { (fun_floats, fun') <- cpeArg env True fun ty
630 -- The True says that it's sure to be evaluated,
631 -- so we'll end up case-binding it
632 ; return (fun', (fun', depth), ty, fun_floats, []) }
636 -- ---------------------------------------------------------------------------
637 -- CpeArg: produces a result satisfying CpeArg
638 -- ---------------------------------------------------------------------------
640 -- This is where we arrange that a non-trivial argument is let-bound
641 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
642 -> UniqSM (Floats, CpeTriv)
643 cpeArg env is_strict arg arg_ty
644 = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
645 ; (floats2, arg2) <- if want_float floats1 arg1
646 then return (floats1, arg1)
647 else do { body1 <- rhsToBodyNF arg1
648 ; return (emptyFloats, wrapBinds floats1 body1) }
649 -- Else case: arg1 might have lambdas, and we can't
650 -- put them inside a wrapBinds
652 ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument
653 then return (floats2, arg2)
656 ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
657 arg_float = mkFloat is_strict is_unlifted v arg3
658 ; return (addFloat floats2 arg_float, Var v) } }
660 is_unlifted = isUnLiftedType arg_ty
661 want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
664 Note [Floating unlifted arguments]
665 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
666 Consider C (let v* = expensive in v)
668 where the "*" indicates "will be demanded". Usually v will have been
669 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
672 let v* = expensive in C v
674 because that has different strictness. Hence the use of 'allLazy'.
675 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
678 ------------------------------------------------------------------------------
679 -- Building the saturated syntax
680 -- ---------------------------------------------------------------------------
682 maybeSaturate deals with saturating primops and constructors
683 The type is the type of the entire application
686 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
687 maybeSaturate fn expr n_args
688 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
689 -- A gruesome special case
690 = saturateDataToTag sat_expr
692 | hasNoBinding fn -- There's no binding
698 fn_arity = idArity fn
699 excess_arity = fn_arity - n_args
700 sat_expr = cpeEtaExpand excess_arity expr
703 saturateDataToTag :: CpeApp -> UniqSM CpeApp
704 -- See Note [dataToTag magic]
705 saturateDataToTag sat_expr
706 = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
707 ; eta_body' <- eval_data2tag_arg eta_body
708 ; return (mkLams eta_bndrs eta_body') }
710 eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
711 eval_data2tag_arg app@(fun `App` arg)
712 | exprIsHNF arg -- Includes nullary constructors
713 = return app -- The arg is evaluated
714 | otherwise -- Arg not evaluated, so evaluate it
715 = do { arg_id <- newVar (exprType arg)
716 ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
717 ; return (Case arg arg_id1 (exprType app)
718 [(DEFAULT, [], fun `App` Var arg_id1)]) }
720 eval_data2tag_arg (Note note app) -- Scc notes can appear
721 = do { app' <- eval_data2tag_arg app
722 ; return (Note note app') }
724 eval_data2tag_arg other -- Should not happen
725 = pprPanic "eval_data2tag" (ppr other)
728 Note [dataToTag magic]
729 ~~~~~~~~~~~~~~~~~~~~~~
730 Horrid: we must ensure that the arg of data2TagOp is evaluated
731 (data2tag x) --> (case x of y -> data2tag y)
732 (yuk yuk) take into account the lambdas we've now introduced
734 How might it not be evaluated? Well, we might have floated it out
735 of the scope of a `seq`, or dropped the `seq` altogether.
738 %************************************************************************
740 Simple CoreSyn operations
742 %************************************************************************
745 -- We don't ignore SCCs, since they require some code generation
746 ignoreNote :: Note -> Bool
747 -- Tells which notes to drop altogether; they are ignored by code generation
748 -- Do not ignore SCCs!
749 -- It's important that we do drop InlineMe notes; for example
750 -- unzip = __inline_me__ (/\ab. foldr (..) (..))
751 -- Here unzip gets arity 1 so we'll eta-expand it. But we don't
753 -- unzip = /\ab \xs. (__inline_me__ ...) a b xs
754 ignoreNote (CoreNote _) = True
755 ignoreNote _other = False
758 cpe_ExprIsTrivial :: CoreExpr -> Bool
759 -- Version that doesn't consider an scc annotation to be trivial.
760 cpe_ExprIsTrivial (Var _) = True
761 cpe_ExprIsTrivial (Type _) = True
762 cpe_ExprIsTrivial (Coercion _) = True
763 cpe_ExprIsTrivial (Lit _) = True
764 cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
765 cpe_ExprIsTrivial (Note n e) = notSccNote n && cpe_ExprIsTrivial e
766 cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
767 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
768 cpe_ExprIsTrivial _ = False
771 -- -----------------------------------------------------------------------------
773 -- -----------------------------------------------------------------------------
776 ~~~~~~~~~~~~~~~~~~~~~
777 Eta expand to match the arity claimed by the binder Remember,
778 CorePrep must not change arity
780 Eta expansion might not have happened already, because it is done by
781 the simplifier only when there at least one lambda already.
783 NB1:we could refrain when the RHS is trivial (which can happen
784 for exported things). This would reduce the amount of code
785 generated (a little) and make things a little words for
786 code compiled without -O. The case in point is data constructor
789 NB2: we have to be careful that the result of etaExpand doesn't
790 invalidate any of the assumptions that CorePrep is attempting
791 to establish. One possible cause is eta expanding inside of
792 an SCC note - we're now careful in etaExpand to make sure the
793 SCC is pushed inside any new lambdas that are generated.
795 Note [Eta expansion and the CorePrep invariants]
796 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
797 It turns out to be much much easier to do eta expansion
798 *after* the main CorePrep stuff. But that places constraints
799 on the eta expander: given a CpeRhs, it must return a CpeRhs.
801 For example here is what we do not want:
802 f = /\a -> g (h 3) -- h has arity 2
804 f = /\a -> let s = h 3 in g s
805 and now we do NOT want eta expansion to give
806 f = /\a -> \ y -> (let s = h 3 in g s) y
808 Instead CoreArity.etaExpand gives
809 f = /\a -> \y -> let s = h 3 in g s y
812 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
813 cpeEtaExpand arity expr
815 | otherwise = etaExpand arity expr
818 -- -----------------------------------------------------------------------------
820 -- -----------------------------------------------------------------------------
822 Why try eta reduction? Hasn't the simplifier already done eta?
823 But the simplifier only eta reduces if that leaves something
824 trivial (like f, or f Int). But for deLam it would be enough to
825 get to a partial application:
826 case x of { p -> \xs. map f xs }
827 ==> case x of { p -> map f }
830 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
831 tryEtaReducePrep bndrs expr@(App _ _)
832 | ok_to_eta_reduce f &&
834 and (zipWith ok bndrs last_args) &&
835 not (any (`elemVarSet` fvs_remaining) bndrs)
836 = Just remaining_expr
838 (f, args) = collectArgs expr
839 remaining_expr = mkApps f remaining_args
840 fvs_remaining = exprFreeVars remaining_expr
841 (remaining_args, last_args) = splitAt n_remaining args
842 n_remaining = length args - length bndrs
844 ok bndr (Var arg) = bndr == arg
847 -- we can't eta reduce something which must be saturated.
848 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
849 ok_to_eta_reduce _ = False --safe. ToDo: generalise
851 tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
852 | not (any (`elemVarSet` fvs) bndrs)
853 = case tryEtaReducePrep bndrs body of
854 Just e -> Just (Let bind e)
859 tryEtaReducePrep _ _ = Nothing
863 -- -----------------------------------------------------------------------------
865 -- -----------------------------------------------------------------------------
868 type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recursive
871 %************************************************************************
875 %************************************************************************
879 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
880 -- They are always of lifted type;
881 -- unlifted ones are done with FloatCase
885 Bool -- The bool indicates "ok-for-speculation"
887 data Floats = Floats OkToSpec (OrdList FloatingBind)
889 instance Outputable FloatingBind where
890 ppr (FloatLet b) = ppr b
891 ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
893 instance Outputable Floats where
894 ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+>
895 braces (vcat (map ppr (fromOL fs)))
897 instance Outputable OkToSpec where
898 ppr OkToSpec = ptext (sLit "OkToSpec")
899 ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk")
900 ppr NotOkToSpec = ptext (sLit "NotOkToSpec")
902 -- Can we float these binds out of the rhs of a let? We cache this decision
903 -- to avoid having to recompute it in a non-linear way when there are
904 -- deeply nested lets.
906 = OkToSpec -- Lazy bindings of lifted type
907 | IfUnboxedOk -- A mixture of lazy lifted bindings and n
908 -- ok-to-speculate unlifted bindings
909 | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
911 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
912 mkFloat is_strict is_unlifted bndr rhs
913 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
914 | otherwise = FloatLet (NonRec bndr rhs)
916 use_case = is_unlifted || is_strict && not (exprIsHNF rhs)
917 -- Don't make a case for a value binding,
918 -- even if it's strict. Otherwise we get
919 -- case (\x -> e) of ...!
921 emptyFloats :: Floats
922 emptyFloats = Floats OkToSpec nilOL
924 isEmptyFloats :: Floats -> Bool
925 isEmptyFloats (Floats _ bs) = isNilOL bs
927 wrapBinds :: Floats -> CpeBody -> CpeBody
928 wrapBinds (Floats _ binds) body
929 = foldrOL mk_bind body binds
931 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
932 mk_bind (FloatLet bind) body = Let bind body
934 addFloat :: Floats -> FloatingBind -> Floats
935 addFloat (Floats ok_to_spec floats) new_float
936 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
938 check (FloatLet _) = OkToSpec
939 check (FloatCase _ _ ok_for_spec)
940 | ok_for_spec = IfUnboxedOk
941 | otherwise = NotOkToSpec
942 -- The ok-for-speculation flag says that it's safe to
943 -- float this Case out of a let, and thereby do it more eagerly
944 -- We need the top-level flag because it's never ok to float
945 -- an unboxed binding to the top level
947 unitFloat :: FloatingBind -> Floats
948 unitFloat = addFloat emptyFloats
950 appendFloats :: Floats -> Floats -> Floats
951 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
952 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
954 concatFloats :: [Floats] -> OrdList FloatingBind
955 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
957 combine :: OkToSpec -> OkToSpec -> OkToSpec
958 combine NotOkToSpec _ = NotOkToSpec
959 combine _ NotOkToSpec = NotOkToSpec
960 combine IfUnboxedOk _ = IfUnboxedOk
961 combine _ IfUnboxedOk = IfUnboxedOk
962 combine _ _ = OkToSpec
964 deFloatTop :: Floats -> [CoreBind]
965 -- For top level only; we don't expect any FloatCases
966 deFloatTop (Floats _ floats)
967 = foldrOL get [] floats
969 get (FloatLet b) bs = occurAnalyseRHSs b : bs
970 get b _ = pprPanic "corePrepPgm" (ppr b)
972 -- See Note [Dead code in CorePrep]
973 occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr e)
974 occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]
976 -------------------------------------------
977 canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
978 -- Note [CafInfo and floating]
979 canFloatFromNoCaf (Floats ok_to_spec fs) rhs
980 | OkToSpec <- ok_to_spec -- Worth trying
981 , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
982 = Just (Floats OkToSpec fs', subst_expr subst rhs)
986 subst_expr = substExpr (text "CorePrep")
988 go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
989 -> Maybe (Subst, OrdList FloatingBind)
991 go (subst, fbs_out) [] = Just (subst, fbs_out)
993 go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
995 = go (subst', fbs_out `snocOL` new_fb) fbs_in
997 (subst', b') = set_nocaf_bndr subst b
998 new_fb = FloatLet (NonRec b' (subst_expr subst r))
1000 go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
1002 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1005 (subst', bs') = mapAccumL set_nocaf_bndr subst bs
1006 rs' = map (subst_expr subst') rs
1007 new_fb = FloatLet (Rec (bs' `zip` rs'))
1009 go _ _ = Nothing -- Encountered a caffy binding
1012 set_nocaf_bndr subst bndr
1013 = (extendIdSubst subst bndr (Var bndr'), bndr')
1015 bndr' = bndr `setIdCafInfo` NoCafRefs
1018 rhs_ok :: CoreExpr -> Bool
1019 -- We can only float to top level from a NoCaf thing if
1020 -- the new binding is static. However it can't mention
1021 -- any non-static things or it would *already* be Caffy
1022 rhs_ok = rhsIsStatic (\_ -> False)
1024 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
1025 wantFloatNested is_rec strict_or_unlifted floats rhs
1026 = isEmptyFloats floats
1027 || strict_or_unlifted
1028 || (allLazyNested is_rec floats && exprIsHNF rhs)
1029 -- Why the test for allLazyNested?
1030 -- v = f (x `divInt#` y)
1031 -- we don't want to float the case, even if f has arity 2,
1032 -- because floating the case would make it evaluated too early
1034 allLazyTop :: Floats -> Bool
1035 allLazyTop (Floats OkToSpec _) = True
1036 allLazyTop _ = False
1038 allLazyNested :: RecFlag -> Floats -> Bool
1039 allLazyNested _ (Floats OkToSpec _) = True
1040 allLazyNested _ (Floats NotOkToSpec _) = False
1041 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
1045 %************************************************************************
1049 %************************************************************************
1052 -- ---------------------------------------------------------------------------
1054 -- ---------------------------------------------------------------------------
1056 data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids
1058 emptyCorePrepEnv :: CorePrepEnv
1059 emptyCorePrepEnv = CPE emptyVarEnv
1061 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
1062 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
1064 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
1065 extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs)
1067 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
1068 lookupCorePrepEnv (CPE env) id
1069 = case lookupVarEnv env id of
1073 ------------------------------------------------------------------------------
1075 -- ---------------------------------------------------------------------------
1077 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
1078 cloneBndrs env bs = mapAccumLM cloneBndr env bs
1080 cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
1082 | isLocalId bndr, not (isCoVar bndr)
1083 = do bndr' <- setVarUnique bndr <$> getUniqueM
1085 -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
1086 -- so that we can drop more stuff as dead code.
1087 -- See also Note [Dead code in CorePrep]
1088 let bndr'' = bndr' `setIdUnfolding` noUnfolding
1089 `setIdSpecialisation` emptySpecInfo
1090 return (extendCorePrepEnv env bndr bndr'', bndr'')
1092 | otherwise -- Top level things, which we don't want
1093 -- to clone, have become GlobalIds by now
1094 -- And we don't clone tyvars, or coercion variables
1095 = return (env, bndr)
1098 ------------------------------------------------------------------------------
1099 -- Cloning ccall Ids; each must have a unique name,
1100 -- to give the code generator a handle to hang it on
1101 -- ---------------------------------------------------------------------------
1103 fiddleCCall :: Id -> UniqSM Id
1105 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
1106 | otherwise = return id
1108 ------------------------------------------------------------------------------
1109 -- Generating new binders
1110 -- ---------------------------------------------------------------------------
1112 newVar :: Type -> UniqSM Id
1114 = seqType ty `seq` do
1116 return (mkSysLocal (fsLit "sat") uniq ty)