Renaming and comments 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 Note [CorePrep invariants]
131 ~~~~~~~~~~~~~~~~~~~~~~~~~~
132 Here is the syntax of the Core produced by CorePrep:
133
134 Trivial expressions
135 arg ::= lit | var
136 | arg ty | /\a. arg
137 | truv co | /\c. arg | arg |> co
138
139 Applications
140 app ::= lit | var | app arg | 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 CpeArg = CoreExpr -- Non-terminal 'arg'
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 ArgInfo = CpeApp 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, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)
678 -- We use 'ArgInfo' 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, [ArgInfo], Int)
683 collect_args e = go e [] 0
684 where
685 go (App fun arg) as depth
686 = go fun (CpeApp 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 -> [ArgInfo]
699 -> Int
700 -> UniqSM (Floats, CpeRhs)
701 cpe_app env (Var f) (CpeApp Type{} : CpeApp 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) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp 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 [CpeApp (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 :: [ArgInfo] -- 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 CpeApp arg@(Type arg_ty) ->
787 rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss
788 CpeApp arg@(Coercion {}) ->
789 rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss
790 CpeApp 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, CpeArg)
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 -- This function differs from CoreUtils.exprIsTrivial only in its
924 -- treatment of (Lit l). Otherwise it's identical.
925 -- No one knows why this difference is important: Trac #11158.
926 -- Someone should find out
927 cpe_ExprIsTrivial (Var _) = True
928 cpe_ExprIsTrivial (Type _) = True
929 cpe_ExprIsTrivial (Coercion _) = True
930 cpe_ExprIsTrivial (Lit _) = True
931 cpe_ExprIsTrivial (App e arg) = not (isRuntimeArg arg) && cpe_ExprIsTrivial e
932 cpe_ExprIsTrivial (Lam b e) = not (isRuntimeVar b) && cpe_ExprIsTrivial e
933 cpe_ExprIsTrivial (Tick t e) = not (tickishIsCode t) && cpe_ExprIsTrivial e
934 cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
935 cpe_ExprIsTrivial (Case e _ _ []) = cpe_ExprIsTrivial e
936 -- See Note [Empty case is trivial] in CoreUtils
937 cpe_ExprIsTrivial _ = False
938
939 {-
940 -- -----------------------------------------------------------------------------
941 -- Eta reduction
942 -- -----------------------------------------------------------------------------
943
944 Note [Eta expansion]
945 ~~~~~~~~~~~~~~~~~~~~~
946 Eta expand to match the arity claimed by the binder Remember,
947 CorePrep must not change arity
948
949 Eta expansion might not have happened already, because it is done by
950 the simplifier only when there at least one lambda already.
951
952 NB1:we could refrain when the RHS is trivial (which can happen
953 for exported things). This would reduce the amount of code
954 generated (a little) and make things a little words for
955 code compiled without -O. The case in point is data constructor
956 wrappers.
957
958 NB2: we have to be careful that the result of etaExpand doesn't
959 invalidate any of the assumptions that CorePrep is attempting
960 to establish. One possible cause is eta expanding inside of
961 an SCC note - we're now careful in etaExpand to make sure the
962 SCC is pushed inside any new lambdas that are generated.
963
964 Note [Eta expansion and the CorePrep invariants]
965 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
966 It turns out to be much much easier to do eta expansion
967 *after* the main CorePrep stuff. But that places constraints
968 on the eta expander: given a CpeRhs, it must return a CpeRhs.
969
970 For example here is what we do not want:
971 f = /\a -> g (h 3) -- h has arity 2
972 After ANFing we get
973 f = /\a -> let s = h 3 in g s
974 and now we do NOT want eta expansion to give
975 f = /\a -> \ y -> (let s = h 3 in g s) y
976
977 Instead CoreArity.etaExpand gives
978 f = /\a -> \y -> let s = h 3 in g s y
979 -}
980
981 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
982 cpeEtaExpand arity expr
983 | arity == 0 = expr
984 | otherwise = etaExpand arity expr
985
986 {-
987 -- -----------------------------------------------------------------------------
988 -- Eta reduction
989 -- -----------------------------------------------------------------------------
990
991 Why try eta reduction? Hasn't the simplifier already done eta?
992 But the simplifier only eta reduces if that leaves something
993 trivial (like f, or f Int). But for deLam it would be enough to
994 get to a partial application:
995 case x of { p -> \xs. map f xs }
996 ==> case x of { p -> map f }
997 -}
998
999 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
1000 tryEtaReducePrep bndrs expr@(App _ _)
1001 | ok_to_eta_reduce f
1002 , n_remaining >= 0
1003 , and (zipWith ok bndrs last_args)
1004 , not (any (`elemVarSet` fvs_remaining) bndrs)
1005 , exprIsHNF remaining_expr -- Don't turn value into a non-value
1006 -- else the behaviour with 'seq' changes
1007 = Just remaining_expr
1008 where
1009 (f, args) = collectArgs expr
1010 remaining_expr = mkApps f remaining_args
1011 fvs_remaining = exprFreeVars remaining_expr
1012 (remaining_args, last_args) = splitAt n_remaining args
1013 n_remaining = length args - length bndrs
1014
1015 ok bndr (Var arg) = bndr == arg
1016 ok _ _ = False
1017
1018 -- We can't eta reduce something which must be saturated.
1019 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
1020 ok_to_eta_reduce _ = False -- Safe. ToDo: generalise
1021
1022 tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
1023 | not (any (`elemVarSet` fvs) bndrs)
1024 = case tryEtaReducePrep bndrs body of
1025 Just e -> Just (Let bind e)
1026 Nothing -> Nothing
1027 where
1028 fvs = exprFreeVars r
1029
1030 -- NB: do not attempt to eta-reduce across ticks
1031 -- Otherwise we risk reducing
1032 -- \x. (Tick (Breakpoint {x}) f x)
1033 -- ==> Tick (breakpoint {x}) f
1034 -- which is bogus (Trac #17228)
1035 -- tryEtaReducePrep bndrs (Tick tickish e)
1036 -- = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
1037
1038 tryEtaReducePrep _ _ = Nothing
1039
1040 {-
1041 ************************************************************************
1042 * *
1043 Floats
1044 * *
1045 ************************************************************************
1046
1047 Note [Pin demand info on floats]
1048 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1049 We pin demand info on floated lets so that we can see the one-shot thunks.
1050 -}
1051
1052 data FloatingBind
1053 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
1054 -- They are always of lifted type;
1055 -- unlifted ones are done with FloatCase
1056
1057 | FloatCase
1058 Id CpeBody
1059 Bool -- The bool indicates "ok-for-speculation"
1060
1061 -- | See Note [Floating Ticks in CorePrep]
1062 | FloatTick (Tickish Id)
1063
1064 data Floats = Floats OkToSpec (OrdList FloatingBind)
1065
1066 instance Outputable FloatingBind where
1067 ppr (FloatLet b) = ppr b
1068 ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
1069 ppr (FloatTick t) = ppr t
1070
1071 instance Outputable Floats where
1072 ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>
1073 braces (vcat (map ppr (fromOL fs)))
1074
1075 instance Outputable OkToSpec where
1076 ppr OkToSpec = text "OkToSpec"
1077 ppr IfUnboxedOk = text "IfUnboxedOk"
1078 ppr NotOkToSpec = text "NotOkToSpec"
1079
1080 -- Can we float these binds out of the rhs of a let? We cache this decision
1081 -- to avoid having to recompute it in a non-linear way when there are
1082 -- deeply nested lets.
1083 data OkToSpec
1084 = OkToSpec -- Lazy bindings of lifted type
1085 | IfUnboxedOk -- A mixture of lazy lifted bindings and n
1086 -- ok-to-speculate unlifted bindings
1087 | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
1088
1089 mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
1090 mkFloat dmd is_unlifted bndr rhs
1091 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
1092 | is_hnf = FloatLet (NonRec bndr rhs)
1093 | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
1094 -- See Note [Pin demand info on floats]
1095 where
1096 is_hnf = exprIsHNF rhs
1097 is_strict = isStrictDmd dmd
1098 use_case = is_unlifted || is_strict && not is_hnf
1099 -- Don't make a case for a value binding,
1100 -- even if it's strict. Otherwise we get
1101 -- case (\x -> e) of ...!
1102
1103 emptyFloats :: Floats
1104 emptyFloats = Floats OkToSpec nilOL
1105
1106 isEmptyFloats :: Floats -> Bool
1107 isEmptyFloats (Floats _ bs) = isNilOL bs
1108
1109 wrapBinds :: Floats -> CpeBody -> CpeBody
1110 wrapBinds (Floats _ binds) body
1111 = foldrOL mk_bind body binds
1112 where
1113 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
1114 mk_bind (FloatLet bind) body = Let bind body
1115 mk_bind (FloatTick tickish) body = mkTick tickish body
1116
1117 addFloat :: Floats -> FloatingBind -> Floats
1118 addFloat (Floats ok_to_spec floats) new_float
1119 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
1120 where
1121 check (FloatLet _) = OkToSpec
1122 check (FloatCase _ _ ok_for_spec)
1123 | ok_for_spec = IfUnboxedOk
1124 | otherwise = NotOkToSpec
1125 check FloatTick{} = OkToSpec
1126 -- The ok-for-speculation flag says that it's safe to
1127 -- float this Case out of a let, and thereby do it more eagerly
1128 -- We need the top-level flag because it's never ok to float
1129 -- an unboxed binding to the top level
1130
1131 unitFloat :: FloatingBind -> Floats
1132 unitFloat = addFloat emptyFloats
1133
1134 appendFloats :: Floats -> Floats -> Floats
1135 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
1136 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
1137
1138 concatFloats :: [Floats] -> OrdList FloatingBind
1139 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
1140
1141 combine :: OkToSpec -> OkToSpec -> OkToSpec
1142 combine NotOkToSpec _ = NotOkToSpec
1143 combine _ NotOkToSpec = NotOkToSpec
1144 combine IfUnboxedOk _ = IfUnboxedOk
1145 combine _ IfUnboxedOk = IfUnboxedOk
1146 combine _ _ = OkToSpec
1147
1148 deFloatTop :: Floats -> [CoreBind]
1149 -- For top level only; we don't expect any FloatCases
1150 deFloatTop (Floats _ floats)
1151 = foldrOL get [] floats
1152 where
1153 get (FloatLet b) bs = occurAnalyseRHSs b : bs
1154 get b _ = pprPanic "corePrepPgm" (ppr b)
1155
1156 -- See Note [Dead code in CorePrep]
1157 occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
1158 occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]
1159
1160 ---------------------------------------------------------------------------
1161
1162 canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
1163 -- Note [CafInfo and floating]
1164 canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
1165 | OkToSpec <- ok_to_spec -- Worth trying
1166 , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
1167 = Just (Floats OkToSpec fs', subst_expr subst rhs)
1168 | otherwise
1169 = Nothing
1170 where
1171 subst_expr = substExpr (text "CorePrep")
1172
1173 go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
1174 -> Maybe (Subst, OrdList FloatingBind)
1175
1176 go (subst, fbs_out) [] = Just (subst, fbs_out)
1177
1178 go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
1179 | rhs_ok r
1180 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1181 where
1182 (subst', b') = set_nocaf_bndr subst b
1183 new_fb = FloatLet (NonRec b' (subst_expr subst r))
1184
1185 go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
1186 | all rhs_ok rs
1187 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1188 where
1189 (bs,rs) = unzip prs
1190 (subst', bs') = mapAccumL set_nocaf_bndr subst bs
1191 rs' = map (subst_expr subst') rs
1192 new_fb = FloatLet (Rec (bs' `zip` rs'))
1193
1194 go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
1195 = go (subst, fbs_out `snocOL` ft) fbs_in
1196
1197 go _ _ = Nothing -- Encountered a caffy binding
1198
1199 ------------
1200 set_nocaf_bndr subst bndr
1201 = (extendIdSubst subst bndr (Var bndr'), bndr')
1202 where
1203 bndr' = bndr `setIdCafInfo` NoCafRefs
1204
1205 ------------
1206 rhs_ok :: CoreExpr -> Bool
1207 -- We can only float to top level from a NoCaf thing if
1208 -- the new binding is static. However it can't mention
1209 -- any non-static things or it would *already* be Caffy
1210 rhs_ok = rhsIsStatic platform (\_ -> False)
1211 (\i -> pprPanic "rhsIsStatic" (integer i))
1212 -- Integer literals should not show up
1213
1214 wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
1215 wantFloatNested is_rec dmd is_unlifted floats rhs
1216 = isEmptyFloats floats
1217 || isStrictDmd dmd
1218 || is_unlifted
1219 || (allLazyNested is_rec floats && exprIsHNF rhs)
1220 -- Why the test for allLazyNested?
1221 -- v = f (x `divInt#` y)
1222 -- we don't want to float the case, even if f has arity 2,
1223 -- because floating the case would make it evaluated too early
1224
1225 allLazyTop :: Floats -> Bool
1226 allLazyTop (Floats OkToSpec _) = True
1227 allLazyTop _ = False
1228
1229 allLazyNested :: RecFlag -> Floats -> Bool
1230 allLazyNested _ (Floats OkToSpec _) = True
1231 allLazyNested _ (Floats NotOkToSpec _) = False
1232 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
1233
1234 {-
1235 ************************************************************************
1236 * *
1237 Cloning
1238 * *
1239 ************************************************************************
1240 -}
1241
1242 -- ---------------------------------------------------------------------------
1243 -- The environment
1244 -- ---------------------------------------------------------------------------
1245
1246 -- Note [Inlining in CorePrep]
1247 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1248 -- There is a subtle but important invariant that must be upheld in the output
1249 -- of CorePrep: there are no "trivial" updatable thunks. Thus, this Core
1250 -- is impermissible:
1251 --
1252 -- let x :: ()
1253 -- x = y
1254 --
1255 -- (where y is a reference to a GLOBAL variable). Thunks like this are silly:
1256 -- they can always be profitably replaced by inlining x with y. Consequently,
1257 -- the code generator/runtime does not bother implementing this properly
1258 -- (specifically, there is no implementation of stg_ap_0_upd_info, which is the
1259 -- stack frame that would be used to update this thunk. The "0" means it has
1260 -- zero free variables.)
1261 --
1262 -- In general, the inliner is good at eliminating these let-bindings. However,
1263 -- there is one case where these trivial updatable thunks can arise: when
1264 -- we are optimizing away 'lazy' (see Note [lazyId magic], and also
1265 -- 'cpeRhsE'.) Then, we could have started with:
1266 --
1267 -- let x :: ()
1268 -- x = lazy @ () y
1269 --
1270 -- which is a perfectly fine, non-trivial thunk, but then CorePrep will
1271 -- drop 'lazy', giving us 'x = y' which is trivial and impermissible.
1272 -- The solution is CorePrep to have a miniature inlining pass which deals
1273 -- with cases like this. We can then drop the let-binding altogether.
1274 --
1275 -- Why does the removal of 'lazy' have to occur in CorePrep?
1276 -- The gory details are in Note [lazyId magic] in MkId, but the
1277 -- main reason is that lazy must appear in unfoldings (optimizer
1278 -- output) and it must prevent call-by-value for catch# (which
1279 -- is implemented by CorePrep.)
1280 --
1281 -- An alternate strategy for solving this problem is to have the
1282 -- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
1283 -- We decided not to adopt this solution to keep the definition
1284 -- of 'exprIsTrivial' simple.
1285 --
1286 -- There is ONE caveat however: for top-level bindings we have
1287 -- to preserve the binding so that we float the (hacky) non-recursive
1288 -- binding for data constructors; see Note [Data constructor workers].
1289 --
1290 -- Note [CorePrep inlines trivial CoreExpr not Id]
1291 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1292 -- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
1293 -- IdEnv Id? Naively, we might conjecture that trivial updatable thunks
1294 -- as per Note [Inlining in CorePrep] always have the form
1295 -- 'lazy @ SomeType gbl_id'. But this is not true: the following is
1296 -- perfectly reasonable Core:
1297 --
1298 -- let x :: ()
1299 -- x = lazy @ (forall a. a) y @ Bool
1300 --
1301 -- When we inline 'x' after eliminating 'lazy', we need to replace
1302 -- occurences of 'x' with 'y @ bool', not just 'y'. Situations like
1303 -- this can easily arise with higher-rank types; thus, cpe_env must
1304 -- map to CoreExprs, not Ids.
1305
1306 data CorePrepEnv
1307 = CPE { cpe_dynFlags :: DynFlags
1308 , cpe_env :: IdEnv CoreExpr -- Clone local Ids
1309 -- ^ This environment is used for three operations:
1310 --
1311 -- 1. To support cloning of local Ids so that they are
1312 -- all unique (see item (6) of CorePrep overview).
1313 --
1314 -- 2. To support beta-reduction of runRW, see
1315 -- Note [runRW magic] and Note [runRW arg].
1316 --
1317 -- 3. To let us inline trivial RHSs of non top-level let-bindings,
1318 -- see Note [lazyId magic], Note [Inlining in CorePrep]
1319 -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
1320 , cpe_mkIntegerId :: Id
1321 , cpe_integerSDataCon :: Maybe DataCon
1322 }
1323
1324 lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
1325 lookupMkIntegerName dflags hsc_env
1326 = guardIntegerUse dflags $ liftM tyThingId $
1327 lookupGlobal hsc_env mkIntegerName
1328
1329 lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
1330 lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
1331 IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
1332 lookupGlobal hsc_env integerSDataConName
1333 IntegerSimple -> return Nothing
1334
1335 -- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
1336 guardIntegerUse :: DynFlags -> IO a -> IO a
1337 guardIntegerUse dflags act
1338 | thisPackage dflags == primUnitId
1339 = return $ panic "Can't use Integer in ghc-prim"
1340 | thisPackage dflags == integerUnitId
1341 = return $ panic "Can't use Integer in integer-*"
1342 | otherwise = act
1343
1344 mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
1345 mkInitialCorePrepEnv dflags hsc_env
1346 = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
1347 integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
1348 return $ CPE {
1349 cpe_dynFlags = dflags,
1350 cpe_env = emptyVarEnv,
1351 cpe_mkIntegerId = mkIntegerId,
1352 cpe_integerSDataCon = integerSDataCon
1353 }
1354
1355 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
1356 extendCorePrepEnv cpe id id'
1357 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }
1358
1359 extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
1360 extendCorePrepEnvExpr cpe id expr
1361 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }
1362
1363 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
1364 extendCorePrepEnvList cpe prs
1365 = cpe { cpe_env = extendVarEnvList (cpe_env cpe)
1366 (map (\(id, id') -> (id, Var id')) prs) }
1367
1368 lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
1369 lookupCorePrepEnv cpe id
1370 = case lookupVarEnv (cpe_env cpe) id of
1371 Nothing -> Var id
1372 Just exp -> exp
1373
1374 getMkIntegerId :: CorePrepEnv -> Id
1375 getMkIntegerId = cpe_mkIntegerId
1376
1377 ------------------------------------------------------------------------------
1378 -- Cloning binders
1379 -- ---------------------------------------------------------------------------
1380
1381 cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
1382 cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
1383
1384 cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
1385 cpCloneBndr env bndr
1386 | isLocalId bndr, not (isCoVar bndr)
1387 = do bndr' <- setVarUnique bndr <$> getUniqueM
1388
1389 -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
1390 -- so that we can drop more stuff as dead code.
1391 -- See also Note [Dead code in CorePrep]
1392 let bndr'' = bndr' `setIdUnfolding` noUnfolding
1393 `setIdSpecialisation` emptyRuleInfo
1394 return (extendCorePrepEnv env bndr bndr'', bndr'')
1395
1396 | otherwise -- Top level things, which we don't want
1397 -- to clone, have become GlobalIds by now
1398 -- And we don't clone tyvars, or coercion variables
1399 = return (env, bndr)
1400
1401
1402 ------------------------------------------------------------------------------
1403 -- Cloning ccall Ids; each must have a unique name,
1404 -- to give the code generator a handle to hang it on
1405 -- ---------------------------------------------------------------------------
1406
1407 fiddleCCall :: Id -> UniqSM Id
1408 fiddleCCall id
1409 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
1410 | otherwise = return id
1411
1412 ------------------------------------------------------------------------------
1413 -- Generating new binders
1414 -- ---------------------------------------------------------------------------
1415
1416 newVar :: Type -> UniqSM Id
1417 newVar ty
1418 = seqType ty `seq` do
1419 uniq <- getUniqueM
1420 return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)
1421
1422
1423 ------------------------------------------------------------------------------
1424 -- Floating ticks
1425 -- ---------------------------------------------------------------------------
1426 --
1427 -- Note [Floating Ticks in CorePrep]
1428 --
1429 -- It might seem counter-intuitive to float ticks by default, given
1430 -- that we don't actually want to move them if we can help it. On the
1431 -- other hand, nothing gets very far in CorePrep anyway, and we want
1432 -- to preserve the order of let bindings and tick annotations in
1433 -- relation to each other. For example, if we just wrapped let floats
1434 -- when they pass through ticks, we might end up performing the
1435 -- following transformation:
1436 --
1437 -- src<...> let foo = bar in baz
1438 -- ==> let foo = src<...> bar in src<...> baz
1439 --
1440 -- Because the let-binding would float through the tick, and then
1441 -- immediately materialize, achieving nothing but decreasing tick
1442 -- accuracy. The only special case is the following scenario:
1443 --
1444 -- let foo = src<...> (let a = b in bar) in baz
1445 -- ==> let foo = src<...> bar; a = src<...> b in baz
1446 --
1447 -- Here we would not want the source tick to end up covering "baz" and
1448 -- therefore refrain from pushing ticks outside. Instead, we copy them
1449 -- into the floating binds (here "a") in cpePair. Note that where "b"
1450 -- or "bar" are (value) lambdas we have to push the annotations
1451 -- further inside in order to uphold our rules.
1452 --
1453 -- All of this is implemented below in @wrapTicks@.
1454
1455 -- | Like wrapFloats, but only wraps tick floats
1456 wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
1457 wrapTicks (Floats flag floats0) expr = (Floats flag floats1, expr')
1458 where (floats1, expr') = foldrOL go (nilOL, expr) floats0
1459 go (FloatTick t) (fs, e) = ASSERT(tickishPlace t == PlaceNonLam)
1460 (mapOL (wrap t) fs, mkTick t e)
1461 go other (fs, e) = (other `consOL` fs, e)
1462 wrap t (FloatLet bind) = FloatLet (wrapBind t bind)
1463 wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
1464 wrap _ other = pprPanic "wrapTicks: unexpected float!"
1465 (ppr other)
1466 wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
1467 wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs)