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