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