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