Fix binary-trees regression from unnecessary floating 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 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 ; cpe_app top_env terminal args depth
672 }
673
674 where
675 -- We have a nested data structure of the form
676 -- e `App` a1 `App` a2 ... `App` an, convert it into
677 -- (e, [CpeArg a1, CpeArg a2, ..., CpeArg an], depth)
678 -- We use 'CpeArg' because we may also need to
679 -- record casts and ticks. Depth counts the number
680 -- of arguments that would consume strictness information
681 -- (so, no type or coercion arguments.)
682 collect_args :: CoreExpr -> (CoreExpr, [CpeArg], Int)
683 collect_args e = go e [] 0
684 where
685 go (App fun arg) as depth
686 = go fun (CpeArg arg : as)
687 (if isTyCoArg arg then depth else depth + 1)
688 go (Cast fun co) as depth
689 = go fun (CpeCast co : as) depth
690 go (Tick tickish fun) as depth
691 | tickishPlace tickish == PlaceNonLam
692 && tickish `tickishScopesLike` SoftScope
693 = go fun (CpeTick tickish : as) depth
694 go terminal as depth = (terminal, as, depth)
695
696 cpe_app :: CorePrepEnv
697 -> CoreExpr
698 -> [CpeArg]
699 -> Int
700 -> UniqSM (Floats, CpeRhs)
701 cpe_app env (Var f) (CpeArg Type{} : CpeArg arg : args) depth
702 | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and
703 || f `hasKey` noinlineIdKey -- Replace (noinline a) with a
704 -- Consider the code:
705 --
706 -- lazy (f x) y
707 --
708 -- We need to make sure that we need to recursively collect arguments on
709 -- "f x", otherwise we'll float "f x" out (it's not a variable) and
710 -- end up with this awful -ddump-prep:
711 --
712 -- case f x of f_x {
713 -- __DEFAULT -> f_x y
714 -- }
715 --
716 -- rather than the far superior "f x y". Test case is par01.
717 = let (terminal, args', depth') = collect_args arg
718 in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
719 cpe_app env (Var f) [CpeArg _runtimeRep@Type{}, CpeArg _type@Type{}, CpeArg arg] 1
720 | f `hasKey` runRWKey
721 -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
722 -- is why we return a CorePrepEnv as well)
723 = case arg of
724 Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0
725 _ -> cpe_app env arg [CpeArg (Var realWorldPrimId)] 1
726 cpe_app env (Var v) args depth
727 = do { v1 <- fiddleCCall v
728 ; let e2 = lookupCorePrepEnv env v1
729 hd = getIdFromTrivialExpr_maybe e2
730 -- NB: depth from collect_args 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 ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts
736 ; mb_saturate hd app floats depth }
737 where
738 stricts = case idStrictness v of
739 StrictSig (DmdType _ demands _)
740 | listLengthCmp demands depth /= GT -> demands
741 -- length demands <= depth
742 | otherwise -> []
743 -- If depth < length demands, then we have too few args to
744 -- satisfy strictness info so we have to ignore all the
745 -- strictness info, e.g. + (error "urk")
746 -- Here, we can't evaluate the arg strictly, because this
747 -- partial application might be seq'd
748
749 -- We inlined into something that's not a var and has no args.
750 -- Bounce it back up to cpeRhsE.
751 cpe_app env fun [] _ = cpeRhsE env fun
752
753 -- N-variable fun, better let-bind it
754 cpe_app env fun args depth
755 = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
756 -- The evalDmd says that it's sure to be evaluated,
757 -- so we'll end up case-binding it
758 ; (app, floats) <- rebuild_app args fun' ty fun_floats []
759 ; mb_saturate Nothing app floats depth }
760 where
761 ty = exprType fun
762
763 -- Saturate if necessary
764 mb_saturate head app floats depth =
765 case head of
766 Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth
767 ; return (floats, sat_app) }
768 _other -> return (floats, app)
769
770 -- Deconstruct and rebuild the application, floating any non-atomic
771 -- arguments to the outside. We collect the type of the expression,
772 -- the head of the application, and the number of actual value arguments,
773 -- all of which are used to possibly saturate this application if it
774 -- has a constructor or primop at the head.
775 rebuild_app
776 :: [CpeArg] -- The arguments (inner to outer)
777 -> CpeApp
778 -> Type
779 -> Floats
780 -> [Demand]
781 -> UniqSM (CpeApp, Floats)
782 rebuild_app [] app _ floats ss = do
783 MASSERT(null ss) -- make sure we used all the strictness info
784 return (app, floats)
785 rebuild_app (a : as) fun' fun_ty floats ss = case a of
786 CpeArg arg@(Type arg_ty) ->
787 rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss
788 CpeArg arg@(Coercion {}) ->
789 rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss
790 CpeArg arg -> do
791 let (ss1, ss_rest) -- See Note [lazyId magic] in MkId
792 = case (ss, isLazyExpr arg) of
793 (_ : ss_rest, True) -> (topDmd, ss_rest)
794 (ss1 : ss_rest, False) -> (ss1, ss_rest)
795 ([], _) -> (topDmd, [])
796 (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
797 splitFunTy_maybe fun_ty
798 (fs, arg') <- cpeArg top_env ss1 arg arg_ty
799 rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest
800 CpeCast co ->
801 let Pair _ty1 ty2 = coercionKind co
802 in rebuild_app as (Cast fun' co) ty2 floats ss
803 CpeTick tickish ->
804 -- See [Floating Ticks in CorePrep]
805 rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss
806
807 isLazyExpr :: CoreExpr -> Bool
808 -- See Note [lazyId magic] in MkId
809 isLazyExpr (Cast e _) = isLazyExpr e
810 isLazyExpr (Tick _ e) = isLazyExpr e
811 isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey
812 isLazyExpr _ = False
813
814 -- ---------------------------------------------------------------------------
815 -- CpeArg: produces a result satisfying CpeArg
816 -- ---------------------------------------------------------------------------
817
818 -- This is where we arrange that a non-trivial argument is let-bound
819 cpeArg :: CorePrepEnv -> Demand
820 -> CoreArg -> Type -> UniqSM (Floats, CpeTriv)
821 cpeArg env dmd arg arg_ty
822 = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
823 ; (floats2, arg2) <- if want_float floats1 arg1
824 then return (floats1, arg1)
825 else dontFloat floats1 arg1
826 -- Else case: arg1 might have lambdas, and we can't
827 -- put them inside a wrapBinds
828
829 ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument
830 then return (floats2, arg2)
831 else do
832 { v <- newVar arg_ty
833 ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
834 arg_float = mkFloat dmd is_unlifted v arg3
835 ; return (addFloat floats2 arg_float, varToCoreExpr v) } }
836 where
837 is_unlifted = isUnliftedType arg_ty
838 want_float = wantFloatNested NonRecursive dmd is_unlifted
839
840 {-
841 Note [Floating unlifted arguments]
842 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
843 Consider C (let v* = expensive in v)
844
845 where the "*" indicates "will be demanded". Usually v will have been
846 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
847 do *not* want to get
848
849 let v* = expensive in C v
850
851 because that has different strictness. Hence the use of 'allLazy'.
852 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
853
854
855 ------------------------------------------------------------------------------
856 -- Building the saturated syntax
857 -- ---------------------------------------------------------------------------
858
859 maybeSaturate deals with saturating primops and constructors
860 The type is the type of the entire application
861 -}
862
863 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
864 maybeSaturate fn expr n_args
865 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
866 -- A gruesome special case
867 = saturateDataToTag sat_expr
868
869 | hasNoBinding fn -- There's no binding
870 = return sat_expr
871
872 | otherwise
873 = return expr
874 where
875 fn_arity = idArity fn
876 excess_arity = fn_arity - n_args
877 sat_expr = cpeEtaExpand excess_arity expr
878
879 -------------
880 saturateDataToTag :: CpeApp -> UniqSM CpeApp
881 -- See Note [dataToTag magic]
882 saturateDataToTag sat_expr
883 = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
884 ; eta_body' <- eval_data2tag_arg eta_body
885 ; return (mkLams eta_bndrs eta_body') }
886 where
887 eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
888 eval_data2tag_arg app@(fun `App` arg)
889 | exprIsHNF arg -- Includes nullary constructors
890 = return app -- The arg is evaluated
891 | otherwise -- Arg not evaluated, so evaluate it
892 = do { arg_id <- newVar (exprType arg)
893 ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
894 ; return (Case arg arg_id1 (exprType app)
895 [(DEFAULT, [], fun `App` Var arg_id1)]) }
896
897 eval_data2tag_arg (Tick t app) -- Scc notes can appear
898 = do { app' <- eval_data2tag_arg app
899 ; return (Tick t app') }
900
901 eval_data2tag_arg other -- Should not happen
902 = pprPanic "eval_data2tag" (ppr other)
903
904 {-
905 Note [dataToTag magic]
906 ~~~~~~~~~~~~~~~~~~~~~~
907 Horrid: we must ensure that the arg of data2TagOp is evaluated
908 (data2tag x) --> (case x of y -> data2tag y)
909 (yuk yuk) take into account the lambdas we've now introduced
910
911 How might it not be evaluated? Well, we might have floated it out
912 of the scope of a `seq`, or dropped the `seq` altogether.
913
914
915 ************************************************************************
916 * *
917 Simple CoreSyn operations
918 * *
919 ************************************************************************
920 -}
921
922 cpe_ExprIsTrivial :: CoreExpr -> Bool
923 -- Version that doesn't consider an scc annotation to be trivial.
924 -- See also 'exprIsTrivial'
925 cpe_ExprIsTrivial (Var _) = True
926 cpe_ExprIsTrivial (Type _) = True
927 cpe_ExprIsTrivial (Coercion _) = True
928 cpe_ExprIsTrivial (Lit _) = True
929 cpe_ExprIsTrivial (App e arg) = not (isRuntimeArg arg) && cpe_ExprIsTrivial e
930 cpe_ExprIsTrivial (Lam b e) = not (isRuntimeVar b) && cpe_ExprIsTrivial e
931 cpe_ExprIsTrivial (Tick t e) = not (tickishIsCode t) && cpe_ExprIsTrivial e
932 cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
933 cpe_ExprIsTrivial (Case e _ _ []) = cpe_ExprIsTrivial e
934 -- See Note [Empty case is trivial] in CoreUtils
935 cpe_ExprIsTrivial _ = False
936
937 {-
938 -- -----------------------------------------------------------------------------
939 -- Eta reduction
940 -- -----------------------------------------------------------------------------
941
942 Note [Eta expansion]
943 ~~~~~~~~~~~~~~~~~~~~~
944 Eta expand to match the arity claimed by the binder Remember,
945 CorePrep must not change arity
946
947 Eta expansion might not have happened already, because it is done by
948 the simplifier only when there at least one lambda already.
949
950 NB1:we could refrain when the RHS is trivial (which can happen
951 for exported things). This would reduce the amount of code
952 generated (a little) and make things a little words for
953 code compiled without -O. The case in point is data constructor
954 wrappers.
955
956 NB2: we have to be careful that the result of etaExpand doesn't
957 invalidate any of the assumptions that CorePrep is attempting
958 to establish. One possible cause is eta expanding inside of
959 an SCC note - we're now careful in etaExpand to make sure the
960 SCC is pushed inside any new lambdas that are generated.
961
962 Note [Eta expansion and the CorePrep invariants]
963 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
964 It turns out to be much much easier to do eta expansion
965 *after* the main CorePrep stuff. But that places constraints
966 on the eta expander: given a CpeRhs, it must return a CpeRhs.
967
968 For example here is what we do not want:
969 f = /\a -> g (h 3) -- h has arity 2
970 After ANFing we get
971 f = /\a -> let s = h 3 in g s
972 and now we do NOT want eta expansion to give
973 f = /\a -> \ y -> (let s = h 3 in g s) y
974
975 Instead CoreArity.etaExpand gives
976 f = /\a -> \y -> let s = h 3 in g s y
977 -}
978
979 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
980 cpeEtaExpand arity expr
981 | arity == 0 = expr
982 | otherwise = etaExpand arity expr
983
984 {-
985 -- -----------------------------------------------------------------------------
986 -- Eta reduction
987 -- -----------------------------------------------------------------------------
988
989 Why try eta reduction? Hasn't the simplifier already done eta?
990 But the simplifier only eta reduces if that leaves something
991 trivial (like f, or f Int). But for deLam it would be enough to
992 get to a partial application:
993 case x of { p -> \xs. map f xs }
994 ==> case x of { p -> map f }
995 -}
996
997 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
998 tryEtaReducePrep bndrs expr@(App _ _)
999 | ok_to_eta_reduce f
1000 , n_remaining >= 0
1001 , and (zipWith ok bndrs last_args)
1002 , not (any (`elemVarSet` fvs_remaining) bndrs)
1003 , exprIsHNF remaining_expr -- Don't turn value into a non-value
1004 -- else the behaviour with 'seq' changes
1005 = Just remaining_expr
1006 where
1007 (f, args) = collectArgs expr
1008 remaining_expr = mkApps f remaining_args
1009 fvs_remaining = exprFreeVars remaining_expr
1010 (remaining_args, last_args) = splitAt n_remaining args
1011 n_remaining = length args - length bndrs
1012
1013 ok bndr (Var arg) = bndr == arg
1014 ok _ _ = False
1015
1016 -- We can't eta reduce something which must be saturated.
1017 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
1018 ok_to_eta_reduce _ = False -- Safe. ToDo: generalise
1019
1020 tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
1021 | not (any (`elemVarSet` fvs) bndrs)
1022 = case tryEtaReducePrep bndrs body of
1023 Just e -> Just (Let bind e)
1024 Nothing -> Nothing
1025 where
1026 fvs = exprFreeVars r
1027
1028 -- NB: do not attempt to eta-reduce across ticks
1029 -- Otherwise we risk reducing
1030 -- \x. (Tick (Breakpoint {x}) f x)
1031 -- ==> Tick (breakpoint {x}) f
1032 -- which is bogus (Trac #17228)
1033 -- tryEtaReducePrep bndrs (Tick tickish e)
1034 -- = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
1035
1036 tryEtaReducePrep _ _ = Nothing
1037
1038 {-
1039 ************************************************************************
1040 * *
1041 Floats
1042 * *
1043 ************************************************************************
1044
1045 Note [Pin demand info on floats]
1046 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1047 We pin demand info on floated lets so that we can see the one-shot thunks.
1048 -}
1049
1050 data FloatingBind
1051 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
1052 -- They are always of lifted type;
1053 -- unlifted ones are done with FloatCase
1054
1055 | FloatCase
1056 Id CpeBody
1057 Bool -- The bool indicates "ok-for-speculation"
1058
1059 -- | See Note [Floating Ticks in CorePrep]
1060 | FloatTick (Tickish Id)
1061
1062 data Floats = Floats OkToSpec (OrdList FloatingBind)
1063
1064 instance Outputable FloatingBind where
1065 ppr (FloatLet b) = ppr b
1066 ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
1067 ppr (FloatTick t) = ppr t
1068
1069 instance Outputable Floats where
1070 ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>
1071 braces (vcat (map ppr (fromOL fs)))
1072
1073 instance Outputable OkToSpec where
1074 ppr OkToSpec = text "OkToSpec"
1075 ppr IfUnboxedOk = text "IfUnboxedOk"
1076 ppr NotOkToSpec = text "NotOkToSpec"
1077
1078 -- Can we float these binds out of the rhs of a let? We cache this decision
1079 -- to avoid having to recompute it in a non-linear way when there are
1080 -- deeply nested lets.
1081 data OkToSpec
1082 = OkToSpec -- Lazy bindings of lifted type
1083 | IfUnboxedOk -- A mixture of lazy lifted bindings and n
1084 -- ok-to-speculate unlifted bindings
1085 | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
1086
1087 mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
1088 mkFloat dmd is_unlifted bndr rhs
1089 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
1090 | is_hnf = FloatLet (NonRec bndr rhs)
1091 | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
1092 -- See Note [Pin demand info on floats]
1093 where
1094 is_hnf = exprIsHNF rhs
1095 is_strict = isStrictDmd dmd
1096 use_case = is_unlifted || is_strict && not is_hnf
1097 -- Don't make a case for a value binding,
1098 -- even if it's strict. Otherwise we get
1099 -- case (\x -> e) of ...!
1100
1101 emptyFloats :: Floats
1102 emptyFloats = Floats OkToSpec nilOL
1103
1104 isEmptyFloats :: Floats -> Bool
1105 isEmptyFloats (Floats _ bs) = isNilOL bs
1106
1107 wrapBinds :: Floats -> CpeBody -> CpeBody
1108 wrapBinds (Floats _ binds) body
1109 = foldrOL mk_bind body binds
1110 where
1111 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
1112 mk_bind (FloatLet bind) body = Let bind body
1113 mk_bind (FloatTick tickish) body = mkTick tickish body
1114
1115 addFloat :: Floats -> FloatingBind -> Floats
1116 addFloat (Floats ok_to_spec floats) new_float
1117 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
1118 where
1119 check (FloatLet _) = OkToSpec
1120 check (FloatCase _ _ ok_for_spec)
1121 | ok_for_spec = IfUnboxedOk
1122 | otherwise = NotOkToSpec
1123 check FloatTick{} = OkToSpec
1124 -- The ok-for-speculation flag says that it's safe to
1125 -- float this Case out of a let, and thereby do it more eagerly
1126 -- We need the top-level flag because it's never ok to float
1127 -- an unboxed binding to the top level
1128
1129 unitFloat :: FloatingBind -> Floats
1130 unitFloat = addFloat emptyFloats
1131
1132 appendFloats :: Floats -> Floats -> Floats
1133 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
1134 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
1135
1136 concatFloats :: [Floats] -> OrdList FloatingBind
1137 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
1138
1139 combine :: OkToSpec -> OkToSpec -> OkToSpec
1140 combine NotOkToSpec _ = NotOkToSpec
1141 combine _ NotOkToSpec = NotOkToSpec
1142 combine IfUnboxedOk _ = IfUnboxedOk
1143 combine _ IfUnboxedOk = IfUnboxedOk
1144 combine _ _ = OkToSpec
1145
1146 deFloatTop :: Floats -> [CoreBind]
1147 -- For top level only; we don't expect any FloatCases
1148 deFloatTop (Floats _ floats)
1149 = foldrOL get [] floats
1150 where
1151 get (FloatLet b) bs = occurAnalyseRHSs b : bs
1152 get b _ = pprPanic "corePrepPgm" (ppr b)
1153
1154 -- See Note [Dead code in CorePrep]
1155 occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
1156 occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]
1157
1158 ---------------------------------------------------------------------------
1159
1160 canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
1161 -- Note [CafInfo and floating]
1162 canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
1163 | OkToSpec <- ok_to_spec -- Worth trying
1164 , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
1165 = Just (Floats OkToSpec fs', subst_expr subst rhs)
1166 | otherwise
1167 = Nothing
1168 where
1169 subst_expr = substExpr (text "CorePrep")
1170
1171 go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
1172 -> Maybe (Subst, OrdList FloatingBind)
1173
1174 go (subst, fbs_out) [] = Just (subst, fbs_out)
1175
1176 go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
1177 | rhs_ok r
1178 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1179 where
1180 (subst', b') = set_nocaf_bndr subst b
1181 new_fb = FloatLet (NonRec b' (subst_expr subst r))
1182
1183 go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
1184 | all rhs_ok rs
1185 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1186 where
1187 (bs,rs) = unzip prs
1188 (subst', bs') = mapAccumL set_nocaf_bndr subst bs
1189 rs' = map (subst_expr subst') rs
1190 new_fb = FloatLet (Rec (bs' `zip` rs'))
1191
1192 go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
1193 = go (subst, fbs_out `snocOL` ft) fbs_in
1194
1195 go _ _ = Nothing -- Encountered a caffy binding
1196
1197 ------------
1198 set_nocaf_bndr subst bndr
1199 = (extendIdSubst subst bndr (Var bndr'), bndr')
1200 where
1201 bndr' = bndr `setIdCafInfo` NoCafRefs
1202
1203 ------------
1204 rhs_ok :: CoreExpr -> Bool
1205 -- We can only float to top level from a NoCaf thing if
1206 -- the new binding is static. However it can't mention
1207 -- any non-static things or it would *already* be Caffy
1208 rhs_ok = rhsIsStatic platform (\_ -> False)
1209 (\i -> pprPanic "rhsIsStatic" (integer i))
1210 -- Integer literals should not show up
1211
1212 wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
1213 wantFloatNested is_rec dmd is_unlifted floats rhs
1214 = isEmptyFloats floats
1215 || isStrictDmd dmd
1216 || is_unlifted
1217 || (allLazyNested is_rec floats && exprIsHNF rhs)
1218 -- Why the test for allLazyNested?
1219 -- v = f (x `divInt#` y)
1220 -- we don't want to float the case, even if f has arity 2,
1221 -- because floating the case would make it evaluated too early
1222
1223 allLazyTop :: Floats -> Bool
1224 allLazyTop (Floats OkToSpec _) = True
1225 allLazyTop _ = False
1226
1227 allLazyNested :: RecFlag -> Floats -> Bool
1228 allLazyNested _ (Floats OkToSpec _) = True
1229 allLazyNested _ (Floats NotOkToSpec _) = False
1230 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
1231
1232 {-
1233 ************************************************************************
1234 * *
1235 Cloning
1236 * *
1237 ************************************************************************
1238 -}
1239
1240 -- ---------------------------------------------------------------------------
1241 -- The environment
1242 -- ---------------------------------------------------------------------------
1243
1244 -- Note [Inlining in CorePrep]
1245 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1246 -- There is a subtle but important invariant that must be upheld in the output
1247 -- of CorePrep: there are no "trivial" updatable thunks. Thus, this Core
1248 -- is impermissible:
1249 --
1250 -- let x :: ()
1251 -- x = y
1252 --
1253 -- (where y is a reference to a GLOBAL variable). Thunks like this are silly:
1254 -- they can always be profitably replaced by inlining x with y. Consequently,
1255 -- the code generator/runtime does not bother implementing this properly
1256 -- (specifically, there is no implementation of stg_ap_0_upd_info, which is the
1257 -- stack frame that would be used to update this thunk. The "0" means it has
1258 -- zero free variables.)
1259 --
1260 -- In general, the inliner is good at eliminating these let-bindings. However,
1261 -- there is one case where these trivial updatable thunks can arise: when
1262 -- we are optimizing away 'lazy' (see Note [lazyId magic], and also
1263 -- 'cpeRhsE'.) Then, we could have started with:
1264 --
1265 -- let x :: ()
1266 -- x = lazy @ () y
1267 --
1268 -- which is a perfectly fine, non-trivial thunk, but then CorePrep will
1269 -- drop 'lazy', giving us 'x = y' which is trivial and impermissible.
1270 -- The solution is CorePrep to have a miniature inlining pass which deals
1271 -- with cases like this. We can then drop the let-binding altogether.
1272 --
1273 -- Why does the removal of 'lazy' have to occur in CorePrep?
1274 -- The gory details are in Note [lazyId magic] in MkId, but the
1275 -- main reason is that lazy must appear in unfoldings (optimizer
1276 -- output) and it must prevent call-by-value for catch# (which
1277 -- is implemented by CorePrep.)
1278 --
1279 -- An alternate strategy for solving this problem is to have the
1280 -- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
1281 -- We decided not to adopt this solution to keep the definition
1282 -- of 'exprIsTrivial' simple.
1283 --
1284 -- There is ONE caveat however: for top-level bindings we have
1285 -- to preserve the binding so that we float the (hacky) non-recursive
1286 -- binding for data constructors; see Note [Data constructor workers].
1287 --
1288 -- Note [CorePrep inlines trivial CoreExpr not Id]
1289 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1290 -- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
1291 -- IdEnv Id? Naively, we might conjecture that trivial updatable thunks
1292 -- as per Note [Inlining in CorePrep] always have the form
1293 -- 'lazy @ SomeType gbl_id'. But this is not true: the following is
1294 -- perfectly reasonable Core:
1295 --
1296 -- let x :: ()
1297 -- x = lazy @ (forall a. a) y @ Bool
1298 --
1299 -- When we inline 'x' after eliminating 'lazy', we need to replace
1300 -- occurences of 'x' with 'y @ bool', not just 'y'. Situations like
1301 -- this can easily arise with higher-rank types; thus, cpe_env must
1302 -- map to CoreExprs, not Ids.
1303
1304 data CorePrepEnv
1305 = CPE { cpe_dynFlags :: DynFlags
1306 , cpe_env :: IdEnv CoreExpr -- Clone local Ids
1307 -- ^ This environment is used for three operations:
1308 --
1309 -- 1. To support cloning of local Ids so that they are
1310 -- all unique (see item (6) of CorePrep overview).
1311 --
1312 -- 2. To support beta-reduction of runRW, see
1313 -- Note [runRW magic] and Note [runRW arg].
1314 --
1315 -- 3. To let us inline trivial RHSs of non top-level let-bindings,
1316 -- see Note [lazyId magic], Note [Inlining in CorePrep]
1317 -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
1318 , cpe_mkIntegerId :: Id
1319 , cpe_integerSDataCon :: Maybe DataCon
1320 }
1321
1322 lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
1323 lookupMkIntegerName dflags hsc_env
1324 = guardIntegerUse dflags $ liftM tyThingId $
1325 lookupGlobal hsc_env mkIntegerName
1326
1327 lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
1328 lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
1329 IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
1330 lookupGlobal hsc_env integerSDataConName
1331 IntegerSimple -> return Nothing
1332
1333 -- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
1334 guardIntegerUse :: DynFlags -> IO a -> IO a
1335 guardIntegerUse dflags act
1336 | thisPackage dflags == primUnitId
1337 = return $ panic "Can't use Integer in ghc-prim"
1338 | thisPackage dflags == integerUnitId
1339 = return $ panic "Can't use Integer in integer-*"
1340 | otherwise = act
1341
1342 mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
1343 mkInitialCorePrepEnv dflags hsc_env
1344 = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
1345 integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
1346 return $ CPE {
1347 cpe_dynFlags = dflags,
1348 cpe_env = emptyVarEnv,
1349 cpe_mkIntegerId = mkIntegerId,
1350 cpe_integerSDataCon = integerSDataCon
1351 }
1352
1353 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
1354 extendCorePrepEnv cpe id id'
1355 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }
1356
1357 extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
1358 extendCorePrepEnvExpr cpe id expr
1359 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }
1360
1361 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
1362 extendCorePrepEnvList cpe prs
1363 = cpe { cpe_env = extendVarEnvList (cpe_env cpe)
1364 (map (\(id, id') -> (id, Var id')) prs) }
1365
1366 lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
1367 lookupCorePrepEnv cpe id
1368 = case lookupVarEnv (cpe_env cpe) id of
1369 Nothing -> Var id
1370 Just exp -> exp
1371
1372 getMkIntegerId :: CorePrepEnv -> Id
1373 getMkIntegerId = cpe_mkIntegerId
1374
1375 ------------------------------------------------------------------------------
1376 -- Cloning binders
1377 -- ---------------------------------------------------------------------------
1378
1379 cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
1380 cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
1381
1382 cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
1383 cpCloneBndr env bndr
1384 | isLocalId bndr, not (isCoVar bndr)
1385 = do bndr' <- setVarUnique bndr <$> getUniqueM
1386
1387 -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
1388 -- so that we can drop more stuff as dead code.
1389 -- See also Note [Dead code in CorePrep]
1390 let bndr'' = bndr' `setIdUnfolding` noUnfolding
1391 `setIdSpecialisation` emptyRuleInfo
1392 return (extendCorePrepEnv env bndr bndr'', bndr'')
1393
1394 | otherwise -- Top level things, which we don't want
1395 -- to clone, have become GlobalIds by now
1396 -- And we don't clone tyvars, or coercion variables
1397 = return (env, bndr)
1398
1399
1400 ------------------------------------------------------------------------------
1401 -- Cloning ccall Ids; each must have a unique name,
1402 -- to give the code generator a handle to hang it on
1403 -- ---------------------------------------------------------------------------
1404
1405 fiddleCCall :: Id -> UniqSM Id
1406 fiddleCCall id
1407 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
1408 | otherwise = return id
1409
1410 ------------------------------------------------------------------------------
1411 -- Generating new binders
1412 -- ---------------------------------------------------------------------------
1413
1414 newVar :: Type -> UniqSM Id
1415 newVar ty
1416 = seqType ty `seq` do
1417 uniq <- getUniqueM
1418 return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)
1419
1420
1421 ------------------------------------------------------------------------------
1422 -- Floating ticks
1423 -- ---------------------------------------------------------------------------
1424 --
1425 -- Note [Floating Ticks in CorePrep]
1426 --
1427 -- It might seem counter-intuitive to float ticks by default, given
1428 -- that we don't actually want to move them if we can help it. On the
1429 -- other hand, nothing gets very far in CorePrep anyway, and we want
1430 -- to preserve the order of let bindings and tick annotations in
1431 -- relation to each other. For example, if we just wrapped let floats
1432 -- when they pass through ticks, we might end up performing the
1433 -- following transformation:
1434 --
1435 -- src<...> let foo = bar in baz
1436 -- ==> let foo = src<...> bar in src<...> baz
1437 --
1438 -- Because the let-binding would float through the tick, and then
1439 -- immediately materialize, achieving nothing but decreasing tick
1440 -- accuracy. The only special case is the following scenario:
1441 --
1442 -- let foo = src<...> (let a = b in bar) in baz
1443 -- ==> let foo = src<...> bar; a = src<...> b in baz
1444 --
1445 -- Here we would not want the source tick to end up covering "baz" and
1446 -- therefore refrain from pushing ticks outside. Instead, we copy them
1447 -- into the floating binds (here "a") in cpePair. Note that where "b"
1448 -- or "bar" are (value) lambdas we have to push the annotations
1449 -- further inside in order to uphold our rules.
1450 --
1451 -- All of this is implemented below in @wrapTicks@.
1452
1453 -- | Like wrapFloats, but only wraps tick floats
1454 wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
1455 wrapTicks (Floats flag floats0) expr = (Floats flag floats1, expr')
1456 where (floats1, expr') = foldrOL go (nilOL, expr) floats0
1457 go (FloatTick t) (fs, e) = ASSERT(tickishPlace t == PlaceNonLam)
1458 (mapOL (wrap t) fs, mkTick t e)
1459 go other (fs, e) = (other `consOL` fs, e)
1460 wrap t (FloatLet bind) = FloatLet (wrapBind t bind)
1461 wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
1462 wrap _ other = pprPanic "wrapTicks: unexpected float!"
1463 (ppr other)
1464 wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
1465 wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs)