Strip parentheses in expressions contexts in error messages
[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 GHC.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 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 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 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 -- No eta-expansion: see Note [Do not eta-expand join points] in SimplUtils
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 #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 #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 Note [Eta expansion of hasNoBinding things in CorePrep]
1068 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1069 maybeSaturate deals with eta expanding to saturate things that can't deal with
1070 unsaturated applications (identified by 'hasNoBinding', currently just
1071 foreign calls and unboxed tuple/sum constructors).
1072
1073 Note that eta expansion in CorePrep is very fragile due to the "prediction" of
1074 CAFfyness made by TidyPgm (see Note [CAFfyness inconsistencies due to eta
1075 expansion in CorePrep] in TidyPgm for details. We previously saturated primop
1076 applications here as well but due to this fragility (see #16846) we now deal
1077 with this another way, as described in Note [Primop wrappers] in PrimOp.
1078
1079 It's quite likely that eta expansion of constructor applications will
1080 eventually break in a similar way to how primops did. We really should
1081 eliminate this case as well.
1082 -}
1083
1084 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
1085 maybeSaturate fn expr n_args
1086 | hasNoBinding fn -- There's no binding
1087 = return sat_expr
1088
1089 | otherwise
1090 = return expr
1091 where
1092 fn_arity = idArity fn
1093 excess_arity = fn_arity - n_args
1094 sat_expr = cpeEtaExpand excess_arity expr
1095
1096 {-
1097 ************************************************************************
1098 * *
1099 Simple CoreSyn operations
1100 * *
1101 ************************************************************************
1102 -}
1103
1104 {-
1105 -- -----------------------------------------------------------------------------
1106 -- Eta reduction
1107 -- -----------------------------------------------------------------------------
1108
1109 Note [Eta expansion]
1110 ~~~~~~~~~~~~~~~~~~~~~
1111 Eta expand to match the arity claimed by the binder Remember,
1112 CorePrep must not change arity
1113
1114 Eta expansion might not have happened already, because it is done by
1115 the simplifier only when there at least one lambda already.
1116
1117 NB1:we could refrain when the RHS is trivial (which can happen
1118 for exported things). This would reduce the amount of code
1119 generated (a little) and make things a little words for
1120 code compiled without -O. The case in point is data constructor
1121 wrappers.
1122
1123 NB2: we have to be careful that the result of etaExpand doesn't
1124 invalidate any of the assumptions that CorePrep is attempting
1125 to establish. One possible cause is eta expanding inside of
1126 an SCC note - we're now careful in etaExpand to make sure the
1127 SCC is pushed inside any new lambdas that are generated.
1128
1129 Note [Eta expansion and the CorePrep invariants]
1130 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1131 It turns out to be much much easier to do eta expansion
1132 *after* the main CorePrep stuff. But that places constraints
1133 on the eta expander: given a CpeRhs, it must return a CpeRhs.
1134
1135 For example here is what we do not want:
1136 f = /\a -> g (h 3) -- h has arity 2
1137 After ANFing we get
1138 f = /\a -> let s = h 3 in g s
1139 and now we do NOT want eta expansion to give
1140 f = /\a -> \ y -> (let s = h 3 in g s) y
1141
1142 Instead CoreArity.etaExpand gives
1143 f = /\a -> \y -> let s = h 3 in g s y
1144 -}
1145
1146 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
1147 cpeEtaExpand arity expr
1148 | arity == 0 = expr
1149 | otherwise = etaExpand arity expr
1150
1151 {-
1152 -- -----------------------------------------------------------------------------
1153 -- Eta reduction
1154 -- -----------------------------------------------------------------------------
1155
1156 Why try eta reduction? Hasn't the simplifier already done eta?
1157 But the simplifier only eta reduces if that leaves something
1158 trivial (like f, or f Int). But for deLam it would be enough to
1159 get to a partial application:
1160 case x of { p -> \xs. map f xs }
1161 ==> case x of { p -> map f }
1162 -}
1163
1164 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
1165 tryEtaReducePrep bndrs expr@(App _ _)
1166 | ok_to_eta_reduce f
1167 , n_remaining >= 0
1168 , and (zipWith ok bndrs last_args)
1169 , not (any (`elemVarSet` fvs_remaining) bndrs)
1170 , exprIsHNF remaining_expr -- Don't turn value into a non-value
1171 -- else the behaviour with 'seq' changes
1172 = Just remaining_expr
1173 where
1174 (f, args) = collectArgs expr
1175 remaining_expr = mkApps f remaining_args
1176 fvs_remaining = exprFreeVars remaining_expr
1177 (remaining_args, last_args) = splitAt n_remaining args
1178 n_remaining = length args - length bndrs
1179
1180 ok bndr (Var arg) = bndr == arg
1181 ok _ _ = False
1182
1183 -- We can't eta reduce something which must be saturated.
1184 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
1185 ok_to_eta_reduce _ = False -- Safe. ToDo: generalise
1186
1187 tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
1188 | not (any (`elemVarSet` fvs) bndrs)
1189 = case tryEtaReducePrep bndrs body of
1190 Just e -> Just (Let bind e)
1191 Nothing -> Nothing
1192 where
1193 fvs = exprFreeVars r
1194
1195 -- NB: do not attempt to eta-reduce across ticks
1196 -- Otherwise we risk reducing
1197 -- \x. (Tick (Breakpoint {x}) f x)
1198 -- ==> Tick (breakpoint {x}) f
1199 -- which is bogus (#17228)
1200 -- tryEtaReducePrep bndrs (Tick tickish e)
1201 -- = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
1202
1203 tryEtaReducePrep _ _ = Nothing
1204
1205 {-
1206 ************************************************************************
1207 * *
1208 Floats
1209 * *
1210 ************************************************************************
1211
1212 Note [Pin demand info on floats]
1213 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1214 We pin demand info on floated lets, so that we can see the one-shot thunks.
1215 -}
1216
1217 data FloatingBind
1218 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
1219 -- They are always of lifted type;
1220 -- unlifted ones are done with FloatCase
1221
1222 | FloatCase
1223 Id CpeBody
1224 Bool -- The bool indicates "ok-for-speculation"
1225
1226 -- | See Note [Floating Ticks in CorePrep]
1227 | FloatTick (Tickish Id)
1228
1229 data Floats = Floats OkToSpec (OrdList FloatingBind)
1230
1231 instance Outputable FloatingBind where
1232 ppr (FloatLet b) = ppr b
1233 ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
1234 ppr (FloatTick t) = ppr t
1235
1236 instance Outputable Floats where
1237 ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>
1238 braces (vcat (map ppr (fromOL fs)))
1239
1240 instance Outputable OkToSpec where
1241 ppr OkToSpec = text "OkToSpec"
1242 ppr IfUnboxedOk = text "IfUnboxedOk"
1243 ppr NotOkToSpec = text "NotOkToSpec"
1244
1245 -- Can we float these binds out of the rhs of a let? We cache this decision
1246 -- to avoid having to recompute it in a non-linear way when there are
1247 -- deeply nested lets.
1248 data OkToSpec
1249 = OkToSpec -- Lazy bindings of lifted type
1250 | IfUnboxedOk -- A mixture of lazy lifted bindings and n
1251 -- ok-to-speculate unlifted bindings
1252 | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
1253
1254 mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
1255 mkFloat dmd is_unlifted bndr rhs
1256 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
1257 | is_hnf = FloatLet (NonRec bndr rhs)
1258 | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
1259 -- See Note [Pin demand info on floats]
1260 where
1261 is_hnf = exprIsHNF rhs
1262 is_strict = isStrictDmd dmd
1263 use_case = is_unlifted || is_strict && not is_hnf
1264 -- Don't make a case for a value binding,
1265 -- even if it's strict. Otherwise we get
1266 -- case (\x -> e) of ...!
1267
1268 emptyFloats :: Floats
1269 emptyFloats = Floats OkToSpec nilOL
1270
1271 isEmptyFloats :: Floats -> Bool
1272 isEmptyFloats (Floats _ bs) = isNilOL bs
1273
1274 wrapBinds :: Floats -> CpeBody -> CpeBody
1275 wrapBinds (Floats _ binds) body
1276 = foldrOL mk_bind body binds
1277 where
1278 mk_bind (FloatCase bndr rhs _) body = mkDefaultCase rhs bndr body
1279 mk_bind (FloatLet bind) body = Let bind body
1280 mk_bind (FloatTick tickish) body = mkTick tickish body
1281
1282 addFloat :: Floats -> FloatingBind -> Floats
1283 addFloat (Floats ok_to_spec floats) new_float
1284 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
1285 where
1286 check (FloatLet _) = OkToSpec
1287 check (FloatCase _ _ ok_for_spec)
1288 | ok_for_spec = IfUnboxedOk
1289 | otherwise = NotOkToSpec
1290 check FloatTick{} = OkToSpec
1291 -- The ok-for-speculation flag says that it's safe to
1292 -- float this Case out of a let, and thereby do it more eagerly
1293 -- We need the top-level flag because it's never ok to float
1294 -- an unboxed binding to the top level
1295
1296 unitFloat :: FloatingBind -> Floats
1297 unitFloat = addFloat emptyFloats
1298
1299 appendFloats :: Floats -> Floats -> Floats
1300 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
1301 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
1302
1303 concatFloats :: [Floats] -> OrdList FloatingBind
1304 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
1305
1306 combine :: OkToSpec -> OkToSpec -> OkToSpec
1307 combine NotOkToSpec _ = NotOkToSpec
1308 combine _ NotOkToSpec = NotOkToSpec
1309 combine IfUnboxedOk _ = IfUnboxedOk
1310 combine _ IfUnboxedOk = IfUnboxedOk
1311 combine _ _ = OkToSpec
1312
1313 deFloatTop :: Floats -> [CoreBind]
1314 -- For top level only; we don't expect any FloatCases
1315 deFloatTop (Floats _ floats)
1316 = foldrOL get [] floats
1317 where
1318 get (FloatLet b) bs = occurAnalyseRHSs b : bs
1319 get (FloatCase var body _) bs =
1320 occurAnalyseRHSs (NonRec var body) : bs
1321 get b _ = pprPanic "corePrepPgm" (ppr b)
1322
1323 -- See Note [Dead code in CorePrep]
1324 occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
1325 occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]
1326
1327 ---------------------------------------------------------------------------
1328
1329 canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
1330 -- Note [CafInfo and floating]
1331 canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
1332 | OkToSpec <- ok_to_spec -- Worth trying
1333 , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
1334 = Just (Floats OkToSpec fs', subst_expr subst rhs)
1335 | otherwise
1336 = Nothing
1337 where
1338 subst_expr = substExpr (text "CorePrep")
1339
1340 go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
1341 -> Maybe (Subst, OrdList FloatingBind)
1342
1343 go (subst, fbs_out) [] = Just (subst, fbs_out)
1344
1345 go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
1346 | rhs_ok r
1347 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1348 where
1349 (subst', b') = set_nocaf_bndr subst b
1350 new_fb = FloatLet (NonRec b' (subst_expr subst r))
1351
1352 go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
1353 | all rhs_ok rs
1354 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1355 where
1356 (bs,rs) = unzip prs
1357 (subst', bs') = mapAccumL set_nocaf_bndr subst bs
1358 rs' = map (subst_expr subst') rs
1359 new_fb = FloatLet (Rec (bs' `zip` rs'))
1360
1361 go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
1362 = go (subst, fbs_out `snocOL` ft) fbs_in
1363
1364 go _ _ = Nothing -- Encountered a caffy binding
1365
1366 ------------
1367 set_nocaf_bndr subst bndr
1368 = (extendIdSubst subst bndr (Var bndr'), bndr')
1369 where
1370 bndr' = bndr `setIdCafInfo` NoCafRefs
1371
1372 ------------
1373 rhs_ok :: CoreExpr -> Bool
1374 -- We can only float to top level from a NoCaf thing if
1375 -- the new binding is static. However it can't mention
1376 -- any non-static things or it would *already* be Caffy
1377 rhs_ok = rhsIsStatic platform (\_ -> False)
1378 (\_nt i -> pprPanic "rhsIsStatic" (integer i))
1379 -- Integer or Natural literals should not show up
1380
1381 wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
1382 wantFloatNested is_rec dmd is_unlifted floats rhs
1383 = isEmptyFloats floats
1384 || isStrictDmd dmd
1385 || is_unlifted
1386 || (allLazyNested is_rec floats && exprIsHNF rhs)
1387 -- Why the test for allLazyNested?
1388 -- v = f (x `divInt#` y)
1389 -- we don't want to float the case, even if f has arity 2,
1390 -- because floating the case would make it evaluated too early
1391
1392 allLazyTop :: Floats -> Bool
1393 allLazyTop (Floats OkToSpec _) = True
1394 allLazyTop _ = False
1395
1396 allLazyNested :: RecFlag -> Floats -> Bool
1397 allLazyNested _ (Floats OkToSpec _) = True
1398 allLazyNested _ (Floats NotOkToSpec _) = False
1399 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
1400
1401 {-
1402 ************************************************************************
1403 * *
1404 Cloning
1405 * *
1406 ************************************************************************
1407 -}
1408
1409 -- ---------------------------------------------------------------------------
1410 -- The environment
1411 -- ---------------------------------------------------------------------------
1412
1413 -- Note [Inlining in CorePrep]
1414 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1415 -- There is a subtle but important invariant that must be upheld in the output
1416 -- of CorePrep: there are no "trivial" updatable thunks. Thus, this Core
1417 -- is impermissible:
1418 --
1419 -- let x :: ()
1420 -- x = y
1421 --
1422 -- (where y is a reference to a GLOBAL variable). Thunks like this are silly:
1423 -- they can always be profitably replaced by inlining x with y. Consequently,
1424 -- the code generator/runtime does not bother implementing this properly
1425 -- (specifically, there is no implementation of stg_ap_0_upd_info, which is the
1426 -- stack frame that would be used to update this thunk. The "0" means it has
1427 -- zero free variables.)
1428 --
1429 -- In general, the inliner is good at eliminating these let-bindings. However,
1430 -- there is one case where these trivial updatable thunks can arise: when
1431 -- we are optimizing away 'lazy' (see Note [lazyId magic], and also
1432 -- 'cpeRhsE'.) Then, we could have started with:
1433 --
1434 -- let x :: ()
1435 -- x = lazy @ () y
1436 --
1437 -- which is a perfectly fine, non-trivial thunk, but then CorePrep will
1438 -- drop 'lazy', giving us 'x = y' which is trivial and impermissible.
1439 -- The solution is CorePrep to have a miniature inlining pass which deals
1440 -- with cases like this. We can then drop the let-binding altogether.
1441 --
1442 -- Why does the removal of 'lazy' have to occur in CorePrep?
1443 -- The gory details are in Note [lazyId magic] in MkId, but the
1444 -- main reason is that lazy must appear in unfoldings (optimizer
1445 -- output) and it must prevent call-by-value for catch# (which
1446 -- is implemented by CorePrep.)
1447 --
1448 -- An alternate strategy for solving this problem is to have the
1449 -- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
1450 -- We decided not to adopt this solution to keep the definition
1451 -- of 'exprIsTrivial' simple.
1452 --
1453 -- There is ONE caveat however: for top-level bindings we have
1454 -- to preserve the binding so that we float the (hacky) non-recursive
1455 -- binding for data constructors; see Note [Data constructor workers].
1456 --
1457 -- Note [CorePrep inlines trivial CoreExpr not Id]
1458 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1459 -- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
1460 -- IdEnv Id? Naively, we might conjecture that trivial updatable thunks
1461 -- as per Note [Inlining in CorePrep] always have the form
1462 -- 'lazy @ SomeType gbl_id'. But this is not true: the following is
1463 -- perfectly reasonable Core:
1464 --
1465 -- let x :: ()
1466 -- x = lazy @ (forall a. a) y @ Bool
1467 --
1468 -- When we inline 'x' after eliminating 'lazy', we need to replace
1469 -- occurrences of 'x' with 'y @ bool', not just 'y'. Situations like
1470 -- this can easily arise with higher-rank types; thus, cpe_env must
1471 -- map to CoreExprs, not Ids.
1472
1473 data CorePrepEnv
1474 = CPE { cpe_dynFlags :: DynFlags
1475 , cpe_env :: IdEnv CoreExpr -- Clone local Ids
1476 -- ^ This environment is used for three operations:
1477 --
1478 -- 1. To support cloning of local Ids so that they are
1479 -- all unique (see item (6) of CorePrep overview).
1480 --
1481 -- 2. To support beta-reduction of runRW, see
1482 -- Note [runRW magic] and Note [runRW arg].
1483 --
1484 -- 3. To let us inline trivial RHSs of non top-level let-bindings,
1485 -- see Note [lazyId magic], Note [Inlining in CorePrep]
1486 -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
1487 , cpe_mkIntegerId :: Id
1488 , cpe_mkNaturalId :: Id
1489 , cpe_integerSDataCon :: Maybe DataCon
1490 , cpe_naturalSDataCon :: Maybe DataCon
1491 }
1492
1493 lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
1494 lookupMkIntegerName dflags hsc_env
1495 = guardIntegerUse dflags $ liftM tyThingId $
1496 lookupGlobal hsc_env mkIntegerName
1497
1498 lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id
1499 lookupMkNaturalName dflags hsc_env
1500 = guardNaturalUse dflags $ liftM tyThingId $
1501 lookupGlobal hsc_env mkNaturalName
1502
1503 -- See Note [The integer library] in PrelNames
1504 lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
1505 lookupIntegerSDataConName dflags hsc_env = case integerLibrary dflags of
1506 IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
1507 lookupGlobal hsc_env integerSDataConName
1508 IntegerSimple -> return Nothing
1509
1510 lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
1511 lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of
1512 IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $
1513 lookupGlobal hsc_env naturalSDataConName
1514 IntegerSimple -> return Nothing
1515
1516 -- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'
1517 guardIntegerUse :: DynFlags -> IO a -> IO a
1518 guardIntegerUse dflags act
1519 | thisPackage dflags == primUnitId
1520 = return $ panic "Can't use Integer in ghc-prim"
1521 | thisPackage dflags == integerUnitId
1522 = return $ panic "Can't use Integer in integer-*"
1523 | otherwise = act
1524
1525 -- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'
1526 --
1527 -- Just like we can't use Integer literals in `integer-*`, we can't use Natural
1528 -- literals in `base`. If we do, we get interface loading error for GHC.Natural.
1529 guardNaturalUse :: DynFlags -> IO a -> IO a
1530 guardNaturalUse dflags act
1531 | thisPackage dflags == primUnitId
1532 = return $ panic "Can't use Natural in ghc-prim"
1533 | thisPackage dflags == integerUnitId
1534 = return $ panic "Can't use Natural in integer-*"
1535 | thisPackage dflags == baseUnitId
1536 = return $ panic "Can't use Natural in base"
1537 | otherwise = act
1538
1539 mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
1540 mkInitialCorePrepEnv dflags hsc_env
1541 = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
1542 mkNaturalId <- lookupMkNaturalName dflags hsc_env
1543 integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
1544 naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
1545 return $ CPE {
1546 cpe_dynFlags = dflags,
1547 cpe_env = emptyVarEnv,
1548 cpe_mkIntegerId = mkIntegerId,
1549 cpe_mkNaturalId = mkNaturalId,
1550 cpe_integerSDataCon = integerSDataCon,
1551 cpe_naturalSDataCon = naturalSDataCon
1552 }
1553
1554 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
1555 extendCorePrepEnv cpe id id'
1556 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }
1557
1558 extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
1559 extendCorePrepEnvExpr cpe id expr
1560 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }
1561
1562 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
1563 extendCorePrepEnvList cpe prs
1564 = cpe { cpe_env = extendVarEnvList (cpe_env cpe)
1565 (map (\(id, id') -> (id, Var id')) prs) }
1566
1567 lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
1568 lookupCorePrepEnv cpe id
1569 = case lookupVarEnv (cpe_env cpe) id of
1570 Nothing -> Var id
1571 Just exp -> exp
1572
1573 getMkIntegerId :: CorePrepEnv -> Id
1574 getMkIntegerId = cpe_mkIntegerId
1575
1576 getMkNaturalId :: CorePrepEnv -> Id
1577 getMkNaturalId = cpe_mkNaturalId
1578
1579 ------------------------------------------------------------------------------
1580 -- Cloning binders
1581 -- ---------------------------------------------------------------------------
1582
1583 cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
1584 cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
1585
1586 cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
1587 cpCloneBndr env bndr
1588 | not (isId bndr)
1589 = return (env, bndr)
1590
1591 | otherwise
1592 = do { bndr' <- clone_it bndr
1593
1594 -- Drop (now-useless) rules/unfoldings
1595 -- See Note [Drop unfoldings and rules]
1596 -- and Note [Preserve evaluatedness] in CoreTidy
1597 ; let unfolding' = zapUnfolding (realIdUnfolding bndr)
1598 -- Simplifier will set the Id's unfolding
1599
1600 bndr'' = bndr' `setIdUnfolding` unfolding'
1601 `setIdSpecialisation` emptyRuleInfo
1602
1603 ; return (extendCorePrepEnv env bndr bndr'', bndr'') }
1604 where
1605 clone_it bndr
1606 | isLocalId bndr, not (isCoVar bndr)
1607 = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }
1608 | otherwise -- Top level things, which we don't want
1609 -- to clone, have become GlobalIds by now
1610 -- And we don't clone tyvars, or coercion variables
1611 = return bndr
1612
1613 {- Note [Drop unfoldings and rules]
1614 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1615 We want to drop the unfolding/rules on every Id:
1616
1617 - We are now past interface-file generation, and in the
1618 codegen pipeline, so we really don't need full unfoldings/rules
1619
1620 - The unfolding/rule may be keeping stuff alive that we'd like
1621 to discard. See Note [Dead code in CorePrep]
1622
1623 - Getting rid of unnecessary unfoldings reduces heap usage
1624
1625 - We are changing uniques, so if we didn't discard unfoldings/rules
1626 we'd have to substitute in them
1627
1628 HOWEVER, we want to preserve evaluated-ness;
1629 see Note [Preserve evaluatedness] in CoreTidy.
1630 -}
1631
1632 ------------------------------------------------------------------------------
1633 -- Cloning ccall Ids; each must have a unique name,
1634 -- to give the code generator a handle to hang it on
1635 -- ---------------------------------------------------------------------------
1636
1637 fiddleCCall :: Id -> UniqSM Id
1638 fiddleCCall id
1639 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
1640 | otherwise = return id
1641
1642 ------------------------------------------------------------------------------
1643 -- Generating new binders
1644 -- ---------------------------------------------------------------------------
1645
1646 newVar :: Type -> UniqSM Id
1647 newVar ty
1648 = seqType ty `seq` do
1649 uniq <- getUniqueM
1650 return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)
1651
1652
1653 ------------------------------------------------------------------------------
1654 -- Floating ticks
1655 -- ---------------------------------------------------------------------------
1656 --
1657 -- Note [Floating Ticks in CorePrep]
1658 --
1659 -- It might seem counter-intuitive to float ticks by default, given
1660 -- that we don't actually want to move them if we can help it. On the
1661 -- other hand, nothing gets very far in CorePrep anyway, and we want
1662 -- to preserve the order of let bindings and tick annotations in
1663 -- relation to each other. For example, if we just wrapped let floats
1664 -- when they pass through ticks, we might end up performing the
1665 -- following transformation:
1666 --
1667 -- src<...> let foo = bar in baz
1668 -- ==> let foo = src<...> bar in src<...> baz
1669 --
1670 -- Because the let-binding would float through the tick, and then
1671 -- immediately materialize, achieving nothing but decreasing tick
1672 -- accuracy. The only special case is the following scenario:
1673 --
1674 -- let foo = src<...> (let a = b in bar) in baz
1675 -- ==> let foo = src<...> bar; a = src<...> b in baz
1676 --
1677 -- Here we would not want the source tick to end up covering "baz" and
1678 -- therefore refrain from pushing ticks outside. Instead, we copy them
1679 -- into the floating binds (here "a") in cpePair. Note that where "b"
1680 -- or "bar" are (value) lambdas we have to push the annotations
1681 -- further inside in order to uphold our rules.
1682 --
1683 -- All of this is implemented below in @wrapTicks@.
1684
1685 -- | Like wrapFloats, but only wraps tick floats
1686 wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
1687 wrapTicks (Floats flag floats0) expr =
1688 (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))
1689 where (floats1, ticks1) = foldlOL go ([], []) $ floats0
1690 -- Deeply nested constructors will produce long lists of
1691 -- redundant source note floats here. We need to eliminate
1692 -- those early, as relying on mkTick to spot it after the fact
1693 -- can yield O(n^3) complexity [#11095]
1694 go (floats, ticks) (FloatTick t)
1695 = ASSERT(tickishPlace t == PlaceNonLam)
1696 (floats, if any (flip tickishContains t) ticks
1697 then ticks else t:ticks)
1698 go (floats, ticks) f
1699 = (foldr wrap f (reverse ticks):floats, ticks)
1700
1701 wrap t (FloatLet bind) = FloatLet (wrapBind t bind)
1702 wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
1703 wrap _ other = pprPanic "wrapTicks: unexpected float!"
1704 (ppr other)
1705 wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
1706 wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs)
1707
1708 ------------------------------------------------------------------------------
1709 -- Collecting cost centres
1710 -- ---------------------------------------------------------------------------
1711
1712 -- | Collect cost centres defined in the current module, including those in
1713 -- unfoldings.
1714 collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre
1715 collectCostCentres mod_name
1716 = foldl' go_bind S.empty
1717 where
1718 go cs e = case e of
1719 Var{} -> cs
1720 Lit{} -> cs
1721 App e1 e2 -> go (go cs e1) e2
1722 Lam _ e -> go cs e
1723 Let b e -> go (go_bind cs b) e
1724 Case scrt _ _ alts -> go_alts (go cs scrt) alts
1725 Cast e _ -> go cs e
1726 Tick (ProfNote cc _ _) e ->
1727 go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e
1728 Tick _ e -> go cs e
1729 Type{} -> cs
1730 Coercion{} -> cs
1731
1732 go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e)
1733
1734 go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre
1735 go_bind cs (NonRec b e) =
1736 go (maybe cs (go cs) (get_unf b)) e
1737 go_bind cs (Rec bs) =
1738 foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs
1739
1740 -- Unfoldings may have cost centres that in the original definion are
1741 -- optimized away, see #5889.
1742 get_unf = maybeUnfoldingTemplate . realIdUnfolding