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