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