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