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