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