Fix #12076 by inlining trivial expressions in CorePrep.
[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 #-}
9
10 module CorePrep (
11 corePrepPgm, corePrepExpr, cvtLitInteger,
12 lookupMkIntegerName, lookupIntegerSDataConName
13 ) where
14
15 #include "HsVersions.h"
16
17 import OccurAnal
18
19 import HscTypes
20 import PrelNames
21 import MkId ( realWorldPrimId )
22 import CoreUtils
23 import CoreArity
24 import CoreFVs
25 import CoreMonad ( CoreToDo(..) )
26 import CoreLint ( endPassIO )
27 import CoreSyn
28 import CoreSubst
29 import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here
30 import Type
31 import Literal
32 import Coercion
33 import TcEnv
34 import TyCon
35 import Demand
36 import Var
37 import VarSet
38 import VarEnv
39 import Id
40 import IdInfo
41 import TysWiredIn
42 import DataCon
43 import PrimOp
44 import BasicTypes
45 import Module
46 import UniqSupply
47 import Maybes
48 import OrdList
49 import ErrUtils
50 import DynFlags
51 import Util
52 import Pair
53 import Outputable
54 import Platform
55 import FastString
56 import Config
57 import Name ( NamedThing(..), nameSrcSpan )
58 import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
59 import Data.Bits
60 import MonadUtils ( mapAccumLM )
61 import Data.List ( mapAccumL )
62 import Control.Monad
63
64 {-
65 -- ---------------------------------------------------------------------------
66 -- Overview
67 -- ---------------------------------------------------------------------------
68
69 The goal of this pass is to prepare for code generation.
70
71 1. Saturate constructor and primop applications.
72
73 2. Convert to A-normal form; that is, function arguments
74 are always variables.
75
76 * Use case for strict arguments:
77 f E ==> case E of x -> f x
78 (where f is strict)
79
80 * Use let for non-trivial lazy arguments
81 f E ==> let x = E in f x
82 (were f is lazy and x is non-trivial)
83
84 3. Similarly, convert any unboxed lets into cases.
85 [I'm experimenting with leaving 'ok-for-speculation'
86 rhss in let-form right up to this point.]
87
88 4. Ensure that *value* lambdas only occur as the RHS of a binding
89 (The code generator can't deal with anything else.)
90 Type lambdas are ok, however, because the code gen discards them.
91
92 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
93
94 6. Clone all local Ids.
95 This means that all such Ids are unique, rather than the
96 weaker guarantee of no clashes which the simplifier provides.
97 And that is what the code generator needs.
98
99 We don't clone TyVars or CoVars. The code gen doesn't need that,
100 and doing so would be tiresome because then we'd need
101 to substitute in types and coercions.
102
103 7. Give each dynamic CCall occurrence a fresh unique; this is
104 rather like the cloning step above.
105
106 8. Inject bindings for the "implicit" Ids:
107 * Constructor wrappers
108 * Constructor workers
109 We want curried definitions for all of these in case they
110 aren't inlined by some caller.
111
112 9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.hs
113
114 10. Convert (LitInteger i t) into the core representation
115 for the Integer i. Normally this uses mkInteger, but if
116 we are using the integer-gmp implementation then there is a
117 special case where we use the S# constructor for Integers that
118 are in the range of Int.
119
120 11. Uphold tick consistency while doing this: We move ticks out of
121 (non-type) applications where we can, and make sure that we
122 annotate according to scoping rules when floating.
123
124 This is all done modulo type applications and abstractions, so that
125 when type erasure is done for conversion to STG, we don't end up with
126 any trivial or useless bindings.
127
128
129 Invariants
130 ~~~~~~~~~~
131 Here is the syntax of the Core produced by CorePrep:
132
133 Trivial expressions
134 triv ::= lit | var
135 | triv ty | /\a. triv
136 | truv co | /\c. triv | triv |> co
137
138 Applications
139 app ::= lit | var | app triv | app ty | app co | app |> co
140
141 Expressions
142 body ::= app
143 | let(rec) x = rhs in body -- Boxed only
144 | case body of pat -> body
145 | /\a. body | /\c. body
146 | body |> co
147
148 Right hand sides (only place where value lambdas can occur)
149 rhs ::= /\a.rhs | \x.rhs | body
150
151 We define a synonym for each of these non-terminals. Functions
152 with the corresponding name produce a result in that syntax.
153 -}
154
155 type CpeTriv = CoreExpr -- Non-terminal 'triv'
156 type CpeApp = CoreExpr -- Non-terminal 'app'
157 type CpeBody = CoreExpr -- Non-terminal 'body'
158 type CpeRhs = CoreExpr -- Non-terminal 'rhs'
159
160 {-
161 ************************************************************************
162 * *
163 Top level stuff
164 * *
165 ************************************************************************
166 -}
167
168 corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
169 -> IO CoreProgram
170 corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
171 withTiming (pure dflags)
172 (text "CorePrep"<+>brackets (ppr this_mod))
173 (const ()) $ do
174 us <- mkSplitUniqSupply 's'
175 initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
176
177 let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
178 -- NB: we must feed mkImplicitBinds through corePrep too
179 -- so that they are suitably cloned and eta-expanded
180
181 binds_out = initUs_ us $ do
182 floats1 <- corePrepTopBinds initialCorePrepEnv binds
183 floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
184 return (deFloatTop (floats1 `appendFloats` floats2))
185
186 endPassIO hsc_env alwaysQualify CorePrep binds_out []
187 return binds_out
188 where
189 dflags = hsc_dflags hsc_env
190
191 corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
192 corePrepExpr dflags hsc_env expr =
193 withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do
194 us <- mkSplitUniqSupply 's'
195 initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
196 let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
197 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
198 return new_expr
199
200 corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
201 -- Note [Floating out of top level bindings]
202 corePrepTopBinds initialCorePrepEnv binds
203 = go initialCorePrepEnv binds
204 where
205 go _ [] = return emptyFloats
206 go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
207 binds' <- go env' binds
208 return (bind' `appendFloats` binds')
209
210 mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
211 -- See Note [Data constructor workers]
212 -- c.f. Note [Injecting implicit bindings] in TidyPgm
213 mkDataConWorkers dflags mod_loc data_tycons
214 = [ NonRec id (tick_it (getName data_con) (Var id))
215 -- The ice is thin here, but it works
216 | tycon <- data_tycons, -- CorePrep will eta-expand it
217 data_con <- tyConDataCons tycon,
218 let id = dataConWorkId data_con
219 ]
220 where
221 -- If we want to generate debug info, we put a source note on the
222 -- worker. This is useful, especially for heap profiling.
223 tick_it name
224 | debugLevel dflags == 0 = id
225 | RealSrcSpan span <- nameSrcSpan name = tick span
226 | Just file <- ml_hs_file mod_loc = tick (span1 file)
227 | otherwise = tick (span1 "???")
228 where tick span = Tick (SourceNote span $ showSDoc dflags (ppr name))
229 span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
230
231 {-
232 Note [Floating out of top level bindings]
233 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
234 NB: we do need to float out of top-level bindings
235 Consider x = length [True,False]
236 We want to get
237 s1 = False : []
238 s2 = True : s1
239 x = length s2
240
241 We return a *list* of bindings, because we may start with
242 x* = f (g y)
243 where x is demanded, in which case we want to finish with
244 a = g y
245 x* = f a
246 And then x will actually end up case-bound
247
248 Note [CafInfo and floating]
249 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
250 What happens when we try to float bindings to the top level? At this
251 point all the CafInfo is supposed to be correct, and we must make certain
252 that is true of the new top-level bindings. There are two cases
253 to consider
254
255 a) The top-level binding is marked asCafRefs. In that case we are
256 basically fine. The floated bindings had better all be lazy lets,
257 so they can float to top level, but they'll all have HasCafRefs
258 (the default) which is safe.
259
260 b) The top-level binding is marked NoCafRefs. This really happens
261 Example. CoreTidy produces
262 $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...
263 Now CorePrep has to eta-expand to
264 $fApplicativeSTM = let sat = \xy. retry x y
265 in D:Alternative sat ...blah...
266 So what we *want* is
267 sat [NoCafRefs] = \xy. retry x y
268 $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...
269
270 So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
271 *and* substutite the modified 'sat' into the old RHS.
272
273 It should be the case that 'sat' is itself [NoCafRefs] (a value, no
274 cafs) else the original top-level binding would not itself have been
275 marked [NoCafRefs]. The DEBUG check in CoreToStg for
276 consistentCafInfo will find this.
277
278 This is all very gruesome and horrible. It would be better to figure
279 out CafInfo later, after CorePrep. We'll do that in due course.
280 Meanwhile this horrible hack works.
281
282
283 Note [Data constructor workers]
284 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
285 Create any necessary "implicit" bindings for data con workers. We
286 create the rather strange (non-recursive!) binding
287
288 $wC = \x y -> $wC x y
289
290 i.e. a curried constructor that allocates. This means that we can
291 treat the worker for a constructor like any other function in the rest
292 of the compiler. The point here is that CoreToStg will generate a
293 StgConApp for the RHS, rather than a call to the worker (which would
294 give a loop). As Lennart says: the ice is thin here, but it works.
295
296 Hmm. Should we create bindings for dictionary constructors? They are
297 always fully applied, and the bindings are just there to support
298 partial applications. But it's easier to let them through.
299
300
301 Note [Dead code in CorePrep]
302 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
303 Imagine that we got an input program like this (see Trac #4962):
304
305 f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
306 f x = (g True (Just x) + g () (Just x), g)
307 where
308 g :: Show a => a -> Maybe Int -> Int
309 g _ Nothing = x
310 g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
311
312 After specialisation and SpecConstr, we would get something like this:
313
314 f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
315 f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
316 where
317 {-# RULES g $dBool = g$Bool
318 g $dUnit = g$Unit #-}
319 g = ...
320 {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
321 g$Bool = ...
322 {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
323 g$Unit = ...
324 g$Bool_True_Just = ...
325 g$Unit_Unit_Just = ...
326
327 Note that the g$Bool and g$Unit functions are actually dead code: they
328 are only kept alive by the occurrence analyser because they are
329 referred to by the rules of g, which is being kept alive by the fact
330 that it is used (unspecialised) in the returned pair.
331
332 However, at the CorePrep stage there is no way that the rules for g
333 will ever fire, and it really seems like a shame to produce an output
334 program that goes to the trouble of allocating a closure for the
335 unreachable g$Bool and g$Unit functions.
336
337 The way we fix this is to:
338 * In cloneBndr, drop all unfoldings/rules
339
340 * In deFloatTop, run a simple dead code analyser on each top-level
341 RHS to drop the dead local bindings. For that call to OccAnal, we
342 disable the binder swap, else the occurrence analyser sometimes
343 introduces new let bindings for cased binders, which lead to the bug
344 in #5433.
345
346 The reason we don't just OccAnal the whole output of CorePrep is that
347 the tidier ensures that all top-level binders are GlobalIds, so they
348 don't show up in the free variables any longer. So if you run the
349 occurrence analyser on the output of CoreTidy (or later) you e.g. turn
350 this program:
351
352 Rec {
353 f = ... f ...
354 }
355
356 Into this one:
357
358 f = ... f ...
359
360 (Since f is not considered to be free in its own RHS.)
361
362
363 ************************************************************************
364 * *
365 The main code
366 * *
367 ************************************************************************
368 -}
369
370 cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
371 -> UniqSM (CorePrepEnv, Floats)
372 cpeBind top_lvl env (NonRec bndr rhs)
373 = do { (_, bndr1) <- cpCloneBndr env bndr
374 ; let dmd = idDemandInfo bndr
375 is_unlifted = isUnliftedType (idType bndr)
376 ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
377 dmd
378 is_unlifted
379 env bndr1 rhs
380 -- See Note [Inlining in CorePrep]
381 ; if cpe_ExprIsTrivial rhs2 && isNotTopLevel top_lvl
382 then return (extendCorePrepEnvExpr env bndr rhs2, floats)
383 else do {
384
385 ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2
386
387 -- We want bndr'' in the envt, because it records
388 -- the evaluated-ness of the binder
389 ; return (extendCorePrepEnv env bndr bndr2,
390 addFloat floats new_float) }}
391
392 cpeBind top_lvl env (Rec pairs)
393 = do { let (bndrs,rhss) = unzip pairs
394 ; (env', bndrs1) <- cpCloneBndrs env (map fst pairs)
395 ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss
396
397 ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
398 all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
399 (concatFloats floats_s)
400 ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
401 unitFloat (FloatLet (Rec all_pairs))) }
402 where
403 -- Flatten all the floats, and the currrent
404 -- group into a single giant Rec
405 add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
406 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
407 add_float b _ = pprPanic "cpeBind" (ppr b)
408
409 ---------------
410 cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
411 -> CorePrepEnv -> Id -> CoreExpr
412 -> UniqSM (Floats, Id, CpeRhs)
413 -- Used for all bindings
414 cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
415 = do { (floats1, rhs1) <- cpeRhsE env rhs
416
417 -- See if we are allowed to float this stuff out of the RHS
418 ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
419
420 -- Make the arity match up
421 ; (floats3, rhs3)
422 <- if manifestArity rhs1 <= arity
423 then return (floats2, cpeEtaExpand arity rhs2)
424 else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
425 -- Note [Silly extra arguments]
426 (do { v <- newVar (idType bndr)
427 ; let float = mkFloat topDmd False v rhs2
428 ; return ( addFloat floats2 float
429 , cpeEtaExpand arity (Var v)) })
430
431 -- Wrap floating ticks
432 ; let (floats4, rhs4) = wrapTicks floats3 rhs3
433
434 -- Record if the binder is evaluated
435 -- and otherwise trim off the unfolding altogether
436 -- It's not used by the code generator; getting rid of it reduces
437 -- heap usage and, since we may be changing uniques, we'd have
438 -- to substitute to keep it right
439 ; let bndr' | exprIsHNF rhs3 = bndr `setIdUnfolding` evaldUnfolding
440 | otherwise = bndr `setIdUnfolding` noUnfolding
441
442 ; return (floats4, bndr', rhs4) }
443 where
444 platform = targetPlatform (cpe_dynFlags env)
445
446 arity = idArity bndr -- We must match this arity
447
448 ---------------------
449 float_from_rhs floats rhs
450 | isEmptyFloats floats = return (emptyFloats, rhs)
451 | isTopLevel top_lvl = float_top floats rhs
452 | otherwise = float_nested floats rhs
453
454 ---------------------
455 float_nested floats rhs
456 | wantFloatNested is_rec dmd is_unlifted floats rhs
457 = return (floats, rhs)
458 | otherwise = dontFloat floats rhs
459
460 ---------------------
461 float_top floats rhs -- Urhgh! See Note [CafInfo and floating]
462 | mayHaveCafRefs (idCafInfo bndr)
463 , allLazyTop floats
464 = return (floats, rhs)
465
466 -- So the top-level binding is marked NoCafRefs
467 | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs
468 = return (floats', rhs')
469
470 | otherwise
471 = dontFloat floats rhs
472
473 dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
474 -- Non-empty floats, but do not want to float from rhs
475 -- So wrap the rhs in the floats
476 -- But: rhs1 might have lambdas, and we can't
477 -- put them inside a wrapBinds
478 dontFloat floats1 rhs
479 = do { (floats2, body) <- rhsToBody rhs
480 ; return (emptyFloats, wrapBinds floats1 $
481 wrapBinds floats2 body) }
482
483 {- Note [Silly extra arguments]
484 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
485 Suppose we had this
486 f{arity=1} = \x\y. e
487 We *must* match the arity on the Id, so we have to generate
488 f' = \x\y. e
489 f = \x. f' x
490
491 It's a bizarre case: why is the arity on the Id wrong? Reason
492 (in the days of __inline_me__):
493 f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
494 When InlineMe notes go away this won't happen any more. But
495 it seems good for CorePrep to be robust.
496 -}
497
498 -- ---------------------------------------------------------------------------
499 -- CpeRhs: produces a result satisfying CpeRhs
500 -- ---------------------------------------------------------------------------
501
502 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
503 -- If
504 -- e ===> (bs, e')
505 -- then
506 -- e = let bs in e' (semantically, that is!)
507 --
508 -- For example
509 -- f (g x) ===> ([v = g x], f v)
510
511 cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
512 cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
513 cpeRhsE env (Lit (LitInteger i _))
514 = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
515 (cpe_integerSDataCon env) i)
516 cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
517 cpeRhsE env expr@(Var {}) = cpeApp env expr
518
519 cpeRhsE env (Var f `App` _{-type-} `App` arg)
520 | f `hasKey` lazyIdKey -- Replace (lazy a) by a
521 = cpeRhsE env arg -- See Note [lazyId magic] in MkId
522
523 cpeRhsE env (Var f `App` _runtimeRep `App` _type `App` arg)
524 -- See Note [runRW magic] in MkId
525 | f `hasKey` runRWKey -- Replace (runRW# f) by (f realWorld#),
526 = case arg of -- beta reducing if possible
527 Lam s body -> cpeRhsE (extendCorePrepEnv env s realWorldPrimId) body
528 _ -> cpeRhsE env (arg `App` Var realWorldPrimId)
529 -- See Note [runRW arg]
530
531 {- Note [runRW arg]
532 ~~~~~~~~~~~~~~~~~~~
533 If we got, say
534 runRW# (case bot of {})
535 which happened in Trac #11291, we do /not/ want to turn it into
536 (case bot of {}) realWorldPrimId#
537 because that gives a panic in CoreToStg.myCollectArgs, which expects
538 only variables in function position. But if we are sure to make
539 runRW# strict (which we do in MkId), this can't happen
540 -}
541
542 cpeRhsE env expr@(App {}) = cpeApp env expr
543
544 cpeRhsE env (Let bind expr)
545 = do { (env', new_binds) <- cpeBind NotTopLevel env bind
546 ; (floats, body) <- cpeRhsE env' expr
547 ; return (new_binds `appendFloats` floats, body) }
548
549 cpeRhsE env (Tick tickish expr)
550 | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope
551 = do { (floats, body) <- cpeRhsE env expr
552 -- See [Floating Ticks in CorePrep]
553 ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }
554 | otherwise
555 = do { body <- cpeBodyNF env expr
556 ; return (emptyFloats, mkTick tickish' body) }
557 where
558 tickish' | Breakpoint n fvs <- tickish
559 -- See also 'substTickish'
560 = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
561 | otherwise
562 = tickish
563
564 cpeRhsE env (Cast expr co)
565 = do { (floats, expr') <- cpeRhsE env expr
566 ; return (floats, Cast expr' co) }
567
568 cpeRhsE env expr@(Lam {})
569 = do { let (bndrs,body) = collectBinders expr
570 ; (env', bndrs') <- cpCloneBndrs env bndrs
571 ; body' <- cpeBodyNF env' body
572 ; return (emptyFloats, mkLams bndrs' body') }
573
574 cpeRhsE env (Case scrut bndr ty alts)
575 = do { (floats, scrut') <- cpeBody env scrut
576 ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
577 -- Record that the case binder is evaluated in the alternatives
578 ; (env', bndr2) <- cpCloneBndr env bndr1
579 ; alts' <- mapM (sat_alt env') alts
580 ; return (floats, Case scrut' bndr2 ty alts') }
581 where
582 sat_alt env (con, bs, rhs)
583 = do { (env2, bs') <- cpCloneBndrs env bs
584 ; rhs' <- cpeBodyNF env2 rhs
585 ; return (con, bs', rhs') }
586
587 cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
588 -- Here we convert a literal Integer to the low-level
589 -- represenation. Exactly how we do this depends on the
590 -- library that implements Integer. If it's GMP we
591 -- use the S# data constructor for small literals.
592 -- See Note [Integer literals] in Literal
593 cvtLitInteger dflags _ (Just sdatacon) i
594 | inIntRange dflags i -- Special case for small integers
595 = mkConApp sdatacon [Lit (mkMachInt dflags i)]
596
597 cvtLitInteger dflags mk_integer _ i
598 = mkApps (Var mk_integer) [isNonNegative, ints]
599 where isNonNegative = if i < 0 then mkConApp falseDataCon []
600 else mkConApp trueDataCon []
601 ints = mkListExpr intTy (f (abs i))
602 f 0 = []
603 f x = let low = x .&. mask
604 high = x `shiftR` bits
605 in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high
606 bits = 31
607 mask = 2 ^ bits - 1
608
609 -- ---------------------------------------------------------------------------
610 -- CpeBody: produces a result satisfying CpeBody
611 -- ---------------------------------------------------------------------------
612
613 -- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without
614 -- producing any floats (any generated floats are immediately
615 -- let-bound using 'wrapBinds'). Generally you want this, esp.
616 -- when you've reached a binding form (e.g., a lambda) and
617 -- floating any further would be incorrect.
618 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
619 cpeBodyNF env expr
620 = do { (floats, body) <- cpeBody env expr
621 ; return (wrapBinds floats body) }
622
623 -- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce
624 -- a list of 'Floats' which are being propagated upwards. In
625 -- fact, this function is used in only two cases: to
626 -- implement 'cpeBodyNF' (which is what you usually want),
627 -- and in the case when a let-binding is in a case scrutinee--here,
628 -- we can always float out:
629 --
630 -- case (let x = y in z) of ...
631 -- ==> let x = y in case z of ...
632 --
633 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
634 cpeBody env expr
635 = do { (floats1, rhs) <- cpeRhsE env expr
636 ; (floats2, body) <- rhsToBody rhs
637 ; return (floats1 `appendFloats` floats2, body) }
638
639 --------
640 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
641 -- Remove top level lambdas by let-binding
642
643 rhsToBody (Tick t expr)
644 | tickishScoped t == NoScope -- only float out of non-scoped annotations
645 = do { (floats, expr') <- rhsToBody expr
646 ; return (floats, mkTick t expr') }
647
648 rhsToBody (Cast e co)
649 -- You can get things like
650 -- case e of { p -> coerce t (\s -> ...) }
651 = do { (floats, e') <- rhsToBody e
652 ; return (floats, Cast e' co) }
653
654 rhsToBody expr@(Lam {})
655 | Just no_lam_result <- tryEtaReducePrep bndrs body
656 = return (emptyFloats, no_lam_result)
657 | all isTyVar bndrs -- Type lambdas are ok
658 = return (emptyFloats, expr)
659 | otherwise -- Some value lambdas
660 = do { fn <- newVar (exprType expr)
661 ; let rhs = cpeEtaExpand (exprArity expr) expr
662 float = FloatLet (NonRec fn rhs)
663 ; return (unitFloat float, Var fn) }
664 where
665 (bndrs,body) = collectBinders expr
666
667 rhsToBody expr = return (emptyFloats, expr)
668
669
670
671 -- ---------------------------------------------------------------------------
672 -- CpeApp: produces a result satisfying CpeApp
673 -- ---------------------------------------------------------------------------
674
675 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
676 -- May return a CpeRhs because of saturating primops
677 cpeApp env expr
678 = do { (app, head, _, floats, ss) <- collect_args expr 0
679 ; MASSERT(null ss) -- make sure we used all the strictness info
680
681 -- Now deal with the function
682 ; case head of
683 Just (fn_id, depth) -> do { sat_app <- maybeSaturate fn_id app depth
684 ; return (floats, sat_app) }
685 _other -> return (floats, app) }
686
687 where
688 -- Deconstruct and rebuild the application, floating any non-atomic
689 -- arguments to the outside. We collect the type of the expression,
690 -- the head of the application, and the number of actual value arguments,
691 -- all of which are used to possibly saturate this application if it
692 -- has a constructor or primop at the head.
693
694 collect_args
695 :: CoreExpr
696 -> Int -- Current app depth
697 -> UniqSM (CpeApp, -- The rebuilt expression
698 Maybe (Id, Int), -- The head of the application,
699 -- and no. of args it was applied to
700 Type, -- Type of the whole expr
701 Floats, -- Any floats we pulled out
702 [Demand]) -- Remaining argument demands
703
704 collect_args (App fun arg@(Type arg_ty)) depth
705 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
706 ; return (App fun' arg, hd, piResultTy fun_ty arg_ty, floats, ss) }
707
708 collect_args (App fun arg@(Coercion {})) depth
709 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
710 ; return (App fun' arg, hd, funResultTy fun_ty, floats, ss) }
711
712 collect_args (App fun arg) depth
713 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
714 ; let (ss1, ss_rest) -- See Note [lazyId magic] in MkId
715 = case (ss, isLazyExpr arg) of
716 (_ : ss_rest, True) -> (topDmd, ss_rest)
717 (ss1 : ss_rest, False) -> (ss1, ss_rest)
718 ([], _) -> (topDmd, [])
719 (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
720 splitFunTy_maybe fun_ty
721
722 ; (fs, arg') <- cpeArg env ss1 arg arg_ty
723 ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
724
725 collect_args (Var v) depth
726 = do { v1 <- fiddleCCall v
727 ; let e2 = lookupCorePrepEnv env v1
728 mb_v2 = getIdFromTrivialExpr_maybe e2
729 hd = fmap (\v2 -> (v2, depth)) mb_v2
730 -- NB: current depth is right, because e2 is a trivial expression
731 -- and thus its embedded Id *must* be at the same depth as any
732 -- Apps it is under are type applications only (c.f.
733 -- cpe_ExprIsTrivial). But note that we need the type of the
734 -- expression, not the id.
735 ; return (e2, hd, exprType e2, emptyFloats, stricts) }
736 where
737 stricts = case idStrictness v of
738 StrictSig (DmdType _ demands _)
739 | listLengthCmp demands depth /= GT -> demands
740 -- length demands <= depth
741 | otherwise -> []
742 -- If depth < length demands, then we have too few args to
743 -- satisfy strictness info so we have to ignore all the
744 -- strictness info, e.g. + (error "urk")
745 -- Here, we can't evaluate the arg strictly, because this
746 -- partial application might be seq'd
747
748 collect_args (Cast fun co) depth
749 = do { let Pair _ty1 ty2 = coercionKind co
750 ; (fun', hd, _, floats, ss) <- collect_args fun depth
751 ; return (Cast fun' co, hd, ty2, floats, ss) }
752
753 collect_args (Tick tickish fun) depth
754 | tickishPlace tickish == PlaceNonLam
755 && tickish `tickishScopesLike` SoftScope
756 = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
757 -- See [Floating Ticks in CorePrep]
758 ; return (fun',hd,fun_ty,addFloat floats (FloatTick tickish),ss) }
759
760 -- N-variable fun, better let-bind it
761 collect_args fun _
762 = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
763 -- The evalDmd says that it's sure to be evaluated,
764 -- so we'll end up case-binding it
765 ; return (fun', Nothing, ty, fun_floats, []) }
766 where
767 ty = exprType fun
768
769 isLazyExpr :: CoreExpr -> Bool
770 -- See Note [lazyId magic] in MkId
771 isLazyExpr (Cast e _) = isLazyExpr e
772 isLazyExpr (Tick _ e) = isLazyExpr e
773 isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey
774 isLazyExpr _ = False
775
776 -- ---------------------------------------------------------------------------
777 -- CpeArg: produces a result satisfying CpeArg
778 -- ---------------------------------------------------------------------------
779
780 -- This is where we arrange that a non-trivial argument is let-bound
781 cpeArg :: CorePrepEnv -> Demand
782 -> CoreArg -> Type -> UniqSM (Floats, CpeTriv)
783 cpeArg env dmd arg arg_ty
784 = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
785 ; (floats2, arg2) <- if want_float floats1 arg1
786 then return (floats1, arg1)
787 else dontFloat floats1 arg1
788 -- Else case: arg1 might have lambdas, and we can't
789 -- put them inside a wrapBinds
790
791 ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument
792 then return (floats2, arg2)
793 else do
794 { v <- newVar arg_ty
795 ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
796 arg_float = mkFloat dmd is_unlifted v arg3
797 ; return (addFloat floats2 arg_float, varToCoreExpr v) } }
798 where
799 is_unlifted = isUnliftedType arg_ty
800 want_float = wantFloatNested NonRecursive dmd is_unlifted
801
802 {-
803 Note [Floating unlifted arguments]
804 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
805 Consider C (let v* = expensive in v)
806
807 where the "*" indicates "will be demanded". Usually v will have been
808 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
809 do *not* want to get
810
811 let v* = expensive in C v
812
813 because that has different strictness. Hence the use of 'allLazy'.
814 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
815
816
817 ------------------------------------------------------------------------------
818 -- Building the saturated syntax
819 -- ---------------------------------------------------------------------------
820
821 maybeSaturate deals with saturating primops and constructors
822 The type is the type of the entire application
823 -}
824
825 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
826 maybeSaturate fn expr n_args
827 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
828 -- A gruesome special case
829 = saturateDataToTag sat_expr
830
831 | hasNoBinding fn -- There's no binding
832 = return sat_expr
833
834 | otherwise
835 = return expr
836 where
837 fn_arity = idArity fn
838 excess_arity = fn_arity - n_args
839 sat_expr = cpeEtaExpand excess_arity expr
840
841 -------------
842 saturateDataToTag :: CpeApp -> UniqSM CpeApp
843 -- See Note [dataToTag magic]
844 saturateDataToTag sat_expr
845 = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
846 ; eta_body' <- eval_data2tag_arg eta_body
847 ; return (mkLams eta_bndrs eta_body') }
848 where
849 eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
850 eval_data2tag_arg app@(fun `App` arg)
851 | exprIsHNF arg -- Includes nullary constructors
852 = return app -- The arg is evaluated
853 | otherwise -- Arg not evaluated, so evaluate it
854 = do { arg_id <- newVar (exprType arg)
855 ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
856 ; return (Case arg arg_id1 (exprType app)
857 [(DEFAULT, [], fun `App` Var arg_id1)]) }
858
859 eval_data2tag_arg (Tick t app) -- Scc notes can appear
860 = do { app' <- eval_data2tag_arg app
861 ; return (Tick t app') }
862
863 eval_data2tag_arg other -- Should not happen
864 = pprPanic "eval_data2tag" (ppr other)
865
866 {-
867 Note [dataToTag magic]
868 ~~~~~~~~~~~~~~~~~~~~~~
869 Horrid: we must ensure that the arg of data2TagOp is evaluated
870 (data2tag x) --> (case x of y -> data2tag y)
871 (yuk yuk) take into account the lambdas we've now introduced
872
873 How might it not be evaluated? Well, we might have floated it out
874 of the scope of a `seq`, or dropped the `seq` altogether.
875
876
877 ************************************************************************
878 * *
879 Simple CoreSyn operations
880 * *
881 ************************************************************************
882 -}
883
884 cpe_ExprIsTrivial :: CoreExpr -> Bool
885 -- Version that doesn't consider an scc annotation to be trivial.
886 -- See also 'exprIsTrivial'
887 cpe_ExprIsTrivial (Var _) = True
888 cpe_ExprIsTrivial (Type _) = True
889 cpe_ExprIsTrivial (Coercion _) = True
890 cpe_ExprIsTrivial (Lit _) = True
891 cpe_ExprIsTrivial (App e arg) = not (isRuntimeArg arg) && cpe_ExprIsTrivial e
892 cpe_ExprIsTrivial (Lam b e) = not (isRuntimeVar b) && cpe_ExprIsTrivial e
893 cpe_ExprIsTrivial (Tick t e) = not (tickishIsCode t) && cpe_ExprIsTrivial e
894 cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
895 cpe_ExprIsTrivial (Case e _ _ []) = cpe_ExprIsTrivial e
896 -- See Note [Empty case is trivial] in CoreUtils
897 cpe_ExprIsTrivial _ = False
898
899 {-
900 -- -----------------------------------------------------------------------------
901 -- Eta reduction
902 -- -----------------------------------------------------------------------------
903
904 Note [Eta expansion]
905 ~~~~~~~~~~~~~~~~~~~~~
906 Eta expand to match the arity claimed by the binder Remember,
907 CorePrep must not change arity
908
909 Eta expansion might not have happened already, because it is done by
910 the simplifier only when there at least one lambda already.
911
912 NB1:we could refrain when the RHS is trivial (which can happen
913 for exported things). This would reduce the amount of code
914 generated (a little) and make things a little words for
915 code compiled without -O. The case in point is data constructor
916 wrappers.
917
918 NB2: we have to be careful that the result of etaExpand doesn't
919 invalidate any of the assumptions that CorePrep is attempting
920 to establish. One possible cause is eta expanding inside of
921 an SCC note - we're now careful in etaExpand to make sure the
922 SCC is pushed inside any new lambdas that are generated.
923
924 Note [Eta expansion and the CorePrep invariants]
925 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
926 It turns out to be much much easier to do eta expansion
927 *after* the main CorePrep stuff. But that places constraints
928 on the eta expander: given a CpeRhs, it must return a CpeRhs.
929
930 For example here is what we do not want:
931 f = /\a -> g (h 3) -- h has arity 2
932 After ANFing we get
933 f = /\a -> let s = h 3 in g s
934 and now we do NOT want eta expansion to give
935 f = /\a -> \ y -> (let s = h 3 in g s) y
936
937 Instead CoreArity.etaExpand gives
938 f = /\a -> \y -> let s = h 3 in g s y
939 -}
940
941 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
942 cpeEtaExpand arity expr
943 | arity == 0 = expr
944 | otherwise = etaExpand arity expr
945
946 {-
947 -- -----------------------------------------------------------------------------
948 -- Eta reduction
949 -- -----------------------------------------------------------------------------
950
951 Why try eta reduction? Hasn't the simplifier already done eta?
952 But the simplifier only eta reduces if that leaves something
953 trivial (like f, or f Int). But for deLam it would be enough to
954 get to a partial application:
955 case x of { p -> \xs. map f xs }
956 ==> case x of { p -> map f }
957 -}
958
959 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
960 tryEtaReducePrep bndrs expr@(App _ _)
961 | ok_to_eta_reduce f
962 , n_remaining >= 0
963 , and (zipWith ok bndrs last_args)
964 , not (any (`elemVarSet` fvs_remaining) bndrs)
965 , exprIsHNF remaining_expr -- Don't turn value into a non-value
966 -- else the behaviour with 'seq' changes
967 = Just remaining_expr
968 where
969 (f, args) = collectArgs expr
970 remaining_expr = mkApps f remaining_args
971 fvs_remaining = exprFreeVars remaining_expr
972 (remaining_args, last_args) = splitAt n_remaining args
973 n_remaining = length args - length bndrs
974
975 ok bndr (Var arg) = bndr == arg
976 ok _ _ = False
977
978 -- We can't eta reduce something which must be saturated.
979 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
980 ok_to_eta_reduce _ = False -- Safe. ToDo: generalise
981
982 tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
983 | not (any (`elemVarSet` fvs) bndrs)
984 = case tryEtaReducePrep bndrs body of
985 Just e -> Just (Let bind e)
986 Nothing -> Nothing
987 where
988 fvs = exprFreeVars r
989
990 -- NB: do not attempt to eta-reduce across ticks
991 -- Otherwise we risk reducing
992 -- \x. (Tick (Breakpoint {x}) f x)
993 -- ==> Tick (breakpoint {x}) f
994 -- which is bogus (Trac #17228)
995 -- tryEtaReducePrep bndrs (Tick tickish e)
996 -- = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
997
998 tryEtaReducePrep _ _ = Nothing
999
1000 {-
1001 ************************************************************************
1002 * *
1003 Floats
1004 * *
1005 ************************************************************************
1006
1007 Note [Pin demand info on floats]
1008 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1009 We pin demand info on floated lets so that we can see the one-shot thunks.
1010 -}
1011
1012 data FloatingBind
1013 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
1014 -- They are always of lifted type;
1015 -- unlifted ones are done with FloatCase
1016
1017 | FloatCase
1018 Id CpeBody
1019 Bool -- The bool indicates "ok-for-speculation"
1020
1021 -- | See Note [Floating Ticks in CorePrep]
1022 | FloatTick (Tickish Id)
1023
1024 data Floats = Floats OkToSpec (OrdList FloatingBind)
1025
1026 instance Outputable FloatingBind where
1027 ppr (FloatLet b) = ppr b
1028 ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
1029 ppr (FloatTick t) = ppr t
1030
1031 instance Outputable Floats where
1032 ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>
1033 braces (vcat (map ppr (fromOL fs)))
1034
1035 instance Outputable OkToSpec where
1036 ppr OkToSpec = text "OkToSpec"
1037 ppr IfUnboxedOk = text "IfUnboxedOk"
1038 ppr NotOkToSpec = text "NotOkToSpec"
1039
1040 -- Can we float these binds out of the rhs of a let? We cache this decision
1041 -- to avoid having to recompute it in a non-linear way when there are
1042 -- deeply nested lets.
1043 data OkToSpec
1044 = OkToSpec -- Lazy bindings of lifted type
1045 | IfUnboxedOk -- A mixture of lazy lifted bindings and n
1046 -- ok-to-speculate unlifted bindings
1047 | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
1048
1049 mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
1050 mkFloat dmd is_unlifted bndr rhs
1051 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
1052 | is_hnf = FloatLet (NonRec bndr rhs)
1053 | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
1054 -- See Note [Pin demand info on floats]
1055 where
1056 is_hnf = exprIsHNF rhs
1057 is_strict = isStrictDmd dmd
1058 use_case = is_unlifted || is_strict && not is_hnf
1059 -- Don't make a case for a value binding,
1060 -- even if it's strict. Otherwise we get
1061 -- case (\x -> e) of ...!
1062
1063 emptyFloats :: Floats
1064 emptyFloats = Floats OkToSpec nilOL
1065
1066 isEmptyFloats :: Floats -> Bool
1067 isEmptyFloats (Floats _ bs) = isNilOL bs
1068
1069 wrapBinds :: Floats -> CpeBody -> CpeBody
1070 wrapBinds (Floats _ binds) body
1071 = foldrOL mk_bind body binds
1072 where
1073 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
1074 mk_bind (FloatLet bind) body = Let bind body
1075 mk_bind (FloatTick tickish) body = mkTick tickish body
1076
1077 addFloat :: Floats -> FloatingBind -> Floats
1078 addFloat (Floats ok_to_spec floats) new_float
1079 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
1080 where
1081 check (FloatLet _) = OkToSpec
1082 check (FloatCase _ _ ok_for_spec)
1083 | ok_for_spec = IfUnboxedOk
1084 | otherwise = NotOkToSpec
1085 check FloatTick{} = OkToSpec
1086 -- The ok-for-speculation flag says that it's safe to
1087 -- float this Case out of a let, and thereby do it more eagerly
1088 -- We need the top-level flag because it's never ok to float
1089 -- an unboxed binding to the top level
1090
1091 unitFloat :: FloatingBind -> Floats
1092 unitFloat = addFloat emptyFloats
1093
1094 appendFloats :: Floats -> Floats -> Floats
1095 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
1096 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
1097
1098 concatFloats :: [Floats] -> OrdList FloatingBind
1099 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
1100
1101 combine :: OkToSpec -> OkToSpec -> OkToSpec
1102 combine NotOkToSpec _ = NotOkToSpec
1103 combine _ NotOkToSpec = NotOkToSpec
1104 combine IfUnboxedOk _ = IfUnboxedOk
1105 combine _ IfUnboxedOk = IfUnboxedOk
1106 combine _ _ = OkToSpec
1107
1108 deFloatTop :: Floats -> [CoreBind]
1109 -- For top level only; we don't expect any FloatCases
1110 deFloatTop (Floats _ floats)
1111 = foldrOL get [] floats
1112 where
1113 get (FloatLet b) bs = occurAnalyseRHSs b : bs
1114 get b _ = pprPanic "corePrepPgm" (ppr b)
1115
1116 -- See Note [Dead code in CorePrep]
1117 occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
1118 occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]
1119
1120 ---------------------------------------------------------------------------
1121
1122 canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
1123 -- Note [CafInfo and floating]
1124 canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
1125 | OkToSpec <- ok_to_spec -- Worth trying
1126 , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
1127 = Just (Floats OkToSpec fs', subst_expr subst rhs)
1128 | otherwise
1129 = Nothing
1130 where
1131 subst_expr = substExpr (text "CorePrep")
1132
1133 go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
1134 -> Maybe (Subst, OrdList FloatingBind)
1135
1136 go (subst, fbs_out) [] = Just (subst, fbs_out)
1137
1138 go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
1139 | rhs_ok r
1140 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1141 where
1142 (subst', b') = set_nocaf_bndr subst b
1143 new_fb = FloatLet (NonRec b' (subst_expr subst r))
1144
1145 go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
1146 | all rhs_ok rs
1147 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1148 where
1149 (bs,rs) = unzip prs
1150 (subst', bs') = mapAccumL set_nocaf_bndr subst bs
1151 rs' = map (subst_expr subst') rs
1152 new_fb = FloatLet (Rec (bs' `zip` rs'))
1153
1154 go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
1155 = go (subst, fbs_out `snocOL` ft) fbs_in
1156
1157 go _ _ = Nothing -- Encountered a caffy binding
1158
1159 ------------
1160 set_nocaf_bndr subst bndr
1161 = (extendIdSubst subst bndr (Var bndr'), bndr')
1162 where
1163 bndr' = bndr `setIdCafInfo` NoCafRefs
1164
1165 ------------
1166 rhs_ok :: CoreExpr -> Bool
1167 -- We can only float to top level from a NoCaf thing if
1168 -- the new binding is static. However it can't mention
1169 -- any non-static things or it would *already* be Caffy
1170 rhs_ok = rhsIsStatic platform (\_ -> False)
1171 (\i -> pprPanic "rhsIsStatic" (integer i))
1172 -- Integer literals should not show up
1173
1174 wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
1175 wantFloatNested is_rec dmd is_unlifted floats rhs
1176 = isEmptyFloats floats
1177 || isStrictDmd dmd
1178 || is_unlifted
1179 || (allLazyNested is_rec floats && exprIsHNF rhs)
1180 -- Why the test for allLazyNested?
1181 -- v = f (x `divInt#` y)
1182 -- we don't want to float the case, even if f has arity 2,
1183 -- because floating the case would make it evaluated too early
1184
1185 allLazyTop :: Floats -> Bool
1186 allLazyTop (Floats OkToSpec _) = True
1187 allLazyTop _ = False
1188
1189 allLazyNested :: RecFlag -> Floats -> Bool
1190 allLazyNested _ (Floats OkToSpec _) = True
1191 allLazyNested _ (Floats NotOkToSpec _) = False
1192 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
1193
1194 {-
1195 ************************************************************************
1196 * *
1197 Cloning
1198 * *
1199 ************************************************************************
1200 -}
1201
1202 -- ---------------------------------------------------------------------------
1203 -- The environment
1204 -- ---------------------------------------------------------------------------
1205
1206 -- Note [Inlining in CorePrep]
1207 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1208 -- There is a subtle but important invariant that must be upheld in the output
1209 -- of CorePrep: there are no "trivial" updatable thunks. Thus, this Core
1210 -- is impermissible:
1211 --
1212 -- let x :: ()
1213 -- x = y
1214 --
1215 -- (where y is a reference to a GLOBAL variable). Thunks like this are silly:
1216 -- they can always be profitably replaced by inlining x with y. Consequently,
1217 -- the code generator/runtime does not bother implementing this properly
1218 -- (specifically, there is no implementation of stg_ap_0_upd_info, which is the
1219 -- stack frame that would be used to update this thunk. The "0" means it has
1220 -- zero free variables.)
1221 --
1222 -- In general, the inliner is good at eliminating these let-bindings. However,
1223 -- there is one case where these trivial updatable thunks can arise: when
1224 -- we are optimizing away 'lazy' (see Note [lazyId magic], and also
1225 -- 'cpeRhsE'.) Then, we could have started with:
1226 --
1227 -- let x :: ()
1228 -- x = lazy @ () y
1229 --
1230 -- which is a perfectly fine, non-trivial thunk, but then CorePrep will
1231 -- drop 'lazy', giving us 'x = y' which is trivial and impermissible.
1232 -- The solution is CorePrep to have a miniature inlining pass which deals
1233 -- with cases like this. We can then drop the let-binding altogether.
1234 --
1235 -- Why does the removal of 'lazy' have to occur in CorePrep?
1236 -- The gory details are in Note [lazyId magic] in MkId, but the
1237 -- main reason is that lazy must appear in unfoldings (optimizer
1238 -- output) and it must prevent call-by-value for catch# (which
1239 -- is implemented by CorePrep.)
1240 --
1241 -- An alternate strategy for solving this problem is to have the
1242 -- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
1243 -- We decided not to adopt this solution to keep the definition
1244 -- of 'exprIsTrivial' simple.
1245 --
1246 -- There is ONE caveat however: for top-level bindings we have
1247 -- to preserve the binding so that we float the (hacky) non-recursive
1248 -- binding for data constructors; see Note [Data constructor workers].
1249 --
1250 -- Note [CorePrep inlines trivial CoreExpr not Id]
1251 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1252 -- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
1253 -- IdEnv Id? Naively, we might conjecture that trivial updatable thunks
1254 -- as per Note [Inlining in CorePrep] always have the form
1255 -- 'lazy @ SomeType gbl_id'. But this is not true: the following is
1256 -- perfectly reasonable Core:
1257 --
1258 -- let x :: ()
1259 -- x = lazy @ (forall a. a) y @ Bool
1260 --
1261 -- When we inline 'x' after eliminating 'lazy', we need to replace
1262 -- occurences of 'x' with 'y @ bool', not just 'y'. Situations like
1263 -- this can easily arise with higher-rank types; thus, cpe_env must
1264 -- map to CoreExprs, not Ids.
1265
1266 data CorePrepEnv
1267 = CPE { cpe_dynFlags :: DynFlags
1268 , cpe_env :: IdEnv CoreExpr -- Clone local Ids
1269 -- ^ This environment is used for three operations:
1270 --
1271 -- 1. To support cloning of local Ids so that they are
1272 -- all unique (see item (6) of CorePrep overview).
1273 --
1274 -- 2. To support beta-reduction of runRW, see
1275 -- Note [runRW magic] and Note [runRW arg].
1276 --
1277 -- 3. To let us inline trivial RHSs of non top-level let-bindings,
1278 -- see Note [lazyId magic], Note [Inlining in CorePrep]
1279 -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
1280 , cpe_mkIntegerId :: Id
1281 , cpe_integerSDataCon :: Maybe DataCon
1282 }
1283
1284 lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
1285 lookupMkIntegerName dflags hsc_env
1286 = guardIntegerUse dflags $ liftM tyThingId $
1287 lookupGlobal hsc_env mkIntegerName
1288
1289 lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
1290 lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
1291 IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
1292 lookupGlobal hsc_env integerSDataConName
1293 IntegerSimple -> return Nothing
1294
1295 -- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
1296 guardIntegerUse :: DynFlags -> IO a -> IO a
1297 guardIntegerUse dflags act
1298 | thisPackage dflags == primUnitId
1299 = return $ panic "Can't use Integer in ghc-prim"
1300 | thisPackage dflags == integerUnitId
1301 = return $ panic "Can't use Integer in integer-*"
1302 | otherwise = act
1303
1304 mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
1305 mkInitialCorePrepEnv dflags hsc_env
1306 = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
1307 integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
1308 return $ CPE {
1309 cpe_dynFlags = dflags,
1310 cpe_env = emptyVarEnv,
1311 cpe_mkIntegerId = mkIntegerId,
1312 cpe_integerSDataCon = integerSDataCon
1313 }
1314
1315 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
1316 extendCorePrepEnv cpe id id'
1317 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }
1318
1319 extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
1320 extendCorePrepEnvExpr cpe id expr
1321 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }
1322
1323 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
1324 extendCorePrepEnvList cpe prs
1325 = cpe { cpe_env = extendVarEnvList (cpe_env cpe)
1326 (map (\(id, id') -> (id, Var id')) prs) }
1327
1328 lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
1329 lookupCorePrepEnv cpe id
1330 = case lookupVarEnv (cpe_env cpe) id of
1331 Nothing -> Var id
1332 Just exp -> exp
1333
1334 getMkIntegerId :: CorePrepEnv -> Id
1335 getMkIntegerId = cpe_mkIntegerId
1336
1337 ------------------------------------------------------------------------------
1338 -- Cloning binders
1339 -- ---------------------------------------------------------------------------
1340
1341 cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
1342 cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
1343
1344 cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
1345 cpCloneBndr env bndr
1346 | isLocalId bndr, not (isCoVar bndr)
1347 = do bndr' <- setVarUnique bndr <$> getUniqueM
1348
1349 -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
1350 -- so that we can drop more stuff as dead code.
1351 -- See also Note [Dead code in CorePrep]
1352 let bndr'' = bndr' `setIdUnfolding` noUnfolding
1353 `setIdSpecialisation` emptyRuleInfo
1354 return (extendCorePrepEnv env bndr bndr'', bndr'')
1355
1356 | otherwise -- Top level things, which we don't want
1357 -- to clone, have become GlobalIds by now
1358 -- And we don't clone tyvars, or coercion variables
1359 = return (env, bndr)
1360
1361
1362 ------------------------------------------------------------------------------
1363 -- Cloning ccall Ids; each must have a unique name,
1364 -- to give the code generator a handle to hang it on
1365 -- ---------------------------------------------------------------------------
1366
1367 fiddleCCall :: Id -> UniqSM Id
1368 fiddleCCall id
1369 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
1370 | otherwise = return id
1371
1372 ------------------------------------------------------------------------------
1373 -- Generating new binders
1374 -- ---------------------------------------------------------------------------
1375
1376 newVar :: Type -> UniqSM Id
1377 newVar ty
1378 = seqType ty `seq` do
1379 uniq <- getUniqueM
1380 return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)
1381
1382
1383 ------------------------------------------------------------------------------
1384 -- Floating ticks
1385 -- ---------------------------------------------------------------------------
1386 --
1387 -- Note [Floating Ticks in CorePrep]
1388 --
1389 -- It might seem counter-intuitive to float ticks by default, given
1390 -- that we don't actually want to move them if we can help it. On the
1391 -- other hand, nothing gets very far in CorePrep anyway, and we want
1392 -- to preserve the order of let bindings and tick annotations in
1393 -- relation to each other. For example, if we just wrapped let floats
1394 -- when they pass through ticks, we might end up performing the
1395 -- following transformation:
1396 --
1397 -- src<...> let foo = bar in baz
1398 -- ==> let foo = src<...> bar in src<...> baz
1399 --
1400 -- Because the let-binding would float through the tick, and then
1401 -- immediately materialize, achieving nothing but decreasing tick
1402 -- accuracy. The only special case is the following scenario:
1403 --
1404 -- let foo = src<...> (let a = b in bar) in baz
1405 -- ==> let foo = src<...> bar; a = src<...> b in baz
1406 --
1407 -- Here we would not want the source tick to end up covering "baz" and
1408 -- therefore refrain from pushing ticks outside. Instead, we copy them
1409 -- into the floating binds (here "a") in cpePair. Note that where "b"
1410 -- or "bar" are (value) lambdas we have to push the annotations
1411 -- further inside in order to uphold our rules.
1412 --
1413 -- All of this is implemented below in @wrapTicks@.
1414
1415 -- | Like wrapFloats, but only wraps tick floats
1416 wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
1417 wrapTicks (Floats flag floats0) expr = (Floats flag floats1, expr')
1418 where (floats1, expr') = foldrOL go (nilOL, expr) floats0
1419 go (FloatTick t) (fs, e) = ASSERT(tickishPlace t == PlaceNonLam)
1420 (mapOL (wrap t) fs, mkTick t e)
1421 go other (fs, e) = (other `consOL` fs, e)
1422 wrap t (FloatLet bind) = FloatLet (wrapBind t bind)
1423 wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
1424 wrap _ other = pprPanic "wrapTicks: unexpected float!"
1425 (ppr other)
1426 wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
1427 wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs)