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