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