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