75301791b409b277360ccbdcabdad8e05e331242
[ghc.git] / compiler / coreSyn / CorePrep.hs
1 {-
2 (c) The University of Glasgow, 1994-2006
3
4
5 Core pass to saturate constructors and PrimOps
6 -}
7
8 {-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}
9
10 module CorePrep (
11 corePrepPgm, corePrepExpr, cvtLitInteger,
12 lookupMkIntegerName, lookupIntegerSDataConName
13 ) where
14
15 #include "HsVersions.h"
16
17 import GhcPrelude
18
19 import OccurAnal
20
21 import HscTypes
22 import PrelNames
23 import MkId ( realWorldPrimId )
24 import CoreUtils
25 import CoreArity
26 import CoreFVs
27 import CoreMonad ( CoreToDo(..) )
28 import CoreLint ( endPassIO )
29 import CoreSyn
30 import CoreSubst
31 import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here
32 import Type
33 import Literal
34 import Coercion
35 import TcEnv
36 import TyCon
37 import Demand
38 import Var
39 import VarSet
40 import VarEnv
41 import Id
42 import IdInfo
43 import TysWiredIn
44 import DataCon
45 import PrimOp
46 import BasicTypes
47 import Module
48 import UniqSupply
49 import Maybes
50 import OrdList
51 import ErrUtils
52 import DynFlags
53 import Util
54 import Pair
55 import Outputable
56 import Platform
57 import FastString
58 import Config
59 import Name ( NamedThing(..), nameSrcSpan )
60 import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
61 import Data.Bits
62 import MonadUtils ( mapAccumLM )
63 import Data.List ( mapAccumL, foldl' )
64 import Control.Monad
65 import CostCentre ( CostCentre, ccFromThisModule )
66 import qualified Data.Set as S
67
68 {-
69 -- ---------------------------------------------------------------------------
70 -- Note [CorePrep Overview]
71 -- ---------------------------------------------------------------------------
72
73 The goal of this pass is to prepare for code generation.
74
75 1. Saturate constructor and primop applications.
76
77 2. Convert to A-normal form; that is, function arguments
78 are always variables.
79
80 * Use case for strict arguments:
81 f E ==> case E of x -> f x
82 (where f is strict)
83
84 * Use let for non-trivial lazy arguments
85 f E ==> let x = E in f x
86 (were f is lazy and x is non-trivial)
87
88 3. Similarly, convert any unboxed lets into cases.
89 [I'm experimenting with leaving 'ok-for-speculation'
90 rhss in let-form right up to this point.]
91
92 4. Ensure that *value* lambdas only occur as the RHS of a binding
93 (The code generator can't deal with anything else.)
94 Type lambdas are ok, however, because the code gen discards them.
95
96 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
97
98 6. Clone all local Ids.
99 This means that all such Ids are unique, rather than the
100 weaker guarantee of no clashes which the simplifier provides.
101 And that is what the code generator needs.
102
103 We don't clone TyVars or CoVars. The code gen doesn't need that,
104 and doing so would be tiresome because then we'd need
105 to substitute in types and coercions.
106
107 7. Give each dynamic CCall occurrence a fresh unique; this is
108 rather like the cloning step above.
109
110 8. Inject bindings for the "implicit" Ids:
111 * Constructor wrappers
112 * Constructor workers
113 We want curried definitions for all of these in case they
114 aren't inlined by some caller.
115
116 9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.hs
117 Also replace (noinline e) by e.
118
119 10. Convert (LitInteger i t) into the core representation
120 for the Integer i. Normally this uses mkInteger, but if
121 we are using the integer-gmp implementation then there is a
122 special case where we use the S# constructor for Integers that
123 are in the range of Int.
124
125 11. Uphold tick consistency while doing this: We move ticks out of
126 (non-type) applications where we can, and make sure that we
127 annotate according to scoping rules when floating.
128
129 12. Collect cost centres (including cost centres in unfoldings) if we're in
130 profiling mode. We have to do this here beucase we won't have unfoldings
131 after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].
132
133 This is all done modulo type applications and abstractions, so that
134 when type erasure is done for conversion to STG, we don't end up with
135 any trivial or useless bindings.
136
137
138 Note [CorePrep invariants]
139 ~~~~~~~~~~~~~~~~~~~~~~~~~~
140 Here is the syntax of the Core produced by CorePrep:
141
142 Trivial expressions
143 arg ::= lit | var
144 | arg ty | /\a. arg
145 | truv co | /\c. arg | arg |> co
146
147 Applications
148 app ::= lit | var | app arg | app ty | app co | app |> co
149
150 Expressions
151 body ::= app
152 | let(rec) x = rhs in body -- Boxed only
153 | case body of pat -> body
154 | /\a. body | /\c. body
155 | body |> co
156
157 Right hand sides (only place where value lambdas can occur)
158 rhs ::= /\a.rhs | \x.rhs | body
159
160 We define a synonym for each of these non-terminals. Functions
161 with the corresponding name produce a result in that syntax.
162 -}
163
164 type CpeArg = CoreExpr -- Non-terminal 'arg'
165 type CpeApp = CoreExpr -- Non-terminal 'app'
166 type CpeBody = CoreExpr -- Non-terminal 'body'
167 type CpeRhs = CoreExpr -- Non-terminal 'rhs'
168
169 {-
170 ************************************************************************
171 * *
172 Top level stuff
173 * *
174 ************************************************************************
175 -}
176
177 corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
178 -> IO (CoreProgram, S.Set CostCentre)
179 corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
180 withTiming (pure dflags)
181 (text "CorePrep"<+>brackets (ppr this_mod))
182 (const ()) $ do
183 us <- mkSplitUniqSupply 's'
184 initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
185
186 let cost_centres
187 | WayProf `elem` ways dflags
188 = collectCostCentres this_mod binds
189 | otherwise
190 = S.empty
191
192 implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
193 -- NB: we must feed mkImplicitBinds through corePrep too
194 -- so that they are suitably cloned and eta-expanded
195
196 binds_out = initUs_ us $ do
197 floats1 <- corePrepTopBinds initialCorePrepEnv binds
198 floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
199 return (deFloatTop (floats1 `appendFloats` floats2))
200
201 endPassIO hsc_env alwaysQualify CorePrep binds_out []
202 return (binds_out, cost_centres)
203 where
204 dflags = hsc_dflags hsc_env
205
206 corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
207 corePrepExpr dflags hsc_env expr =
208 withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do
209 us <- mkSplitUniqSupply 's'
210 initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
211 let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
212 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
213 return new_expr
214
215 corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
216 -- Note [Floating out of top level bindings]
217 corePrepTopBinds initialCorePrepEnv binds
218 = go initialCorePrepEnv binds
219 where
220 go _ [] = return emptyFloats
221 go env (bind : binds) = do (env', floats, maybe_new_bind)
222 <- cpeBind TopLevel env bind
223 MASSERT(isNothing maybe_new_bind)
224 -- Only join points get returned this way by
225 -- cpeBind, and no join point may float to top
226 floatss <- go env' binds
227 return (floats `appendFloats` floatss)
228
229 mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
230 -- See Note [Data constructor workers]
231 -- c.f. Note [Injecting implicit bindings] in TidyPgm
232 mkDataConWorkers dflags mod_loc data_tycons
233 = [ NonRec id (tick_it (getName data_con) (Var id))
234 -- The ice is thin here, but it works
235 | tycon <- data_tycons, -- CorePrep will eta-expand it
236 data_con <- tyConDataCons tycon,
237 let id = dataConWorkId data_con
238 ]
239 where
240 -- If we want to generate debug info, we put a source note on the
241 -- worker. This is useful, especially for heap profiling.
242 tick_it name
243 | debugLevel dflags == 0 = id
244 | RealSrcSpan span <- nameSrcSpan name = tick span
245 | Just file <- ml_hs_file mod_loc = tick (span1 file)
246 | otherwise = tick (span1 "???")
247 where tick span = Tick (SourceNote span $ showSDoc dflags (ppr name))
248 span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
249
250 {-
251 Note [Floating out of top level bindings]
252 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
253 NB: we do need to float out of top-level bindings
254 Consider x = length [True,False]
255 We want to get
256 s1 = False : []
257 s2 = True : s1
258 x = length s2
259
260 We return a *list* of bindings, because we may start with
261 x* = f (g y)
262 where x is demanded, in which case we want to finish with
263 a = g y
264 x* = f a
265 And then x will actually end up case-bound
266
267 Note [CafInfo and floating]
268 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
269 What happens when we try to float bindings to the top level? At this
270 point all the CafInfo is supposed to be correct, and we must make certain
271 that is true of the new top-level bindings. There are two cases
272 to consider
273
274 a) The top-level binding is marked asCafRefs. In that case we are
275 basically fine. The floated bindings had better all be lazy lets,
276 so they can float to top level, but they'll all have HasCafRefs
277 (the default) which is safe.
278
279 b) The top-level binding is marked NoCafRefs. This really happens
280 Example. CoreTidy produces
281 $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...
282 Now CorePrep has to eta-expand to
283 $fApplicativeSTM = let sat = \xy. retry x y
284 in D:Alternative sat ...blah...
285 So what we *want* is
286 sat [NoCafRefs] = \xy. retry x y
287 $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...
288
289 So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
290 *and* substitute the modified 'sat' into the old RHS.
291
292 It should be the case that 'sat' is itself [NoCafRefs] (a value, no
293 cafs) else the original top-level binding would not itself have been
294 marked [NoCafRefs]. The DEBUG check in CoreToStg for
295 consistentCafInfo will find this.
296
297 This is all very gruesome and horrible. It would be better to figure
298 out CafInfo later, after CorePrep. We'll do that in due course.
299 Meanwhile this horrible hack works.
300
301 Note [Join points and floating]
302 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
303 Join points can float out of other join points but not out of value bindings:
304
305 let z =
306 let w = ... in -- can float
307 join k = ... in -- can't float
308 ... jump k ...
309 join j x1 ... xn =
310 let y = ... in -- can float (but don't want to)
311 join h = ... in -- can float (but not much point)
312 ... jump h ...
313 in ...
314
315 Here, the jump to h remains valid if h is floated outward, but the jump to k
316 does not.
317
318 We don't float *out* of join points. It would only be safe to float out of
319 nullary join points (or ones where the arguments are all either type arguments
320 or dead binders). Nullary join points aren't ever recursive, so they're always
321 effectively one-shot functions, which we don't float out of. We *could* float
322 join points from nullary join points, but there's no clear benefit at this
323 stage.
324
325 Note [Data constructor workers]
326 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
327 Create any necessary "implicit" bindings for data con workers. We
328 create the rather strange (non-recursive!) binding
329
330 $wC = \x y -> $wC x y
331
332 i.e. a curried constructor that allocates. This means that we can
333 treat the worker for a constructor like any other function in the rest
334 of the compiler. The point here is that CoreToStg will generate a
335 StgConApp for the RHS, rather than a call to the worker (which would
336 give a loop). As Lennart says: the ice is thin here, but it works.
337
338 Hmm. Should we create bindings for dictionary constructors? They are
339 always fully applied, and the bindings are just there to support
340 partial applications. But it's easier to let them through.
341
342
343 Note [Dead code in CorePrep]
344 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
345 Imagine that we got an input program like this (see Trac #4962):
346
347 f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
348 f x = (g True (Just x) + g () (Just x), g)
349 where
350 g :: Show a => a -> Maybe Int -> Int
351 g _ Nothing = x
352 g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
353
354 After specialisation and SpecConstr, we would get something like this:
355
356 f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
357 f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
358 where
359 {-# RULES g $dBool = g$Bool
360 g $dUnit = g$Unit #-}
361 g = ...
362 {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
363 g$Bool = ...
364 {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
365 g$Unit = ...
366 g$Bool_True_Just = ...
367 g$Unit_Unit_Just = ...
368
369 Note that the g$Bool and g$Unit functions are actually dead code: they
370 are only kept alive by the occurrence analyser because they are
371 referred to by the rules of g, which is being kept alive by the fact
372 that it is used (unspecialised) in the returned pair.
373
374 However, at the CorePrep stage there is no way that the rules for g
375 will ever fire, and it really seems like a shame to produce an output
376 program that goes to the trouble of allocating a closure for the
377 unreachable g$Bool and g$Unit functions.
378
379 The way we fix this is to:
380 * In cloneBndr, drop all unfoldings/rules
381
382 * In deFloatTop, run a simple dead code analyser on each top-level
383 RHS to drop the dead local bindings. For that call to OccAnal, we
384 disable the binder swap, else the occurrence analyser sometimes
385 introduces new let bindings for cased binders, which lead to the bug
386 in #5433.
387
388 The reason we don't just OccAnal the whole output of CorePrep is that
389 the tidier ensures that all top-level binders are GlobalIds, so they
390 don't show up in the free variables any longer. So if you run the
391 occurrence analyser on the output of CoreTidy (or later) you e.g. turn
392 this program:
393
394 Rec {
395 f = ... f ...
396 }
397
398 Into this one:
399
400 f = ... f ...
401
402 (Since f is not considered to be free in its own RHS.)
403
404
405 ************************************************************************
406 * *
407 The main code
408 * *
409 ************************************************************************
410 -}
411
412 cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
413 -> UniqSM (CorePrepEnv,
414 Floats, -- Floating value bindings
415 Maybe CoreBind) -- Just bind' <=> returned new bind; no float
416 -- Nothing <=> added bind' to floats instead
417 cpeBind top_lvl env (NonRec bndr rhs)
418 | not (isJoinId bndr)
419 = do { (_, bndr1) <- cpCloneBndr env bndr
420 ; let dmd = idDemandInfo bndr
421 is_unlifted = isUnliftedType (idType bndr)
422 ; (floats, rhs1) <- cpePair top_lvl NonRecursive
423 dmd is_unlifted
424 env bndr1 rhs
425 -- See Note [Inlining in CorePrep]
426 ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl
427 then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)
428 else do {
429
430 ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1
431
432 ; return (extendCorePrepEnv env bndr bndr1,
433 addFloat floats new_float,
434 Nothing) }}
435
436 | otherwise -- A join point; see Note [Join points and floating]
437 = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point
438 do { (_, bndr1) <- cpCloneBndr env bndr
439 ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
440 ; return (extendCorePrepEnv env bndr bndr2,
441 emptyFloats,
442 Just (NonRec bndr2 rhs1)) }
443
444 cpeBind top_lvl env (Rec pairs)
445 | not (isJoinId (head bndrs))
446 = do { (env', bndrs1) <- cpCloneBndrs env bndrs
447 ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
448 bndrs1 rhss
449
450 ; let (floats_s, rhss1) = unzip stuff
451 all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)
452 (concatFloats floats_s)
453
454 ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
455 unitFloat (FloatLet (Rec all_pairs)),
456 Nothing) }
457
458 | otherwise -- See Note [Join points and floating]
459 = do { (env', bndrs1) <- cpCloneBndrs env bndrs
460 ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
461
462 ; let bndrs2 = map fst pairs1
463 ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),
464 emptyFloats,
465 Just (Rec pairs1)) }
466 where
467 (bndrs, rhss) = unzip pairs
468
469 -- Flatten all the floats, and the current
470 -- group into a single giant Rec
471 add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
472 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
473 add_float b _ = pprPanic "cpeBind" (ppr b)
474
475 ---------------
476 cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
477 -> CorePrepEnv -> OutId -> CoreExpr
478 -> UniqSM (Floats, CpeRhs)
479 -- Used for all bindings
480 -- The binder is already cloned, hence an OutId
481 cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
482 = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair
483 do { (floats1, rhs1) <- cpeRhsE env rhs
484
485 -- See if we are allowed to float this stuff out of the RHS
486 ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
487
488 -- Make the arity match up
489 ; (floats3, rhs3)
490 <- if manifestArity rhs1 <= arity
491 then return (floats2, cpeEtaExpand arity rhs2)
492 else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
493 -- Note [Silly extra arguments]
494 (do { v <- newVar (idType bndr)
495 ; let float = mkFloat topDmd False v rhs2
496 ; return ( addFloat floats2 float
497 , cpeEtaExpand arity (Var v)) })
498
499 -- Wrap floating ticks
500 ; let (floats4, rhs4) = wrapTicks floats3 rhs3
501
502 ; return (floats4, rhs4) }
503 where
504 platform = targetPlatform (cpe_dynFlags env)
505
506 arity = idArity bndr -- We must match this arity
507
508 ---------------------
509 float_from_rhs floats rhs
510 | isEmptyFloats floats = return (emptyFloats, rhs)
511 | isTopLevel top_lvl = float_top floats rhs
512 | otherwise = float_nested floats rhs
513
514 ---------------------
515 float_nested floats rhs
516 | wantFloatNested is_rec dmd is_unlifted floats rhs
517 = return (floats, rhs)
518 | otherwise = dontFloat floats rhs
519
520 ---------------------
521 float_top floats rhs -- Urhgh! See Note [CafInfo and floating]
522 | mayHaveCafRefs (idCafInfo bndr)
523 , allLazyTop floats
524 = return (floats, rhs)
525
526 -- So the top-level binding is marked NoCafRefs
527 | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs
528 = return (floats', rhs')
529
530 | otherwise
531 = dontFloat floats rhs
532
533 dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
534 -- Non-empty floats, but do not want to float from rhs
535 -- So wrap the rhs in the floats
536 -- But: rhs1 might have lambdas, and we can't
537 -- put them inside a wrapBinds
538 dontFloat floats1 rhs
539 = do { (floats2, body) <- rhsToBody rhs
540 ; return (emptyFloats, wrapBinds floats1 $
541 wrapBinds floats2 body) }
542
543 {- Note [Silly extra arguments]
544 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
545 Suppose we had this
546 f{arity=1} = \x\y. e
547 We *must* match the arity on the Id, so we have to generate
548 f' = \x\y. e
549 f = \x. f' x
550
551 It's a bizarre case: why is the arity on the Id wrong? Reason
552 (in the days of __inline_me__):
553 f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
554 When InlineMe notes go away this won't happen any more. But
555 it seems good for CorePrep to be robust.
556 -}
557
558 ---------------
559 cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
560 -> UniqSM (JoinId, CpeRhs)
561 -- Used for all join bindings
562 cpeJoinPair env bndr rhs
563 = ASSERT(isJoinId bndr)
564 do { let Just join_arity = isJoinId_maybe bndr
565 (bndrs, body) = collectNBinders join_arity rhs
566
567 ; (env', bndrs') <- cpCloneBndrs env bndrs
568
569 ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts
570 -- with a lambda
571
572 ; let rhs' = mkCoreLams bndrs' body'
573 bndr' = bndr `setIdUnfolding` evaldUnfolding
574 `setIdArity` count isId bndrs
575 -- See Note [Arity and join points]
576
577 ; return (bndr', rhs') }
578
579 {-
580 Note [Arity and join points]
581 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
582 Up to now, we've allowed a join point to have an arity greater than its join
583 arity (minus type arguments), since this is what's useful for eta expansion.
584 However, for code gen purposes, its arity must be exactly the number of value
585 arguments it will be called with, and it must have exactly that many value
586 lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:
587
588 join j x y z = \w -> ... in ...
589 =>
590 join j x y z = (let f = \w -> ... in f) in ...
591
592 This is also what happens with Note [Silly extra arguments]. Note that it's okay
593 for us to mess with the arity because a join point is never exported.
594 -}
595
596 -- ---------------------------------------------------------------------------
597 -- CpeRhs: produces a result satisfying CpeRhs
598 -- ---------------------------------------------------------------------------
599
600 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
601 -- If
602 -- e ===> (bs, e')
603 -- then
604 -- e = let bs in e' (semantically, that is!)
605 --
606 -- For example
607 -- f (g x) ===> ([v = g x], f v)
608
609 cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
610 cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
611 cpeRhsE env (Lit (LitInteger i _))
612 = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
613 (cpe_integerSDataCon env) i)
614 cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
615 cpeRhsE env expr@(Var {}) = cpeApp env expr
616 cpeRhsE env expr@(App {}) = cpeApp env expr
617
618 cpeRhsE env (Let bind body)
619 = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind
620 ; (body_floats, body') <- cpeRhsE env' body
621 ; let expr' = case maybe_bind' of Just bind' -> Let bind' body'
622 Nothing -> body'
623 ; return (bind_floats `appendFloats` body_floats, expr') }
624
625 cpeRhsE env (Tick tickish expr)
626 | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope
627 = do { (floats, body) <- cpeRhsE env expr
628 -- See [Floating Ticks in CorePrep]
629 ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }
630 | otherwise
631 = do { body <- cpeBodyNF env expr
632 ; return (emptyFloats, mkTick tickish' body) }
633 where
634 tickish' | Breakpoint n fvs <- tickish
635 -- See also 'substTickish'
636 = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
637 | otherwise
638 = tickish
639
640 cpeRhsE env (Cast expr co)
641 = do { (floats, expr') <- cpeRhsE env expr
642 ; return (floats, Cast expr' co) }
643
644 cpeRhsE env expr@(Lam {})
645 = do { let (bndrs,body) = collectBinders expr
646 ; (env', bndrs') <- cpCloneBndrs env bndrs
647 ; body' <- cpeBodyNF env' body
648 ; return (emptyFloats, mkLams bndrs' body') }
649
650 cpeRhsE env (Case scrut bndr ty alts)
651 = do { (floats, scrut') <- cpeBody env scrut
652 ; (env', bndr2) <- cpCloneBndr env bndr
653 ; let alts'
654 -- This flag is intended to aid in debugging strictness
655 -- analysis bugs. These are particularly nasty to chase down as
656 -- they may manifest as segmentation faults. When this flag is
657 -- enabled we instead produce an 'error' expression to catch
658 -- the case where a function we think should bottom
659 -- unexpectedly returns.
660 | gopt Opt_CatchBottoms (cpe_dynFlags env)
661 , not (altsAreExhaustive alts)
662 = addDefault alts (Just err)
663 | otherwise = alts
664 where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty
665 "Bottoming expression returned"
666 ; alts'' <- mapM (sat_alt env') alts'
667 ; return (floats, Case scrut' bndr2 ty alts'') }
668 where
669 sat_alt env (con, bs, rhs)
670 = do { (env2, bs') <- cpCloneBndrs env bs
671 ; rhs' <- cpeBodyNF env2 rhs
672 ; return (con, bs', rhs') }
673
674 cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
675 -- Here we convert a literal Integer to the low-level
676 -- representation. Exactly how we do this depends on the
677 -- library that implements Integer. If it's GMP we
678 -- use the S# data constructor for small literals.
679 -- See Note [Integer literals] in Literal
680 cvtLitInteger dflags _ (Just sdatacon) i
681 | inIntRange dflags i -- Special case for small integers
682 = mkConApp sdatacon [Lit (mkMachInt dflags i)]
683
684 cvtLitInteger dflags mk_integer _ i
685 = mkApps (Var mk_integer) [isNonNegative, ints]
686 where isNonNegative = if i < 0 then mkConApp falseDataCon []
687 else mkConApp trueDataCon []
688 ints = mkListExpr intTy (f (abs i))
689 f 0 = []
690 f x = let low = x .&. mask
691 high = x `shiftR` bits
692 in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high
693 bits = 31
694 mask = 2 ^ bits - 1
695
696 -- ---------------------------------------------------------------------------
697 -- CpeBody: produces a result satisfying CpeBody
698 -- ---------------------------------------------------------------------------
699
700 -- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without
701 -- producing any floats (any generated floats are immediately
702 -- let-bound using 'wrapBinds'). Generally you want this, esp.
703 -- when you've reached a binding form (e.g., a lambda) and
704 -- floating any further would be incorrect.
705 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
706 cpeBodyNF env expr
707 = do { (floats, body) <- cpeBody env expr
708 ; return (wrapBinds floats body) }
709
710 -- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce
711 -- a list of 'Floats' which are being propagated upwards. In
712 -- fact, this function is used in only two cases: to
713 -- implement 'cpeBodyNF' (which is what you usually want),
714 -- and in the case when a let-binding is in a case scrutinee--here,
715 -- we can always float out:
716 --
717 -- case (let x = y in z) of ...
718 -- ==> let x = y in case z of ...
719 --
720 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
721 cpeBody env expr
722 = do { (floats1, rhs) <- cpeRhsE env expr
723 ; (floats2, body) <- rhsToBody rhs
724 ; return (floats1 `appendFloats` floats2, body) }
725
726 --------
727 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
728 -- Remove top level lambdas by let-binding
729
730 rhsToBody (Tick t expr)
731 | tickishScoped t == NoScope -- only float out of non-scoped annotations
732 = do { (floats, expr') <- rhsToBody expr
733 ; return (floats, mkTick t expr') }
734
735 rhsToBody (Cast e co)
736 -- You can get things like
737 -- case e of { p -> coerce t (\s -> ...) }
738 = do { (floats, e') <- rhsToBody e
739 ; return (floats, Cast e' co) }
740
741 rhsToBody expr@(Lam {})
742 | Just no_lam_result <- tryEtaReducePrep bndrs body
743 = return (emptyFloats, no_lam_result)
744 | all isTyVar bndrs -- Type lambdas are ok
745 = return (emptyFloats, expr)
746 | otherwise -- Some value lambdas
747 = do { fn <- newVar (exprType expr)
748 ; let rhs = cpeEtaExpand (exprArity expr) expr
749 float = FloatLet (NonRec fn rhs)
750 ; return (unitFloat float, Var fn) }
751 where
752 (bndrs,body) = collectBinders expr
753
754 rhsToBody expr = return (emptyFloats, expr)
755
756
757
758 -- ---------------------------------------------------------------------------
759 -- CpeApp: produces a result satisfying CpeApp
760 -- ---------------------------------------------------------------------------
761
762 data ArgInfo = CpeApp CoreArg
763 | CpeCast Coercion
764 | CpeTick (Tickish Id)
765
766 {- Note [runRW arg]
767 ~~~~~~~~~~~~~~~~~~~
768 If we got, say
769 runRW# (case bot of {})
770 which happened in Trac #11291, we do /not/ want to turn it into
771 (case bot of {}) realWorldPrimId#
772 because that gives a panic in CoreToStg.myCollectArgs, which expects
773 only variables in function position. But if we are sure to make
774 runRW# strict (which we do in MkId), this can't happen
775 -}
776
777 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
778 -- May return a CpeRhs because of saturating primops
779 cpeApp top_env expr
780 = do { let (terminal, args, depth) = collect_args expr
781 ; cpe_app top_env terminal args depth
782 }
783
784 where
785 -- We have a nested data structure of the form
786 -- e `App` a1 `App` a2 ... `App` an, convert it into
787 -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)
788 -- We use 'ArgInfo' because we may also need to
789 -- record casts and ticks. Depth counts the number
790 -- of arguments that would consume strictness information
791 -- (so, no type or coercion arguments.)
792 collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)
793 collect_args e = go e [] 0
794 where
795 go (App fun arg) as !depth
796 = go fun (CpeApp arg : as)
797 (if isTyCoArg arg then depth else depth + 1)
798 go (Cast fun co) as depth
799 = go fun (CpeCast co : as) depth
800 go (Tick tickish fun) as depth
801 | tickishPlace tickish == PlaceNonLam
802 && tickish `tickishScopesLike` SoftScope
803 = go fun (CpeTick tickish : as) depth
804 go terminal as depth = (terminal, as, depth)
805
806 cpe_app :: CorePrepEnv
807 -> CoreExpr
808 -> [ArgInfo]
809 -> Int
810 -> UniqSM (Floats, CpeRhs)
811 cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth
812 | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and
813 || f `hasKey` noinlineIdKey -- Replace (noinline a) with a
814 -- Consider the code:
815 --
816 -- lazy (f x) y
817 --
818 -- We need to make sure that we need to recursively collect arguments on
819 -- "f x", otherwise we'll float "f x" out (it's not a variable) and
820 -- end up with this awful -ddump-prep:
821 --
822 -- case f x of f_x {
823 -- __DEFAULT -> f_x y
824 -- }
825 --
826 -- rather than the far superior "f x y". Test case is par01.
827 = let (terminal, args', depth') = collect_args arg
828 in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
829 cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1
830 | f `hasKey` runRWKey
831 -- See Note [runRW magic]
832 -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
833 -- is why we return a CorePrepEnv as well)
834 = case arg of
835 Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0
836 _ -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1
837 cpe_app env (Var v) args depth
838 = do { v1 <- fiddleCCall v
839 ; let e2 = lookupCorePrepEnv env v1
840 hd = getIdFromTrivialExpr_maybe e2
841 -- NB: depth from collect_args is right, because e2 is a trivial expression
842 -- and thus its embedded Id *must* be at the same depth as any
843 -- Apps it is under are type applications only (c.f.
844 -- exprIsTrivial). But note that we need the type of the
845 -- expression, not the id.
846 ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts
847 ; mb_saturate hd app floats depth }
848 where
849 stricts = case idStrictness v of
850 StrictSig (DmdType _ demands _)
851 | listLengthCmp demands depth /= GT -> demands
852 -- length demands <= depth
853 | otherwise -> []
854 -- If depth < length demands, then we have too few args to
855 -- satisfy strictness info so we have to ignore all the
856 -- strictness info, e.g. + (error "urk")
857 -- Here, we can't evaluate the arg strictly, because this
858 -- partial application might be seq'd
859
860 -- We inlined into something that's not a var and has no args.
861 -- Bounce it back up to cpeRhsE.
862 cpe_app env fun [] _ = cpeRhsE env fun
863
864 -- N-variable fun, better let-bind it
865 cpe_app env fun args depth
866 = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
867 -- The evalDmd says that it's sure to be evaluated,
868 -- so we'll end up case-binding it
869 ; (app, floats) <- rebuild_app args fun' ty fun_floats []
870 ; mb_saturate Nothing app floats depth }
871 where
872 ty = exprType fun
873
874 -- Saturate if necessary
875 mb_saturate head app floats depth =
876 case head of
877 Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth
878 ; return (floats, sat_app) }
879 _other -> return (floats, app)
880
881 -- Deconstruct and rebuild the application, floating any non-atomic
882 -- arguments to the outside. We collect the type of the expression,
883 -- the head of the application, and the number of actual value arguments,
884 -- all of which are used to possibly saturate this application if it
885 -- has a constructor or primop at the head.
886 rebuild_app
887 :: [ArgInfo] -- The arguments (inner to outer)
888 -> CpeApp
889 -> Type
890 -> Floats
891 -> [Demand]
892 -> UniqSM (CpeApp, Floats)
893 rebuild_app [] app _ floats ss = do
894 MASSERT(null ss) -- make sure we used all the strictness info
895 return (app, floats)
896 rebuild_app (a : as) fun' fun_ty floats ss = case a of
897 CpeApp arg@(Type arg_ty) ->
898 rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss
899 CpeApp arg@(Coercion {}) ->
900 rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss
901 CpeApp arg -> do
902 let (ss1, ss_rest) -- See Note [lazyId magic] in MkId
903 = case (ss, isLazyExpr arg) of
904 (_ : ss_rest, True) -> (topDmd, ss_rest)
905 (ss1 : ss_rest, False) -> (ss1, ss_rest)
906 ([], _) -> (topDmd, [])
907 (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
908 splitFunTy_maybe fun_ty
909 (fs, arg') <- cpeArg top_env ss1 arg arg_ty
910 rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest
911 CpeCast co ->
912 let Pair _ty1 ty2 = coercionKind co
913 in rebuild_app as (Cast fun' co) ty2 floats ss
914 CpeTick tickish ->
915 -- See [Floating Ticks in CorePrep]
916 rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss
917
918 isLazyExpr :: CoreExpr -> Bool
919 -- See Note [lazyId magic] in MkId
920 isLazyExpr (Cast e _) = isLazyExpr e
921 isLazyExpr (Tick _ e) = isLazyExpr e
922 isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey
923 isLazyExpr _ = False
924
925 {- Note [runRW magic]
926 ~~~~~~~~~~~~~~~~~~~~~
927 Some definitions, for instance @runST@, must have careful control over float out
928 of the bindings in their body. Consider this use of @runST@,
929
930 f x = runST ( \ s -> let (a, s') = newArray# 100 [] s
931 (_, s'') = fill_in_array_or_something a x s'
932 in freezeArray# a s'' )
933
934 If we inline @runST@, we'll get:
935
936 f x = let (a, s') = newArray# 100 [] realWorld#{-NB-}
937 (_, s'') = fill_in_array_or_something a x s'
938 in freezeArray# a s''
939
940 And now if we allow the @newArray#@ binding to float out to become a CAF,
941 we end up with a result that is totally and utterly wrong:
942
943 f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
944 in \ x ->
945 let (_, s'') = fill_in_array_or_something a x s'
946 in freezeArray# a s''
947
948 All calls to @f@ will share a {\em single} array! Clearly this is nonsense and
949 must be prevented.
950
951 This is what @runRW#@ gives us: by being inlined extremely late in the
952 optimization (right before lowering to STG, in CorePrep), we can ensure that
953 no further floating will occur. This allows us to safely inline things like
954 @runST@, which are otherwise needlessly expensive (see #10678 and #5916).
955
956 'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE
957 pragma. It is levity-polymorphic.
958
959 runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
960 => (State# RealWorld -> (# State# RealWorld, o #))
961 -> (# State# RealWorld, o #)
962
963 It needs no special treatment in GHC except this special inlining here
964 in CorePrep (and in ByteCodeGen).
965
966 -- ---------------------------------------------------------------------------
967 -- CpeArg: produces a result satisfying CpeArg
968 -- ---------------------------------------------------------------------------
969
970 Note [ANF-ising literal string arguments]
971 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
972
973 Consider a program like,
974
975 data Foo = Foo Addr#
976
977 foo = Foo "turtle"#
978
979 When we go to ANFise this we might think that we want to float the string
980 literal like we do any other non-trivial argument. This would look like,
981
982 foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }
983
984 However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)
985 wreaks havoc on the CAF annotations that we produce here since we the result
986 above is caffy since it is updateable. Ideally at some point in the future we
987 would like to just float the literal to the top level as suggested in #11312,
988
989 s = "turtle"#
990 foo = Foo s
991
992 However, until then we simply add a special case excluding literals from the
993 floating done by cpeArg.
994 -}
995
996 -- | Is an argument okay to CPE?
997 okCpeArg :: CoreExpr -> Bool
998 -- Don't float literals. See Note [ANF-ising literal string arguments].
999 okCpeArg (Lit _) = False
1000 -- Do not eta expand a trivial argument
1001 okCpeArg expr = not (exprIsTrivial expr)
1002
1003 -- This is where we arrange that a non-trivial argument is let-bound
1004 cpeArg :: CorePrepEnv -> Demand
1005 -> CoreArg -> Type -> UniqSM (Floats, CpeArg)
1006 cpeArg env dmd arg arg_ty
1007 = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
1008 ; (floats2, arg2) <- if want_float floats1 arg1
1009 then return (floats1, arg1)
1010 else dontFloat floats1 arg1
1011 -- Else case: arg1 might have lambdas, and we can't
1012 -- put them inside a wrapBinds
1013
1014 ; if okCpeArg arg2
1015 then do { v <- newVar arg_ty
1016 ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
1017 arg_float = mkFloat dmd is_unlifted v arg3
1018 ; return (addFloat floats2 arg_float, varToCoreExpr v) }
1019 else return (floats2, arg2)
1020 }
1021 where
1022 is_unlifted = isUnliftedType arg_ty
1023 want_float = wantFloatNested NonRecursive dmd is_unlifted
1024
1025 {-
1026 Note [Floating unlifted arguments]
1027 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1028 Consider C (let v* = expensive in v)
1029
1030 where the "*" indicates "will be demanded". Usually v will have been
1031 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
1032 do *not* want to get
1033
1034 let v* = expensive in C v
1035
1036 because that has different strictness. Hence the use of 'allLazy'.
1037 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
1038
1039
1040 ------------------------------------------------------------------------------
1041 -- Building the saturated syntax
1042 -- ---------------------------------------------------------------------------
1043
1044 maybeSaturate deals with saturating primops and constructors
1045 The type is the type of the entire application
1046 -}
1047
1048 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
1049 maybeSaturate fn expr n_args
1050 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
1051 -- A gruesome special case
1052 = saturateDataToTag sat_expr
1053
1054 | hasNoBinding fn -- There's no binding
1055 = return sat_expr
1056
1057 | otherwise
1058 = return expr
1059 where
1060 fn_arity = idArity fn
1061 excess_arity = fn_arity - n_args
1062 sat_expr = cpeEtaExpand excess_arity expr
1063
1064 -------------
1065 saturateDataToTag :: CpeApp -> UniqSM CpeApp
1066 -- See Note [dataToTag magic]
1067 saturateDataToTag sat_expr
1068 = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
1069 ; eta_body' <- eval_data2tag_arg eta_body
1070 ; return (mkLams eta_bndrs eta_body') }
1071 where
1072 eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
1073 eval_data2tag_arg app@(fun `App` arg)
1074 | exprIsHNF arg -- Includes nullary constructors
1075 = return app -- The arg is evaluated
1076 | otherwise -- Arg not evaluated, so evaluate it
1077 = do { arg_id <- newVar (exprType arg)
1078 ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
1079 ; return (Case arg arg_id1 (exprType app)
1080 [(DEFAULT, [], fun `App` Var arg_id1)]) }
1081
1082 eval_data2tag_arg (Tick t app) -- Scc notes can appear
1083 = do { app' <- eval_data2tag_arg app
1084 ; return (Tick t app') }
1085
1086 eval_data2tag_arg other -- Should not happen
1087 = pprPanic "eval_data2tag" (ppr other)
1088
1089 {- Note [dataToTag magic]
1090 ~~~~~~~~~~~~~~~~~~~~~~~~~
1091 We must ensure that the arg of data2TagOp is evaluated. So
1092 in general CorePrep does this transformation:
1093 data2tag e --> case e of y -> data2tag y
1094 (yuk yuk) take into account the lambdas we've now introduced
1095
1096 How might it not be evaluated? Well, we might have floated it out
1097 of the scope of a `seq`, or dropped the `seq` altogether.
1098
1099 We only do this if 'e' is not a WHNF. But if it's a simple
1100 variable (common case) we need to know its evaluated-ness flag.
1101 Example:
1102 data T = MkT !Bool
1103 f v = case v of
1104 MkT y -> dataToTag# y
1105 Here we don't want to generate an extra case on 'y', because it's
1106 already evaluated. So we want to keep the evaluated-ness flag
1107 on y. See Note [Preserve evaluated-ness in CorePrep].
1108
1109
1110 ************************************************************************
1111 * *
1112 Simple CoreSyn operations
1113 * *
1114 ************************************************************************
1115 -}
1116
1117 {-
1118 -- -----------------------------------------------------------------------------
1119 -- Eta reduction
1120 -- -----------------------------------------------------------------------------
1121
1122 Note [Eta expansion]
1123 ~~~~~~~~~~~~~~~~~~~~~
1124 Eta expand to match the arity claimed by the binder Remember,
1125 CorePrep must not change arity
1126
1127 Eta expansion might not have happened already, because it is done by
1128 the simplifier only when there at least one lambda already.
1129
1130 NB1:we could refrain when the RHS is trivial (which can happen
1131 for exported things). This would reduce the amount of code
1132 generated (a little) and make things a little words for
1133 code compiled without -O. The case in point is data constructor
1134 wrappers.
1135
1136 NB2: we have to be careful that the result of etaExpand doesn't
1137 invalidate any of the assumptions that CorePrep is attempting
1138 to establish. One possible cause is eta expanding inside of
1139 an SCC note - we're now careful in etaExpand to make sure the
1140 SCC is pushed inside any new lambdas that are generated.
1141
1142 Note [Eta expansion and the CorePrep invariants]
1143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1144 It turns out to be much much easier to do eta expansion
1145 *after* the main CorePrep stuff. But that places constraints
1146 on the eta expander: given a CpeRhs, it must return a CpeRhs.
1147
1148 For example here is what we do not want:
1149 f = /\a -> g (h 3) -- h has arity 2
1150 After ANFing we get
1151 f = /\a -> let s = h 3 in g s
1152 and now we do NOT want eta expansion to give
1153 f = /\a -> \ y -> (let s = h 3 in g s) y
1154
1155 Instead CoreArity.etaExpand gives
1156 f = /\a -> \y -> let s = h 3 in g s y
1157 -}
1158
1159 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
1160 cpeEtaExpand arity expr
1161 | arity == 0 = expr
1162 | otherwise = etaExpand arity expr
1163
1164 {-
1165 -- -----------------------------------------------------------------------------
1166 -- Eta reduction
1167 -- -----------------------------------------------------------------------------
1168
1169 Why try eta reduction? Hasn't the simplifier already done eta?
1170 But the simplifier only eta reduces if that leaves something
1171 trivial (like f, or f Int). But for deLam it would be enough to
1172 get to a partial application:
1173 case x of { p -> \xs. map f xs }
1174 ==> case x of { p -> map f }
1175 -}
1176
1177 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
1178 tryEtaReducePrep bndrs expr@(App _ _)
1179 | ok_to_eta_reduce f
1180 , n_remaining >= 0
1181 , and (zipWith ok bndrs last_args)
1182 , not (any (`elemVarSet` fvs_remaining) bndrs)
1183 , exprIsHNF remaining_expr -- Don't turn value into a non-value
1184 -- else the behaviour with 'seq' changes
1185 = Just remaining_expr
1186 where
1187 (f, args) = collectArgs expr
1188 remaining_expr = mkApps f remaining_args
1189 fvs_remaining = exprFreeVars remaining_expr
1190 (remaining_args, last_args) = splitAt n_remaining args
1191 n_remaining = length args - length bndrs
1192
1193 ok bndr (Var arg) = bndr == arg
1194 ok _ _ = False
1195
1196 -- We can't eta reduce something which must be saturated.
1197 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
1198 ok_to_eta_reduce _ = False -- Safe. ToDo: generalise
1199
1200 tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
1201 | not (any (`elemVarSet` fvs) bndrs)
1202 = case tryEtaReducePrep bndrs body of
1203 Just e -> Just (Let bind e)
1204 Nothing -> Nothing
1205 where
1206 fvs = exprFreeVars r
1207
1208 -- NB: do not attempt to eta-reduce across ticks
1209 -- Otherwise we risk reducing
1210 -- \x. (Tick (Breakpoint {x}) f x)
1211 -- ==> Tick (breakpoint {x}) f
1212 -- which is bogus (Trac #17228)
1213 -- tryEtaReducePrep bndrs (Tick tickish e)
1214 -- = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
1215
1216 tryEtaReducePrep _ _ = Nothing
1217
1218 {-
1219 ************************************************************************
1220 * *
1221 Floats
1222 * *
1223 ************************************************************************
1224
1225 Note [Pin demand info on floats]
1226 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1227 We pin demand info on floated lets, so that we can see the one-shot thunks.
1228 -}
1229
1230 data FloatingBind
1231 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
1232 -- They are always of lifted type;
1233 -- unlifted ones are done with FloatCase
1234
1235 | FloatCase
1236 Id CpeBody
1237 Bool -- The bool indicates "ok-for-speculation"
1238
1239 -- | See Note [Floating Ticks in CorePrep]
1240 | FloatTick (Tickish Id)
1241
1242 data Floats = Floats OkToSpec (OrdList FloatingBind)
1243
1244 instance Outputable FloatingBind where
1245 ppr (FloatLet b) = ppr b
1246 ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
1247 ppr (FloatTick t) = ppr t
1248
1249 instance Outputable Floats where
1250 ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>
1251 braces (vcat (map ppr (fromOL fs)))
1252
1253 instance Outputable OkToSpec where
1254 ppr OkToSpec = text "OkToSpec"
1255 ppr IfUnboxedOk = text "IfUnboxedOk"
1256 ppr NotOkToSpec = text "NotOkToSpec"
1257
1258 -- Can we float these binds out of the rhs of a let? We cache this decision
1259 -- to avoid having to recompute it in a non-linear way when there are
1260 -- deeply nested lets.
1261 data OkToSpec
1262 = OkToSpec -- Lazy bindings of lifted type
1263 | IfUnboxedOk -- A mixture of lazy lifted bindings and n
1264 -- ok-to-speculate unlifted bindings
1265 | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
1266
1267 mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
1268 mkFloat dmd is_unlifted bndr rhs
1269 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
1270 | is_hnf = FloatLet (NonRec bndr rhs)
1271 | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
1272 -- See Note [Pin demand info on floats]
1273 where
1274 is_hnf = exprIsHNF rhs
1275 is_strict = isStrictDmd dmd
1276 use_case = is_unlifted || is_strict && not is_hnf
1277 -- Don't make a case for a value binding,
1278 -- even if it's strict. Otherwise we get
1279 -- case (\x -> e) of ...!
1280
1281 emptyFloats :: Floats
1282 emptyFloats = Floats OkToSpec nilOL
1283
1284 isEmptyFloats :: Floats -> Bool
1285 isEmptyFloats (Floats _ bs) = isNilOL bs
1286
1287 wrapBinds :: Floats -> CpeBody -> CpeBody
1288 wrapBinds (Floats _ binds) body
1289 = foldrOL mk_bind body binds
1290 where
1291 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
1292 mk_bind (FloatLet bind) body = Let bind body
1293 mk_bind (FloatTick tickish) body = mkTick tickish body
1294
1295 addFloat :: Floats -> FloatingBind -> Floats
1296 addFloat (Floats ok_to_spec floats) new_float
1297 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
1298 where
1299 check (FloatLet _) = OkToSpec
1300 check (FloatCase _ _ ok_for_spec)
1301 | ok_for_spec = IfUnboxedOk
1302 | otherwise = NotOkToSpec
1303 check FloatTick{} = OkToSpec
1304 -- The ok-for-speculation flag says that it's safe to
1305 -- float this Case out of a let, and thereby do it more eagerly
1306 -- We need the top-level flag because it's never ok to float
1307 -- an unboxed binding to the top level
1308
1309 unitFloat :: FloatingBind -> Floats
1310 unitFloat = addFloat emptyFloats
1311
1312 appendFloats :: Floats -> Floats -> Floats
1313 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
1314 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
1315
1316 concatFloats :: [Floats] -> OrdList FloatingBind
1317 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
1318
1319 combine :: OkToSpec -> OkToSpec -> OkToSpec
1320 combine NotOkToSpec _ = NotOkToSpec
1321 combine _ NotOkToSpec = NotOkToSpec
1322 combine IfUnboxedOk _ = IfUnboxedOk
1323 combine _ IfUnboxedOk = IfUnboxedOk
1324 combine _ _ = OkToSpec
1325
1326 deFloatTop :: Floats -> [CoreBind]
1327 -- For top level only; we don't expect any FloatCases
1328 deFloatTop (Floats _ floats)
1329 = foldrOL get [] floats
1330 where
1331 get (FloatLet b) bs = occurAnalyseRHSs b : bs
1332 get (FloatCase var body _) bs =
1333 occurAnalyseRHSs (NonRec var body) : bs
1334 get b _ = pprPanic "corePrepPgm" (ppr b)
1335
1336 -- See Note [Dead code in CorePrep]
1337 occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
1338 occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]
1339
1340 ---------------------------------------------------------------------------
1341
1342 canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
1343 -- Note [CafInfo and floating]
1344 canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
1345 | OkToSpec <- ok_to_spec -- Worth trying
1346 , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
1347 = Just (Floats OkToSpec fs', subst_expr subst rhs)
1348 | otherwise
1349 = Nothing
1350 where
1351 subst_expr = substExpr (text "CorePrep")
1352
1353 go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
1354 -> Maybe (Subst, OrdList FloatingBind)
1355
1356 go (subst, fbs_out) [] = Just (subst, fbs_out)
1357
1358 go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
1359 | rhs_ok r
1360 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1361 where
1362 (subst', b') = set_nocaf_bndr subst b
1363 new_fb = FloatLet (NonRec b' (subst_expr subst r))
1364
1365 go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
1366 | all rhs_ok rs
1367 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1368 where
1369 (bs,rs) = unzip prs
1370 (subst', bs') = mapAccumL set_nocaf_bndr subst bs
1371 rs' = map (subst_expr subst') rs
1372 new_fb = FloatLet (Rec (bs' `zip` rs'))
1373
1374 go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
1375 = go (subst, fbs_out `snocOL` ft) fbs_in
1376
1377 go _ _ = Nothing -- Encountered a caffy binding
1378
1379 ------------
1380 set_nocaf_bndr subst bndr
1381 = (extendIdSubst subst bndr (Var bndr'), bndr')
1382 where
1383 bndr' = bndr `setIdCafInfo` NoCafRefs
1384
1385 ------------
1386 rhs_ok :: CoreExpr -> Bool
1387 -- We can only float to top level from a NoCaf thing if
1388 -- the new binding is static. However it can't mention
1389 -- any non-static things or it would *already* be Caffy
1390 rhs_ok = rhsIsStatic platform (\_ -> False)
1391 (\i -> pprPanic "rhsIsStatic" (integer i))
1392 -- Integer literals should not show up
1393
1394 wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
1395 wantFloatNested is_rec dmd is_unlifted floats rhs
1396 = isEmptyFloats floats
1397 || isStrictDmd dmd
1398 || is_unlifted
1399 || (allLazyNested is_rec floats && exprIsHNF rhs)
1400 -- Why the test for allLazyNested?
1401 -- v = f (x `divInt#` y)
1402 -- we don't want to float the case, even if f has arity 2,
1403 -- because floating the case would make it evaluated too early
1404
1405 allLazyTop :: Floats -> Bool
1406 allLazyTop (Floats OkToSpec _) = True
1407 allLazyTop _ = False
1408
1409 allLazyNested :: RecFlag -> Floats -> Bool
1410 allLazyNested _ (Floats OkToSpec _) = True
1411 allLazyNested _ (Floats NotOkToSpec _) = False
1412 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
1413
1414 {-
1415 ************************************************************************
1416 * *
1417 Cloning
1418 * *
1419 ************************************************************************
1420 -}
1421
1422 -- ---------------------------------------------------------------------------
1423 -- The environment
1424 -- ---------------------------------------------------------------------------
1425
1426 -- Note [Inlining in CorePrep]
1427 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1428 -- There is a subtle but important invariant that must be upheld in the output
1429 -- of CorePrep: there are no "trivial" updatable thunks. Thus, this Core
1430 -- is impermissible:
1431 --
1432 -- let x :: ()
1433 -- x = y
1434 --
1435 -- (where y is a reference to a GLOBAL variable). Thunks like this are silly:
1436 -- they can always be profitably replaced by inlining x with y. Consequently,
1437 -- the code generator/runtime does not bother implementing this properly
1438 -- (specifically, there is no implementation of stg_ap_0_upd_info, which is the
1439 -- stack frame that would be used to update this thunk. The "0" means it has
1440 -- zero free variables.)
1441 --
1442 -- In general, the inliner is good at eliminating these let-bindings. However,
1443 -- there is one case where these trivial updatable thunks can arise: when
1444 -- we are optimizing away 'lazy' (see Note [lazyId magic], and also
1445 -- 'cpeRhsE'.) Then, we could have started with:
1446 --
1447 -- let x :: ()
1448 -- x = lazy @ () y
1449 --
1450 -- which is a perfectly fine, non-trivial thunk, but then CorePrep will
1451 -- drop 'lazy', giving us 'x = y' which is trivial and impermissible.
1452 -- The solution is CorePrep to have a miniature inlining pass which deals
1453 -- with cases like this. We can then drop the let-binding altogether.
1454 --
1455 -- Why does the removal of 'lazy' have to occur in CorePrep?
1456 -- The gory details are in Note [lazyId magic] in MkId, but the
1457 -- main reason is that lazy must appear in unfoldings (optimizer
1458 -- output) and it must prevent call-by-value for catch# (which
1459 -- is implemented by CorePrep.)
1460 --
1461 -- An alternate strategy for solving this problem is to have the
1462 -- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
1463 -- We decided not to adopt this solution to keep the definition
1464 -- of 'exprIsTrivial' simple.
1465 --
1466 -- There is ONE caveat however: for top-level bindings we have
1467 -- to preserve the binding so that we float the (hacky) non-recursive
1468 -- binding for data constructors; see Note [Data constructor workers].
1469 --
1470 -- Note [CorePrep inlines trivial CoreExpr not Id]
1471 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1472 -- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
1473 -- IdEnv Id? Naively, we might conjecture that trivial updatable thunks
1474 -- as per Note [Inlining in CorePrep] always have the form
1475 -- 'lazy @ SomeType gbl_id'. But this is not true: the following is
1476 -- perfectly reasonable Core:
1477 --
1478 -- let x :: ()
1479 -- x = lazy @ (forall a. a) y @ Bool
1480 --
1481 -- When we inline 'x' after eliminating 'lazy', we need to replace
1482 -- occurrences of 'x' with 'y @ bool', not just 'y'. Situations like
1483 -- this can easily arise with higher-rank types; thus, cpe_env must
1484 -- map to CoreExprs, not Ids.
1485
1486 data CorePrepEnv
1487 = CPE { cpe_dynFlags :: DynFlags
1488 , cpe_env :: IdEnv CoreExpr -- Clone local Ids
1489 -- ^ This environment is used for three operations:
1490 --
1491 -- 1. To support cloning of local Ids so that they are
1492 -- all unique (see item (6) of CorePrep overview).
1493 --
1494 -- 2. To support beta-reduction of runRW, see
1495 -- Note [runRW magic] and Note [runRW arg].
1496 --
1497 -- 3. To let us inline trivial RHSs of non top-level let-bindings,
1498 -- see Note [lazyId magic], Note [Inlining in CorePrep]
1499 -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
1500 , cpe_mkIntegerId :: Id
1501 , cpe_integerSDataCon :: Maybe DataCon
1502 }
1503
1504 lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
1505 lookupMkIntegerName dflags hsc_env
1506 = guardIntegerUse dflags $ liftM tyThingId $
1507 lookupGlobal hsc_env mkIntegerName
1508
1509 lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
1510 lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
1511 IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
1512 lookupGlobal hsc_env integerSDataConName
1513 IntegerSimple -> return Nothing
1514
1515 -- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
1516 guardIntegerUse :: DynFlags -> IO a -> IO a
1517 guardIntegerUse dflags act
1518 | thisPackage dflags == primUnitId
1519 = return $ panic "Can't use Integer in ghc-prim"
1520 | thisPackage dflags == integerUnitId
1521 = return $ panic "Can't use Integer in integer-*"
1522 | otherwise = act
1523
1524 mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
1525 mkInitialCorePrepEnv dflags hsc_env
1526 = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
1527 integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
1528 return $ CPE {
1529 cpe_dynFlags = dflags,
1530 cpe_env = emptyVarEnv,
1531 cpe_mkIntegerId = mkIntegerId,
1532 cpe_integerSDataCon = integerSDataCon
1533 }
1534
1535 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
1536 extendCorePrepEnv cpe id id'
1537 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }
1538
1539 extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
1540 extendCorePrepEnvExpr cpe id expr
1541 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }
1542
1543 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
1544 extendCorePrepEnvList cpe prs
1545 = cpe { cpe_env = extendVarEnvList (cpe_env cpe)
1546 (map (\(id, id') -> (id, Var id')) prs) }
1547
1548 lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
1549 lookupCorePrepEnv cpe id
1550 = case lookupVarEnv (cpe_env cpe) id of
1551 Nothing -> Var id
1552 Just exp -> exp
1553
1554 getMkIntegerId :: CorePrepEnv -> Id
1555 getMkIntegerId = cpe_mkIntegerId
1556
1557 ------------------------------------------------------------------------------
1558 -- Cloning binders
1559 -- ---------------------------------------------------------------------------
1560
1561 cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
1562 cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
1563
1564 cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
1565 cpCloneBndr env bndr
1566 | not (isId bndr)
1567 = return (env, bndr)
1568
1569 | otherwise
1570 = do { bndr' <- clone_it bndr
1571
1572 -- Drop (now-useless) rules/unfoldings
1573 -- See Note [Drop unfoldings and rules]
1574 -- and Note [Preserve evaluated-ness in CorePrep]
1575 ; let unfolding' = zapUnfolding (realIdUnfolding bndr)
1576 -- Simplifier will set the Id's unfolding
1577
1578 bndr'' = bndr' `setIdUnfolding` unfolding'
1579 `setIdSpecialisation` emptyRuleInfo
1580
1581 ; return (extendCorePrepEnv env bndr bndr'', bndr'') }
1582 where
1583 clone_it bndr
1584 | isLocalId bndr, not (isCoVar bndr)
1585 = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }
1586 | otherwise -- Top level things, which we don't want
1587 -- to clone, have become GlobalIds by now
1588 -- And we don't clone tyvars, or coercion variables
1589 = return bndr
1590
1591 {- Note [Drop unfoldings and rules]
1592 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1593 We want to drop the unfolding/rules on every Id:
1594
1595 - We are now past interface-file generation, and in the
1596 codegen pipeline, so we really don't need full unfoldings/rules
1597
1598 - The unfolding/rule may be keeping stuff alive that we'd like
1599 to discard. See Note [Dead code in CorePrep]
1600
1601 - Getting rid of unnecessary unfoldings reduces heap usage
1602
1603 - We are changing uniques, so if we didn't discard unfoldings/rules
1604 we'd have to substitute in them
1605
1606 HOWEVER, we want to preserve evaluated-ness; see
1607 Note [Preserve evaluated-ness in CorePrep]
1608
1609 Note [Preserve evaluated-ness in CorePrep]
1610 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1611 We want to preserve the evaluated-ness of each binder (via
1612 evaldUnfolding) for two reasons
1613
1614 * In the code generator if we have
1615 case x of y { Red -> e1; DEFAULT -> y }
1616 we can return 'y' rather than entering it, if we know
1617 it is evaluated (Trac #14626)
1618
1619 * In the DataToTag magic (in CorePrep itself) we rely on
1620 evaluated-ness. See Note Note [dataToTag magic].
1621 -}
1622
1623 ------------------------------------------------------------------------------
1624 -- Cloning ccall Ids; each must have a unique name,
1625 -- to give the code generator a handle to hang it on
1626 -- ---------------------------------------------------------------------------
1627
1628 fiddleCCall :: Id -> UniqSM Id
1629 fiddleCCall id
1630 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
1631 | otherwise = return id
1632
1633 ------------------------------------------------------------------------------
1634 -- Generating new binders
1635 -- ---------------------------------------------------------------------------
1636
1637 newVar :: Type -> UniqSM Id
1638 newVar ty
1639 = seqType ty `seq` do
1640 uniq <- getUniqueM
1641 return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)
1642
1643
1644 ------------------------------------------------------------------------------
1645 -- Floating ticks
1646 -- ---------------------------------------------------------------------------
1647 --
1648 -- Note [Floating Ticks in CorePrep]
1649 --
1650 -- It might seem counter-intuitive to float ticks by default, given
1651 -- that we don't actually want to move them if we can help it. On the
1652 -- other hand, nothing gets very far in CorePrep anyway, and we want
1653 -- to preserve the order of let bindings and tick annotations in
1654 -- relation to each other. For example, if we just wrapped let floats
1655 -- when they pass through ticks, we might end up performing the
1656 -- following transformation:
1657 --
1658 -- src<...> let foo = bar in baz
1659 -- ==> let foo = src<...> bar in src<...> baz
1660 --
1661 -- Because the let-binding would float through the tick, and then
1662 -- immediately materialize, achieving nothing but decreasing tick
1663 -- accuracy. The only special case is the following scenario:
1664 --
1665 -- let foo = src<...> (let a = b in bar) in baz
1666 -- ==> let foo = src<...> bar; a = src<...> b in baz
1667 --
1668 -- Here we would not want the source tick to end up covering "baz" and
1669 -- therefore refrain from pushing ticks outside. Instead, we copy them
1670 -- into the floating binds (here "a") in cpePair. Note that where "b"
1671 -- or "bar" are (value) lambdas we have to push the annotations
1672 -- further inside in order to uphold our rules.
1673 --
1674 -- All of this is implemented below in @wrapTicks@.
1675
1676 -- | Like wrapFloats, but only wraps tick floats
1677 wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
1678 wrapTicks (Floats flag floats0) expr =
1679 (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))
1680 where (floats1, ticks1) = foldlOL go ([], []) $ floats0
1681 -- Deeply nested constructors will produce long lists of
1682 -- redundant source note floats here. We need to eliminate
1683 -- those early, as relying on mkTick to spot it after the fact
1684 -- can yield O(n^3) complexity [#11095]
1685 go (floats, ticks) (FloatTick t)
1686 = ASSERT(tickishPlace t == PlaceNonLam)
1687 (floats, if any (flip tickishContains t) ticks
1688 then ticks else t:ticks)
1689 go (floats, ticks) f
1690 = (foldr wrap f (reverse ticks):floats, ticks)
1691
1692 wrap t (FloatLet bind) = FloatLet (wrapBind t bind)
1693 wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
1694 wrap _ other = pprPanic "wrapTicks: unexpected float!"
1695 (ppr other)
1696 wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
1697 wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs)
1698
1699 ------------------------------------------------------------------------------
1700 -- Collecting cost centres
1701 -- ---------------------------------------------------------------------------
1702
1703 -- | Collect cost centres defined in the current module, including those in
1704 -- unfoldings.
1705 collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre
1706 collectCostCentres mod_name
1707 = foldl' go_bind S.empty
1708 where
1709 go cs e = case e of
1710 Var{} -> cs
1711 Lit{} -> cs
1712 App e1 e2 -> go (go cs e1) e2
1713 Lam _ e -> go cs e
1714 Let b e -> go (go_bind cs b) e
1715 Case scrt _ _ alts -> go_alts (go cs scrt) alts
1716 Cast e _ -> go cs e
1717 Tick (ProfNote cc _ _) e ->
1718 go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e
1719 Tick _ e -> go cs e
1720 Type{} -> cs
1721 Coercion{} -> cs
1722
1723 go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e)
1724
1725 go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre
1726 go_bind cs (NonRec b e) =
1727 go (maybe cs (go cs) (get_unf b)) e
1728 go_bind cs (Rec bs) =
1729 foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs
1730
1731 -- Unfoldings may have cost centres that in the original definion are
1732 -- optimized away, see #5889.
1733 get_unf = maybeUnfoldingTemplate . realIdUnfolding