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