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