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