Get evaluated-ness right in the back end
[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, MultiWayIf #-}
9
10 module CorePrep (
11 corePrepPgm, corePrepExpr, cvtLitInteger,
12 lookupMkIntegerName, lookupIntegerSDataConName
13 ) where
14
15 #include "HsVersions.h"
16
17 import GhcPrelude
18
19 import OccurAnal
20
21 import HscTypes
22 import PrelNames
23 import MkId ( realWorldPrimId )
24 import CoreUtils
25 import CoreArity
26 import CoreFVs
27 import CoreMonad ( CoreToDo(..) )
28 import CoreLint ( endPassIO )
29 import CoreSyn
30 import CoreSubst
31 import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here
32 import Type
33 import Literal
34 import Coercion
35 import TcEnv
36 import TyCon
37 import Demand
38 import Var
39 import VarSet
40 import VarEnv
41 import Id
42 import IdInfo
43 import TysWiredIn
44 import DataCon
45 import PrimOp
46 import BasicTypes
47 import Module
48 import UniqSupply
49 import Maybes
50 import OrdList
51 import ErrUtils
52 import DynFlags
53 import Util
54 import Pair
55 import Outputable
56 import Platform
57 import FastString
58 import Config
59 import Name ( NamedThing(..), nameSrcSpan )
60 import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
61 import Data.Bits
62 import MonadUtils ( mapAccumLM )
63 import Data.List ( mapAccumL )
64 import Control.Monad
65
66 {-
67 -- ---------------------------------------------------------------------------
68 -- Overview
69 -- ---------------------------------------------------------------------------
70
71 The goal of this pass is to prepare for code generation.
72
73 1. Saturate constructor and primop applications.
74
75 2. Convert to A-normal form; that is, function arguments
76 are always variables.
77
78 * Use case for strict arguments:
79 f E ==> case E of x -> f x
80 (where f is strict)
81
82 * Use let for non-trivial lazy arguments
83 f E ==> let x = E in f x
84 (were f is lazy and x is non-trivial)
85
86 3. Similarly, convert any unboxed lets into cases.
87 [I'm experimenting with leaving 'ok-for-speculation'
88 rhss in let-form right up to this point.]
89
90 4. Ensure that *value* lambdas only occur as the RHS of a binding
91 (The code generator can't deal with anything else.)
92 Type lambdas are ok, however, because the code gen discards them.
93
94 5. [Not any more; nuked Jun 2002] Do the seq/par munging.
95
96 6. Clone all local Ids.
97 This means that all such Ids are unique, rather than the
98 weaker guarantee of no clashes which the simplifier provides.
99 And that is what the code generator needs.
100
101 We don't clone TyVars or CoVars. The code gen doesn't need that,
102 and doing so would be tiresome because then we'd need
103 to substitute in types and coercions.
104
105 7. Give each dynamic CCall occurrence a fresh unique; this is
106 rather like the cloning step above.
107
108 8. Inject bindings for the "implicit" Ids:
109 * Constructor wrappers
110 * Constructor workers
111 We want curried definitions for all of these in case they
112 aren't inlined by some caller.
113
114 9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.hs
115 Also replace (noinline e) by e.
116
117 10. Convert (LitInteger i t) into the core representation
118 for the Integer i. Normally this uses mkInteger, but if
119 we are using the integer-gmp implementation then there is a
120 special case where we use the S# constructor for Integers that
121 are in the range of Int.
122
123 11. Uphold tick consistency while doing this: We move ticks out of
124 (non-type) applications where we can, and make sure that we
125 annotate according to scoping rules when floating.
126
127 This is all done modulo type applications and abstractions, so that
128 when type erasure is done for conversion to STG, we don't end up with
129 any trivial or useless bindings.
130
131
132 Note [CorePrep invariants]
133 ~~~~~~~~~~~~~~~~~~~~~~~~~~
134 Here is the syntax of the Core produced by CorePrep:
135
136 Trivial expressions
137 arg ::= lit | var
138 | arg ty | /\a. arg
139 | truv co | /\c. arg | arg |> co
140
141 Applications
142 app ::= lit | var | app arg | app ty | app co | app |> co
143
144 Expressions
145 body ::= app
146 | let(rec) x = rhs in body -- Boxed only
147 | case body of pat -> body
148 | /\a. body | /\c. body
149 | body |> co
150
151 Right hand sides (only place where value lambdas can occur)
152 rhs ::= /\a.rhs | \x.rhs | body
153
154 We define a synonym for each of these non-terminals. Functions
155 with the corresponding name produce a result in that syntax.
156 -}
157
158 type CpeArg = CoreExpr -- Non-terminal 'arg'
159 type CpeApp = CoreExpr -- Non-terminal 'app'
160 type CpeBody = CoreExpr -- Non-terminal 'body'
161 type CpeRhs = CoreExpr -- Non-terminal 'rhs'
162
163 {-
164 ************************************************************************
165 * *
166 Top level stuff
167 * *
168 ************************************************************************
169 -}
170
171 corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
172 -> IO CoreProgram
173 corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
174 withTiming (pure dflags)
175 (text "CorePrep"<+>brackets (ppr this_mod))
176 (const ()) $ do
177 us <- mkSplitUniqSupply 's'
178 initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
179
180 let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
181 -- NB: we must feed mkImplicitBinds through corePrep too
182 -- so that they are suitably cloned and eta-expanded
183
184 binds_out = initUs_ us $ do
185 floats1 <- corePrepTopBinds initialCorePrepEnv binds
186 floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
187 return (deFloatTop (floats1 `appendFloats` floats2))
188
189 endPassIO hsc_env alwaysQualify CorePrep binds_out []
190 return binds_out
191 where
192 dflags = hsc_dflags hsc_env
193
194 corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
195 corePrepExpr dflags hsc_env expr =
196 withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do
197 us <- mkSplitUniqSupply 's'
198 initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
199 let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
200 dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
201 return new_expr
202
203 corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
204 -- Note [Floating out of top level bindings]
205 corePrepTopBinds initialCorePrepEnv binds
206 = go initialCorePrepEnv binds
207 where
208 go _ [] = return emptyFloats
209 go env (bind : binds) = do (env', floats, maybe_new_bind)
210 <- cpeBind TopLevel env bind
211 MASSERT(isNothing maybe_new_bind)
212 -- Only join points get returned this way by
213 -- cpeBind, and no join point may float to top
214 floatss <- go env' binds
215 return (floats `appendFloats` floatss)
216
217 mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
218 -- See Note [Data constructor workers]
219 -- c.f. Note [Injecting implicit bindings] in TidyPgm
220 mkDataConWorkers dflags mod_loc data_tycons
221 = [ NonRec id (tick_it (getName data_con) (Var id))
222 -- The ice is thin here, but it works
223 | tycon <- data_tycons, -- CorePrep will eta-expand it
224 data_con <- tyConDataCons tycon,
225 let id = dataConWorkId data_con
226 ]
227 where
228 -- If we want to generate debug info, we put a source note on the
229 -- worker. This is useful, especially for heap profiling.
230 tick_it name
231 | debugLevel dflags == 0 = id
232 | RealSrcSpan span <- nameSrcSpan name = tick span
233 | Just file <- ml_hs_file mod_loc = tick (span1 file)
234 | otherwise = tick (span1 "???")
235 where tick span = Tick (SourceNote span $ showSDoc dflags (ppr name))
236 span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
237
238 {-
239 Note [Floating out of top level bindings]
240 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
241 NB: we do need to float out of top-level bindings
242 Consider x = length [True,False]
243 We want to get
244 s1 = False : []
245 s2 = True : s1
246 x = length s2
247
248 We return a *list* of bindings, because we may start with
249 x* = f (g y)
250 where x is demanded, in which case we want to finish with
251 a = g y
252 x* = f a
253 And then x will actually end up case-bound
254
255 Note [CafInfo and floating]
256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
257 What happens when we try to float bindings to the top level? At this
258 point all the CafInfo is supposed to be correct, and we must make certain
259 that is true of the new top-level bindings. There are two cases
260 to consider
261
262 a) The top-level binding is marked asCafRefs. In that case we are
263 basically fine. The floated bindings had better all be lazy lets,
264 so they can float to top level, but they'll all have HasCafRefs
265 (the default) which is safe.
266
267 b) The top-level binding is marked NoCafRefs. This really happens
268 Example. CoreTidy produces
269 $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...
270 Now CorePrep has to eta-expand to
271 $fApplicativeSTM = let sat = \xy. retry x y
272 in D:Alternative sat ...blah...
273 So what we *want* is
274 sat [NoCafRefs] = \xy. retry x y
275 $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...
276
277 So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
278 *and* substitute the modified 'sat' into the old RHS.
279
280 It should be the case that 'sat' is itself [NoCafRefs] (a value, no
281 cafs) else the original top-level binding would not itself have been
282 marked [NoCafRefs]. The DEBUG check in CoreToStg for
283 consistentCafInfo will find this.
284
285 This is all very gruesome and horrible. It would be better to figure
286 out CafInfo later, after CorePrep. We'll do that in due course.
287 Meanwhile this horrible hack works.
288
289 Note [Join points and floating]
290 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
291 Join points can float out of other join points but not out of value bindings:
292
293 let z =
294 let w = ... in -- can float
295 join k = ... in -- can't float
296 ... jump k ...
297 join j x1 ... xn =
298 let y = ... in -- can float (but don't want to)
299 join h = ... in -- can float (but not much point)
300 ... jump h ...
301 in ...
302
303 Here, the jump to h remains valid if h is floated outward, but the jump to k
304 does not.
305
306 We don't float *out* of join points. It would only be safe to float out of
307 nullary join points (or ones where the arguments are all either type arguments
308 or dead binders). Nullary join points aren't ever recursive, so they're always
309 effectively one-shot functions, which we don't float out of. We *could* float
310 join points from nullary join points, but there's no clear benefit at this
311 stage.
312
313 Note [Data constructor workers]
314 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
315 Create any necessary "implicit" bindings for data con workers. We
316 create the rather strange (non-recursive!) binding
317
318 $wC = \x y -> $wC x y
319
320 i.e. a curried constructor that allocates. This means that we can
321 treat the worker for a constructor like any other function in the rest
322 of the compiler. The point here is that CoreToStg will generate a
323 StgConApp for the RHS, rather than a call to the worker (which would
324 give a loop). As Lennart says: the ice is thin here, but it works.
325
326 Hmm. Should we create bindings for dictionary constructors? They are
327 always fully applied, and the bindings are just there to support
328 partial applications. But it's easier to let them through.
329
330
331 Note [Dead code in CorePrep]
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
333 Imagine that we got an input program like this (see Trac #4962):
334
335 f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
336 f x = (g True (Just x) + g () (Just x), g)
337 where
338 g :: Show a => a -> Maybe Int -> Int
339 g _ Nothing = x
340 g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
341
342 After specialisation and SpecConstr, we would get something like this:
343
344 f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
345 f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
346 where
347 {-# RULES g $dBool = g$Bool
348 g $dUnit = g$Unit #-}
349 g = ...
350 {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
351 g$Bool = ...
352 {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
353 g$Unit = ...
354 g$Bool_True_Just = ...
355 g$Unit_Unit_Just = ...
356
357 Note that the g$Bool and g$Unit functions are actually dead code: they
358 are only kept alive by the occurrence analyser because they are
359 referred to by the rules of g, which is being kept alive by the fact
360 that it is used (unspecialised) in the returned pair.
361
362 However, at the CorePrep stage there is no way that the rules for g
363 will ever fire, and it really seems like a shame to produce an output
364 program that goes to the trouble of allocating a closure for the
365 unreachable g$Bool and g$Unit functions.
366
367 The way we fix this is to:
368 * In cloneBndr, drop all unfoldings/rules
369
370 * In deFloatTop, run a simple dead code analyser on each top-level
371 RHS to drop the dead local bindings. For that call to OccAnal, we
372 disable the binder swap, else the occurrence analyser sometimes
373 introduces new let bindings for cased binders, which lead to the bug
374 in #5433.
375
376 The reason we don't just OccAnal the whole output of CorePrep is that
377 the tidier ensures that all top-level binders are GlobalIds, so they
378 don't show up in the free variables any longer. So if you run the
379 occurrence analyser on the output of CoreTidy (or later) you e.g. turn
380 this program:
381
382 Rec {
383 f = ... f ...
384 }
385
386 Into this one:
387
388 f = ... f ...
389
390 (Since f is not considered to be free in its own RHS.)
391
392
393 ************************************************************************
394 * *
395 The main code
396 * *
397 ************************************************************************
398 -}
399
400 cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
401 -> UniqSM (CorePrepEnv,
402 Floats, -- Floating value bindings
403 Maybe CoreBind) -- Just bind' <=> returned new bind; no float
404 -- Nothing <=> added bind' to floats instead
405 cpeBind top_lvl env (NonRec bndr rhs)
406 | not (isJoinId bndr)
407 = do { (_, bndr1) <- cpCloneBndr env bndr
408 ; let dmd = idDemandInfo bndr
409 is_unlifted = isUnliftedType (idType bndr)
410 ; (floats, rhs1) <- cpePair top_lvl NonRecursive
411 dmd is_unlifted
412 env bndr1 rhs
413 -- See Note [Inlining in CorePrep]
414 ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl
415 then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)
416 else do {
417
418 ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1
419
420 ; return (extendCorePrepEnv env bndr bndr1,
421 addFloat floats new_float,
422 Nothing) }}
423
424 | otherwise -- A join point; see Note [Join points and floating]
425 = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point
426 do { (_, bndr1) <- cpCloneBndr env bndr
427 ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
428 ; return (extendCorePrepEnv env bndr bndr2,
429 emptyFloats,
430 Just (NonRec bndr2 rhs1)) }
431
432 cpeBind top_lvl env (Rec pairs)
433 | not (isJoinId (head bndrs))
434 = do { (env', bndrs1) <- cpCloneBndrs env bndrs
435 ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
436 bndrs1 rhss
437
438 ; let (floats_s, rhss1) = unzip stuff
439 all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)
440 (concatFloats floats_s)
441
442 ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
443 unitFloat (FloatLet (Rec all_pairs)),
444 Nothing) }
445
446 | otherwise -- See Note [Join points and floating]
447 = do { (env', bndrs1) <- cpCloneBndrs env bndrs
448 ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
449
450 ; let bndrs2 = map fst pairs1
451 ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),
452 emptyFloats,
453 Just (Rec pairs1)) }
454 where
455 (bndrs, rhss) = unzip pairs
456
457 -- Flatten all the floats, and the current
458 -- group into a single giant Rec
459 add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
460 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
461 add_float b _ = pprPanic "cpeBind" (ppr b)
462
463 ---------------
464 cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
465 -> CorePrepEnv -> OutId -> CoreExpr
466 -> UniqSM (Floats, CpeRhs)
467 -- Used for all bindings
468 -- The binder is already cloned, hence an OutId
469 cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
470 = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair
471 do { (floats1, rhs1) <- cpeRhsE env rhs
472
473 -- See if we are allowed to float this stuff out of the RHS
474 ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
475
476 -- Make the arity match up
477 ; (floats3, rhs3)
478 <- if manifestArity rhs1 <= arity
479 then return (floats2, cpeEtaExpand arity rhs2)
480 else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
481 -- Note [Silly extra arguments]
482 (do { v <- newVar (idType bndr)
483 ; let float = mkFloat topDmd False v rhs2
484 ; return ( addFloat floats2 float
485 , cpeEtaExpand arity (Var v)) })
486
487 -- Wrap floating ticks
488 ; let (floats4, rhs4) = wrapTicks floats3 rhs3
489
490 ; return (floats4, rhs4) }
491 where
492 platform = targetPlatform (cpe_dynFlags env)
493
494 arity = idArity bndr -- We must match this arity
495
496 ---------------------
497 float_from_rhs floats rhs
498 | isEmptyFloats floats = return (emptyFloats, rhs)
499 | isTopLevel top_lvl = float_top floats rhs
500 | otherwise = float_nested floats rhs
501
502 ---------------------
503 float_nested floats rhs
504 | wantFloatNested is_rec dmd is_unlifted floats rhs
505 = return (floats, rhs)
506 | otherwise = dontFloat floats rhs
507
508 ---------------------
509 float_top floats rhs -- Urhgh! See Note [CafInfo and floating]
510 | mayHaveCafRefs (idCafInfo bndr)
511 , allLazyTop floats
512 = return (floats, rhs)
513
514 -- So the top-level binding is marked NoCafRefs
515 | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs
516 = return (floats', rhs')
517
518 | otherwise
519 = dontFloat floats rhs
520
521 dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
522 -- Non-empty floats, but do not want to float from rhs
523 -- So wrap the rhs in the floats
524 -- But: rhs1 might have lambdas, and we can't
525 -- put them inside a wrapBinds
526 dontFloat floats1 rhs
527 = do { (floats2, body) <- rhsToBody rhs
528 ; return (emptyFloats, wrapBinds floats1 $
529 wrapBinds floats2 body) }
530
531 {- Note [Silly extra arguments]
532 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
533 Suppose we had this
534 f{arity=1} = \x\y. e
535 We *must* match the arity on the Id, so we have to generate
536 f' = \x\y. e
537 f = \x. f' x
538
539 It's a bizarre case: why is the arity on the Id wrong? Reason
540 (in the days of __inline_me__):
541 f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
542 When InlineMe notes go away this won't happen any more. But
543 it seems good for CorePrep to be robust.
544 -}
545
546 ---------------
547 cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
548 -> UniqSM (JoinId, CpeRhs)
549 -- Used for all join bindings
550 cpeJoinPair env bndr rhs
551 = ASSERT(isJoinId bndr)
552 do { let Just join_arity = isJoinId_maybe bndr
553 (bndrs, body) = collectNBinders join_arity rhs
554
555 ; (env', bndrs') <- cpCloneBndrs env bndrs
556
557 ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts
558 -- with a lambda
559
560 ; let rhs' = mkCoreLams bndrs' body'
561 bndr' = bndr `setIdUnfolding` evaldUnfolding
562 `setIdArity` count isId bndrs
563 -- See Note [Arity and join points]
564
565 ; return (bndr', rhs') }
566
567 {-
568 Note [Arity and join points]
569 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
570 Up to now, we've allowed a join point to have an arity greater than its join
571 arity (minus type arguments), since this is what's useful for eta expansion.
572 However, for code gen purposes, its arity must be exactly the number of value
573 arguments it will be called with, and it must have exactly that many value
574 lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:
575
576 join j x y z = \w -> ... in ...
577 =>
578 join j x y z = (let f = \w -> ... in f) in ...
579
580 This is also what happens with Note [Silly extra arguments]. Note that it's okay
581 for us to mess with the arity because a join point is never exported.
582 -}
583
584 -- ---------------------------------------------------------------------------
585 -- CpeRhs: produces a result satisfying CpeRhs
586 -- ---------------------------------------------------------------------------
587
588 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
589 -- If
590 -- e ===> (bs, e')
591 -- then
592 -- e = let bs in e' (semantically, that is!)
593 --
594 -- For example
595 -- f (g x) ===> ([v = g x], f v)
596
597 cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
598 cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
599 cpeRhsE env (Lit (LitInteger i _))
600 = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
601 (cpe_integerSDataCon env) i)
602 cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
603 cpeRhsE env expr@(Var {}) = cpeApp env expr
604 cpeRhsE env expr@(App {}) = cpeApp env expr
605
606 cpeRhsE env (Let bind body)
607 = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind
608 ; (body_floats, body') <- cpeRhsE env' body
609 ; let expr' = case maybe_bind' of Just bind' -> Let bind' body'
610 Nothing -> body'
611 ; return (bind_floats `appendFloats` body_floats, expr') }
612
613 cpeRhsE env (Tick tickish expr)
614 | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope
615 = do { (floats, body) <- cpeRhsE env expr
616 -- See [Floating Ticks in CorePrep]
617 ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }
618 | otherwise
619 = do { body <- cpeBodyNF env expr
620 ; return (emptyFloats, mkTick tickish' body) }
621 where
622 tickish' | Breakpoint n fvs <- tickish
623 -- See also 'substTickish'
624 = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
625 | otherwise
626 = tickish
627
628 cpeRhsE env (Cast expr co)
629 = do { (floats, expr') <- cpeRhsE env expr
630 ; return (floats, Cast expr' co) }
631
632 cpeRhsE env expr@(Lam {})
633 = do { let (bndrs,body) = collectBinders expr
634 ; (env', bndrs') <- cpCloneBndrs env bndrs
635 ; body' <- cpeBodyNF env' body
636 ; return (emptyFloats, mkLams bndrs' body') }
637
638 cpeRhsE env (Case scrut bndr ty alts)
639 = do { (floats, scrut') <- cpeBody env scrut
640 ; (env', bndr2) <- cpCloneBndr env bndr
641 ; let alts'
642 -- This flag is intended to aid in debugging strictness
643 -- analysis bugs. These are particularly nasty to chase down as
644 -- they may manifest as segmentation faults. When this flag is
645 -- enabled we instead produce an 'error' expression to catch
646 -- the case where a function we think should bottom
647 -- unexpectedly returns.
648 | gopt Opt_CatchBottoms (cpe_dynFlags env)
649 , not (altsAreExhaustive alts)
650 = addDefault alts (Just err)
651 | otherwise = alts
652 where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty
653 "Bottoming expression returned"
654 ; alts'' <- mapM (sat_alt env') alts'
655 ; return (floats, Case scrut' bndr2 ty alts'') }
656 where
657 sat_alt env (con, bs, rhs)
658 = do { (env2, bs') <- cpCloneBndrs env bs
659 ; rhs' <- cpeBodyNF env2 rhs
660 ; return (con, bs', rhs') }
661
662 cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
663 -- Here we convert a literal Integer to the low-level
664 -- representation. Exactly how we do this depends on the
665 -- library that implements Integer. If it's GMP we
666 -- use the S# data constructor for small literals.
667 -- See Note [Integer literals] in Literal
668 cvtLitInteger dflags _ (Just sdatacon) i
669 | inIntRange dflags i -- Special case for small integers
670 = mkConApp sdatacon [Lit (mkMachInt dflags i)]
671
672 cvtLitInteger dflags mk_integer _ i
673 = mkApps (Var mk_integer) [isNonNegative, ints]
674 where isNonNegative = if i < 0 then mkConApp falseDataCon []
675 else mkConApp trueDataCon []
676 ints = mkListExpr intTy (f (abs i))
677 f 0 = []
678 f x = let low = x .&. mask
679 high = x `shiftR` bits
680 in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high
681 bits = 31
682 mask = 2 ^ bits - 1
683
684 -- ---------------------------------------------------------------------------
685 -- CpeBody: produces a result satisfying CpeBody
686 -- ---------------------------------------------------------------------------
687
688 -- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without
689 -- producing any floats (any generated floats are immediately
690 -- let-bound using 'wrapBinds'). Generally you want this, esp.
691 -- when you've reached a binding form (e.g., a lambda) and
692 -- floating any further would be incorrect.
693 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
694 cpeBodyNF env expr
695 = do { (floats, body) <- cpeBody env expr
696 ; return (wrapBinds floats body) }
697
698 -- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce
699 -- a list of 'Floats' which are being propagated upwards. In
700 -- fact, this function is used in only two cases: to
701 -- implement 'cpeBodyNF' (which is what you usually want),
702 -- and in the case when a let-binding is in a case scrutinee--here,
703 -- we can always float out:
704 --
705 -- case (let x = y in z) of ...
706 -- ==> let x = y in case z of ...
707 --
708 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
709 cpeBody env expr
710 = do { (floats1, rhs) <- cpeRhsE env expr
711 ; (floats2, body) <- rhsToBody rhs
712 ; return (floats1 `appendFloats` floats2, body) }
713
714 --------
715 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
716 -- Remove top level lambdas by let-binding
717
718 rhsToBody (Tick t expr)
719 | tickishScoped t == NoScope -- only float out of non-scoped annotations
720 = do { (floats, expr') <- rhsToBody expr
721 ; return (floats, mkTick t expr') }
722
723 rhsToBody (Cast e co)
724 -- You can get things like
725 -- case e of { p -> coerce t (\s -> ...) }
726 = do { (floats, e') <- rhsToBody e
727 ; return (floats, Cast e' co) }
728
729 rhsToBody expr@(Lam {})
730 | Just no_lam_result <- tryEtaReducePrep bndrs body
731 = return (emptyFloats, no_lam_result)
732 | all isTyVar bndrs -- Type lambdas are ok
733 = return (emptyFloats, expr)
734 | otherwise -- Some value lambdas
735 = do { fn <- newVar (exprType expr)
736 ; let rhs = cpeEtaExpand (exprArity expr) expr
737 float = FloatLet (NonRec fn rhs)
738 ; return (unitFloat float, Var fn) }
739 where
740 (bndrs,body) = collectBinders expr
741
742 rhsToBody expr = return (emptyFloats, expr)
743
744
745
746 -- ---------------------------------------------------------------------------
747 -- CpeApp: produces a result satisfying CpeApp
748 -- ---------------------------------------------------------------------------
749
750 data ArgInfo = CpeApp CoreArg
751 | CpeCast Coercion
752 | CpeTick (Tickish Id)
753
754 {- Note [runRW arg]
755 ~~~~~~~~~~~~~~~~~~~
756 If we got, say
757 runRW# (case bot of {})
758 which happened in Trac #11291, we do /not/ want to turn it into
759 (case bot of {}) realWorldPrimId#
760 because that gives a panic in CoreToStg.myCollectArgs, which expects
761 only variables in function position. But if we are sure to make
762 runRW# strict (which we do in MkId), this can't happen
763 -}
764
765 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
766 -- May return a CpeRhs because of saturating primops
767 cpeApp top_env expr
768 = do { let (terminal, args, depth) = collect_args expr
769 ; cpe_app top_env terminal args depth
770 }
771
772 where
773 -- We have a nested data structure of the form
774 -- e `App` a1 `App` a2 ... `App` an, convert it into
775 -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)
776 -- We use 'ArgInfo' because we may also need to
777 -- record casts and ticks. Depth counts the number
778 -- of arguments that would consume strictness information
779 -- (so, no type or coercion arguments.)
780 collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)
781 collect_args e = go e [] 0
782 where
783 go (App fun arg) as !depth
784 = go fun (CpeApp arg : as)
785 (if isTyCoArg arg then depth else depth + 1)
786 go (Cast fun co) as depth
787 = go fun (CpeCast co : as) depth
788 go (Tick tickish fun) as depth
789 | tickishPlace tickish == PlaceNonLam
790 && tickish `tickishScopesLike` SoftScope
791 = go fun (CpeTick tickish : as) depth
792 go terminal as depth = (terminal, as, depth)
793
794 cpe_app :: CorePrepEnv
795 -> CoreExpr
796 -> [ArgInfo]
797 -> Int
798 -> UniqSM (Floats, CpeRhs)
799 cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth
800 | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and
801 || f `hasKey` noinlineIdKey -- Replace (noinline a) with a
802 -- Consider the code:
803 --
804 -- lazy (f x) y
805 --
806 -- We need to make sure that we need to recursively collect arguments on
807 -- "f x", otherwise we'll float "f x" out (it's not a variable) and
808 -- end up with this awful -ddump-prep:
809 --
810 -- case f x of f_x {
811 -- __DEFAULT -> f_x y
812 -- }
813 --
814 -- rather than the far superior "f x y". Test case is par01.
815 = let (terminal, args', depth') = collect_args arg
816 in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
817 cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1
818 | f `hasKey` runRWKey
819 -- See Note [runRW magic]
820 -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
821 -- is why we return a CorePrepEnv as well)
822 = case arg of
823 Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0
824 _ -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1
825 cpe_app env (Var v) args depth
826 = do { v1 <- fiddleCCall v
827 ; let e2 = lookupCorePrepEnv env v1
828 hd = getIdFromTrivialExpr_maybe e2
829 -- NB: depth from collect_args is right, because e2 is a trivial expression
830 -- and thus its embedded Id *must* be at the same depth as any
831 -- Apps it is under are type applications only (c.f.
832 -- exprIsTrivial). But note that we need the type of the
833 -- expression, not the id.
834 ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts
835 ; mb_saturate hd app floats depth }
836 where
837 stricts = case idStrictness v of
838 StrictSig (DmdType _ demands _)
839 | listLengthCmp demands depth /= GT -> demands
840 -- length demands <= depth
841 | otherwise -> []
842 -- If depth < length demands, then we have too few args to
843 -- satisfy strictness info so we have to ignore all the
844 -- strictness info, e.g. + (error "urk")
845 -- Here, we can't evaluate the arg strictly, because this
846 -- partial application might be seq'd
847
848 -- We inlined into something that's not a var and has no args.
849 -- Bounce it back up to cpeRhsE.
850 cpe_app env fun [] _ = cpeRhsE env fun
851
852 -- N-variable fun, better let-bind it
853 cpe_app env fun args depth
854 = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
855 -- The evalDmd says that it's sure to be evaluated,
856 -- so we'll end up case-binding it
857 ; (app, floats) <- rebuild_app args fun' ty fun_floats []
858 ; mb_saturate Nothing app floats depth }
859 where
860 ty = exprType fun
861
862 -- Saturate if necessary
863 mb_saturate head app floats depth =
864 case head of
865 Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth
866 ; return (floats, sat_app) }
867 _other -> return (floats, app)
868
869 -- Deconstruct and rebuild the application, floating any non-atomic
870 -- arguments to the outside. We collect the type of the expression,
871 -- the head of the application, and the number of actual value arguments,
872 -- all of which are used to possibly saturate this application if it
873 -- has a constructor or primop at the head.
874 rebuild_app
875 :: [ArgInfo] -- The arguments (inner to outer)
876 -> CpeApp
877 -> Type
878 -> Floats
879 -> [Demand]
880 -> UniqSM (CpeApp, Floats)
881 rebuild_app [] app _ floats ss = do
882 MASSERT(null ss) -- make sure we used all the strictness info
883 return (app, floats)
884 rebuild_app (a : as) fun' fun_ty floats ss = case a of
885 CpeApp arg@(Type arg_ty) ->
886 rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss
887 CpeApp arg@(Coercion {}) ->
888 rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss
889 CpeApp arg -> do
890 let (ss1, ss_rest) -- See Note [lazyId magic] in MkId
891 = case (ss, isLazyExpr arg) of
892 (_ : ss_rest, True) -> (topDmd, ss_rest)
893 (ss1 : ss_rest, False) -> (ss1, ss_rest)
894 ([], _) -> (topDmd, [])
895 (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
896 splitFunTy_maybe fun_ty
897 (fs, arg') <- cpeArg top_env ss1 arg arg_ty
898 rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest
899 CpeCast co ->
900 let Pair _ty1 ty2 = coercionKind co
901 in rebuild_app as (Cast fun' co) ty2 floats ss
902 CpeTick tickish ->
903 -- See [Floating Ticks in CorePrep]
904 rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss
905
906 isLazyExpr :: CoreExpr -> Bool
907 -- See Note [lazyId magic] in MkId
908 isLazyExpr (Cast e _) = isLazyExpr e
909 isLazyExpr (Tick _ e) = isLazyExpr e
910 isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey
911 isLazyExpr _ = False
912
913 {- Note [runRW magic]
914 ~~~~~~~~~~~~~~~~~~~~~
915 Some definitions, for instance @runST@, must have careful control over float out
916 of the bindings in their body. Consider this use of @runST@,
917
918 f x = runST ( \ s -> let (a, s') = newArray# 100 [] s
919 (_, s'') = fill_in_array_or_something a x s'
920 in freezeArray# a s'' )
921
922 If we inline @runST@, we'll get:
923
924 f x = let (a, s') = newArray# 100 [] realWorld#{-NB-}
925 (_, s'') = fill_in_array_or_something a x s'
926 in freezeArray# a s''
927
928 And now if we allow the @newArray#@ binding to float out to become a CAF,
929 we end up with a result that is totally and utterly wrong:
930
931 f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
932 in \ x ->
933 let (_, s'') = fill_in_array_or_something a x s'
934 in freezeArray# a s''
935
936 All calls to @f@ will share a {\em single} array! Clearly this is nonsense and
937 must be prevented.
938
939 This is what @runRW#@ gives us: by being inlined extremely late in the
940 optimization (right before lowering to STG, in CorePrep), we can ensure that
941 no further floating will occur. This allows us to safely inline things like
942 @runST@, which are otherwise needlessly expensive (see #10678 and #5916).
943
944 'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE
945 pragma. It is levity-polymorphic.
946
947 runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
948 => (State# RealWorld -> (# State# RealWorld, o #))
949 -> (# State# RealWorld, o #)
950
951 It needs no special treatment in GHC except this special inlining here
952 in CorePrep (and in ByteCodeGen).
953
954 -- ---------------------------------------------------------------------------
955 -- CpeArg: produces a result satisfying CpeArg
956 -- ---------------------------------------------------------------------------
957
958 Note [ANF-ising literal string arguments]
959 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
960
961 Consider a program like,
962
963 data Foo = Foo Addr#
964
965 foo = Foo "turtle"#
966
967 When we go to ANFise this we might think that we want to float the string
968 literal like we do any other non-trivial argument. This would look like,
969
970 foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }
971
972 However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)
973 wreaks havoc on the CAF annotations that we produce here since we the result
974 above is caffy since it is updateable. Ideally at some point in the future we
975 would like to just float the literal to the top level as suggested in #11312,
976
977 s = "turtle"#
978 foo = Foo s
979
980 However, until then we simply add a special case excluding literals from the
981 floating done by cpeArg.
982 -}
983
984 -- | Is an argument okay to CPE?
985 okCpeArg :: CoreExpr -> Bool
986 -- Don't float literals. See Note [ANF-ising literal string arguments].
987 okCpeArg (Lit _) = False
988 -- Do not eta expand a trivial argument
989 okCpeArg expr = not (exprIsTrivial expr)
990
991 -- This is where we arrange that a non-trivial argument is let-bound
992 cpeArg :: CorePrepEnv -> Demand
993 -> CoreArg -> Type -> UniqSM (Floats, CpeArg)
994 cpeArg env dmd arg arg_ty
995 = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
996 ; (floats2, arg2) <- if want_float floats1 arg1
997 then return (floats1, arg1)
998 else dontFloat floats1 arg1
999 -- Else case: arg1 might have lambdas, and we can't
1000 -- put them inside a wrapBinds
1001
1002 ; if okCpeArg arg2
1003 then do { v <- newVar arg_ty
1004 ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
1005 arg_float = mkFloat dmd is_unlifted v arg3
1006 ; return (addFloat floats2 arg_float, varToCoreExpr v) }
1007 else return (floats2, arg2)
1008 }
1009 where
1010 is_unlifted = isUnliftedType arg_ty
1011 want_float = wantFloatNested NonRecursive dmd is_unlifted
1012
1013 {-
1014 Note [Floating unlifted arguments]
1015 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1016 Consider C (let v* = expensive in v)
1017
1018 where the "*" indicates "will be demanded". Usually v will have been
1019 inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
1020 do *not* want to get
1021
1022 let v* = expensive in C v
1023
1024 because that has different strictness. Hence the use of 'allLazy'.
1025 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
1026
1027
1028 ------------------------------------------------------------------------------
1029 -- Building the saturated syntax
1030 -- ---------------------------------------------------------------------------
1031
1032 maybeSaturate deals with saturating primops and constructors
1033 The type is the type of the entire application
1034 -}
1035
1036 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
1037 maybeSaturate fn expr n_args
1038 | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg
1039 -- A gruesome special case
1040 = saturateDataToTag sat_expr
1041
1042 | hasNoBinding fn -- There's no binding
1043 = return sat_expr
1044
1045 | otherwise
1046 = return expr
1047 where
1048 fn_arity = idArity fn
1049 excess_arity = fn_arity - n_args
1050 sat_expr = cpeEtaExpand excess_arity expr
1051
1052 -------------
1053 saturateDataToTag :: CpeApp -> UniqSM CpeApp
1054 -- See Note [dataToTag magic]
1055 saturateDataToTag sat_expr
1056 = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
1057 ; eta_body' <- eval_data2tag_arg eta_body
1058 ; return (mkLams eta_bndrs eta_body') }
1059 where
1060 eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
1061 eval_data2tag_arg app@(fun `App` arg)
1062 | exprIsHNF arg -- Includes nullary constructors
1063 = return app -- The arg is evaluated
1064 | otherwise -- Arg not evaluated, so evaluate it
1065 = do { arg_id <- newVar (exprType arg)
1066 ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
1067 ; return (Case arg arg_id1 (exprType app)
1068 [(DEFAULT, [], fun `App` Var arg_id1)]) }
1069
1070 eval_data2tag_arg (Tick t app) -- Scc notes can appear
1071 = do { app' <- eval_data2tag_arg app
1072 ; return (Tick t app') }
1073
1074 eval_data2tag_arg other -- Should not happen
1075 = pprPanic "eval_data2tag" (ppr other)
1076
1077 {- Note [dataToTag magic]
1078 ~~~~~~~~~~~~~~~~~~~~~~~~~
1079 We must ensure that the arg of data2TagOp is evaluated. So
1080 in general CorePrep does this transformation:
1081 data2tag e --> case e of y -> data2tag y
1082 (yuk yuk) take into account the lambdas we've now introduced
1083
1084 How might it not be evaluated? Well, we might have floated it out
1085 of the scope of a `seq`, or dropped the `seq` altogether.
1086
1087 We only do this if 'e' is not a WHNF. But if it's a simple
1088 variable (common case) we need to know it's evaluated-ness flag.
1089 Example:
1090 data T = MkT !Bool
1091 f v = case v of
1092 MkT y -> dataToTag# y
1093 Here we don't want to generate an extra case on 'y', because it's
1094 already evaluated. So we want to keep the evaluated-ness flag
1095 on y. See Note [Preserve evaluated-ness in CorePrep].
1096
1097
1098 ************************************************************************
1099 * *
1100 Simple CoreSyn operations
1101 * *
1102 ************************************************************************
1103 -}
1104
1105 {-
1106 -- -----------------------------------------------------------------------------
1107 -- Eta reduction
1108 -- -----------------------------------------------------------------------------
1109
1110 Note [Eta expansion]
1111 ~~~~~~~~~~~~~~~~~~~~~
1112 Eta expand to match the arity claimed by the binder Remember,
1113 CorePrep must not change arity
1114
1115 Eta expansion might not have happened already, because it is done by
1116 the simplifier only when there at least one lambda already.
1117
1118 NB1:we could refrain when the RHS is trivial (which can happen
1119 for exported things). This would reduce the amount of code
1120 generated (a little) and make things a little words for
1121 code compiled without -O. The case in point is data constructor
1122 wrappers.
1123
1124 NB2: we have to be careful that the result of etaExpand doesn't
1125 invalidate any of the assumptions that CorePrep is attempting
1126 to establish. One possible cause is eta expanding inside of
1127 an SCC note - we're now careful in etaExpand to make sure the
1128 SCC is pushed inside any new lambdas that are generated.
1129
1130 Note [Eta expansion and the CorePrep invariants]
1131 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1132 It turns out to be much much easier to do eta expansion
1133 *after* the main CorePrep stuff. But that places constraints
1134 on the eta expander: given a CpeRhs, it must return a CpeRhs.
1135
1136 For example here is what we do not want:
1137 f = /\a -> g (h 3) -- h has arity 2
1138 After ANFing we get
1139 f = /\a -> let s = h 3 in g s
1140 and now we do NOT want eta expansion to give
1141 f = /\a -> \ y -> (let s = h 3 in g s) y
1142
1143 Instead CoreArity.etaExpand gives
1144 f = /\a -> \y -> let s = h 3 in g s y
1145 -}
1146
1147 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
1148 cpeEtaExpand arity expr
1149 | arity == 0 = expr
1150 | otherwise = etaExpand arity expr
1151
1152 {-
1153 -- -----------------------------------------------------------------------------
1154 -- Eta reduction
1155 -- -----------------------------------------------------------------------------
1156
1157 Why try eta reduction? Hasn't the simplifier already done eta?
1158 But the simplifier only eta reduces if that leaves something
1159 trivial (like f, or f Int). But for deLam it would be enough to
1160 get to a partial application:
1161 case x of { p -> \xs. map f xs }
1162 ==> case x of { p -> map f }
1163 -}
1164
1165 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
1166 tryEtaReducePrep bndrs expr@(App _ _)
1167 | ok_to_eta_reduce f
1168 , n_remaining >= 0
1169 , and (zipWith ok bndrs last_args)
1170 , not (any (`elemVarSet` fvs_remaining) bndrs)
1171 , exprIsHNF remaining_expr -- Don't turn value into a non-value
1172 -- else the behaviour with 'seq' changes
1173 = Just remaining_expr
1174 where
1175 (f, args) = collectArgs expr
1176 remaining_expr = mkApps f remaining_args
1177 fvs_remaining = exprFreeVars remaining_expr
1178 (remaining_args, last_args) = splitAt n_remaining args
1179 n_remaining = length args - length bndrs
1180
1181 ok bndr (Var arg) = bndr == arg
1182 ok _ _ = False
1183
1184 -- We can't eta reduce something which must be saturated.
1185 ok_to_eta_reduce (Var f) = not (hasNoBinding f)
1186 ok_to_eta_reduce _ = False -- Safe. ToDo: generalise
1187
1188 tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
1189 | not (any (`elemVarSet` fvs) bndrs)
1190 = case tryEtaReducePrep bndrs body of
1191 Just e -> Just (Let bind e)
1192 Nothing -> Nothing
1193 where
1194 fvs = exprFreeVars r
1195
1196 -- NB: do not attempt to eta-reduce across ticks
1197 -- Otherwise we risk reducing
1198 -- \x. (Tick (Breakpoint {x}) f x)
1199 -- ==> Tick (breakpoint {x}) f
1200 -- which is bogus (Trac #17228)
1201 -- tryEtaReducePrep bndrs (Tick tickish e)
1202 -- = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
1203
1204 tryEtaReducePrep _ _ = Nothing
1205
1206 {-
1207 ************************************************************************
1208 * *
1209 Floats
1210 * *
1211 ************************************************************************
1212
1213 Note [Pin demand info on floats]
1214 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1215 We pin demand info on floated lets, so that we can see the one-shot thunks.
1216 -}
1217
1218 data FloatingBind
1219 = FloatLet CoreBind -- Rhs of bindings are CpeRhss
1220 -- They are always of lifted type;
1221 -- unlifted ones are done with FloatCase
1222
1223 | FloatCase
1224 Id CpeBody
1225 Bool -- The bool indicates "ok-for-speculation"
1226
1227 -- | See Note [Floating Ticks in CorePrep]
1228 | FloatTick (Tickish Id)
1229
1230 data Floats = Floats OkToSpec (OrdList FloatingBind)
1231
1232 instance Outputable FloatingBind where
1233 ppr (FloatLet b) = ppr b
1234 ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
1235 ppr (FloatTick t) = ppr t
1236
1237 instance Outputable Floats where
1238 ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>
1239 braces (vcat (map ppr (fromOL fs)))
1240
1241 instance Outputable OkToSpec where
1242 ppr OkToSpec = text "OkToSpec"
1243 ppr IfUnboxedOk = text "IfUnboxedOk"
1244 ppr NotOkToSpec = text "NotOkToSpec"
1245
1246 -- Can we float these binds out of the rhs of a let? We cache this decision
1247 -- to avoid having to recompute it in a non-linear way when there are
1248 -- deeply nested lets.
1249 data OkToSpec
1250 = OkToSpec -- Lazy bindings of lifted type
1251 | IfUnboxedOk -- A mixture of lazy lifted bindings and n
1252 -- ok-to-speculate unlifted bindings
1253 | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
1254
1255 mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
1256 mkFloat dmd is_unlifted bndr rhs
1257 | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
1258 | is_hnf = FloatLet (NonRec bndr rhs)
1259 | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
1260 -- See Note [Pin demand info on floats]
1261 where
1262 is_hnf = exprIsHNF rhs
1263 is_strict = isStrictDmd dmd
1264 use_case = is_unlifted || is_strict && not is_hnf
1265 -- Don't make a case for a value binding,
1266 -- even if it's strict. Otherwise we get
1267 -- case (\x -> e) of ...!
1268
1269 emptyFloats :: Floats
1270 emptyFloats = Floats OkToSpec nilOL
1271
1272 isEmptyFloats :: Floats -> Bool
1273 isEmptyFloats (Floats _ bs) = isNilOL bs
1274
1275 wrapBinds :: Floats -> CpeBody -> CpeBody
1276 wrapBinds (Floats _ binds) body
1277 = foldrOL mk_bind body binds
1278 where
1279 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
1280 mk_bind (FloatLet bind) body = Let bind body
1281 mk_bind (FloatTick tickish) body = mkTick tickish body
1282
1283 addFloat :: Floats -> FloatingBind -> Floats
1284 addFloat (Floats ok_to_spec floats) new_float
1285 = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
1286 where
1287 check (FloatLet _) = OkToSpec
1288 check (FloatCase _ _ ok_for_spec)
1289 | ok_for_spec = IfUnboxedOk
1290 | otherwise = NotOkToSpec
1291 check FloatTick{} = OkToSpec
1292 -- The ok-for-speculation flag says that it's safe to
1293 -- float this Case out of a let, and thereby do it more eagerly
1294 -- We need the top-level flag because it's never ok to float
1295 -- an unboxed binding to the top level
1296
1297 unitFloat :: FloatingBind -> Floats
1298 unitFloat = addFloat emptyFloats
1299
1300 appendFloats :: Floats -> Floats -> Floats
1301 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
1302 = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
1303
1304 concatFloats :: [Floats] -> OrdList FloatingBind
1305 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
1306
1307 combine :: OkToSpec -> OkToSpec -> OkToSpec
1308 combine NotOkToSpec _ = NotOkToSpec
1309 combine _ NotOkToSpec = NotOkToSpec
1310 combine IfUnboxedOk _ = IfUnboxedOk
1311 combine _ IfUnboxedOk = IfUnboxedOk
1312 combine _ _ = OkToSpec
1313
1314 deFloatTop :: Floats -> [CoreBind]
1315 -- For top level only; we don't expect any FloatCases
1316 deFloatTop (Floats _ floats)
1317 = foldrOL get [] floats
1318 where
1319 get (FloatLet b) bs = occurAnalyseRHSs b : bs
1320 get (FloatCase var body _) bs =
1321 occurAnalyseRHSs (NonRec var body) : bs
1322 get b _ = pprPanic "corePrepPgm" (ppr b)
1323
1324 -- See Note [Dead code in CorePrep]
1325 occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
1326 occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]
1327
1328 ---------------------------------------------------------------------------
1329
1330 canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
1331 -- Note [CafInfo and floating]
1332 canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
1333 | OkToSpec <- ok_to_spec -- Worth trying
1334 , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
1335 = Just (Floats OkToSpec fs', subst_expr subst rhs)
1336 | otherwise
1337 = Nothing
1338 where
1339 subst_expr = substExpr (text "CorePrep")
1340
1341 go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
1342 -> Maybe (Subst, OrdList FloatingBind)
1343
1344 go (subst, fbs_out) [] = Just (subst, fbs_out)
1345
1346 go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
1347 | rhs_ok r
1348 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1349 where
1350 (subst', b') = set_nocaf_bndr subst b
1351 new_fb = FloatLet (NonRec b' (subst_expr subst r))
1352
1353 go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
1354 | all rhs_ok rs
1355 = go (subst', fbs_out `snocOL` new_fb) fbs_in
1356 where
1357 (bs,rs) = unzip prs
1358 (subst', bs') = mapAccumL set_nocaf_bndr subst bs
1359 rs' = map (subst_expr subst') rs
1360 new_fb = FloatLet (Rec (bs' `zip` rs'))
1361
1362 go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
1363 = go (subst, fbs_out `snocOL` ft) fbs_in
1364
1365 go _ _ = Nothing -- Encountered a caffy binding
1366
1367 ------------
1368 set_nocaf_bndr subst bndr
1369 = (extendIdSubst subst bndr (Var bndr'), bndr')
1370 where
1371 bndr' = bndr `setIdCafInfo` NoCafRefs
1372
1373 ------------
1374 rhs_ok :: CoreExpr -> Bool
1375 -- We can only float to top level from a NoCaf thing if
1376 -- the new binding is static. However it can't mention
1377 -- any non-static things or it would *already* be Caffy
1378 rhs_ok = rhsIsStatic platform (\_ -> False)
1379 (\i -> pprPanic "rhsIsStatic" (integer i))
1380 -- Integer literals should not show up
1381
1382 wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
1383 wantFloatNested is_rec dmd is_unlifted floats rhs
1384 = isEmptyFloats floats
1385 || isStrictDmd dmd
1386 || is_unlifted
1387 || (allLazyNested is_rec floats && exprIsHNF rhs)
1388 -- Why the test for allLazyNested?
1389 -- v = f (x `divInt#` y)
1390 -- we don't want to float the case, even if f has arity 2,
1391 -- because floating the case would make it evaluated too early
1392
1393 allLazyTop :: Floats -> Bool
1394 allLazyTop (Floats OkToSpec _) = True
1395 allLazyTop _ = False
1396
1397 allLazyNested :: RecFlag -> Floats -> Bool
1398 allLazyNested _ (Floats OkToSpec _) = True
1399 allLazyNested _ (Floats NotOkToSpec _) = False
1400 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
1401
1402 {-
1403 ************************************************************************
1404 * *
1405 Cloning
1406 * *
1407 ************************************************************************
1408 -}
1409
1410 -- ---------------------------------------------------------------------------
1411 -- The environment
1412 -- ---------------------------------------------------------------------------
1413
1414 -- Note [Inlining in CorePrep]
1415 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1416 -- There is a subtle but important invariant that must be upheld in the output
1417 -- of CorePrep: there are no "trivial" updatable thunks. Thus, this Core
1418 -- is impermissible:
1419 --
1420 -- let x :: ()
1421 -- x = y
1422 --
1423 -- (where y is a reference to a GLOBAL variable). Thunks like this are silly:
1424 -- they can always be profitably replaced by inlining x with y. Consequently,
1425 -- the code generator/runtime does not bother implementing this properly
1426 -- (specifically, there is no implementation of stg_ap_0_upd_info, which is the
1427 -- stack frame that would be used to update this thunk. The "0" means it has
1428 -- zero free variables.)
1429 --
1430 -- In general, the inliner is good at eliminating these let-bindings. However,
1431 -- there is one case where these trivial updatable thunks can arise: when
1432 -- we are optimizing away 'lazy' (see Note [lazyId magic], and also
1433 -- 'cpeRhsE'.) Then, we could have started with:
1434 --
1435 -- let x :: ()
1436 -- x = lazy @ () y
1437 --
1438 -- which is a perfectly fine, non-trivial thunk, but then CorePrep will
1439 -- drop 'lazy', giving us 'x = y' which is trivial and impermissible.
1440 -- The solution is CorePrep to have a miniature inlining pass which deals
1441 -- with cases like this. We can then drop the let-binding altogether.
1442 --
1443 -- Why does the removal of 'lazy' have to occur in CorePrep?
1444 -- The gory details are in Note [lazyId magic] in MkId, but the
1445 -- main reason is that lazy must appear in unfoldings (optimizer
1446 -- output) and it must prevent call-by-value for catch# (which
1447 -- is implemented by CorePrep.)
1448 --
1449 -- An alternate strategy for solving this problem is to have the
1450 -- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
1451 -- We decided not to adopt this solution to keep the definition
1452 -- of 'exprIsTrivial' simple.
1453 --
1454 -- There is ONE caveat however: for top-level bindings we have
1455 -- to preserve the binding so that we float the (hacky) non-recursive
1456 -- binding for data constructors; see Note [Data constructor workers].
1457 --
1458 -- Note [CorePrep inlines trivial CoreExpr not Id]
1459 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1460 -- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
1461 -- IdEnv Id? Naively, we might conjecture that trivial updatable thunks
1462 -- as per Note [Inlining in CorePrep] always have the form
1463 -- 'lazy @ SomeType gbl_id'. But this is not true: the following is
1464 -- perfectly reasonable Core:
1465 --
1466 -- let x :: ()
1467 -- x = lazy @ (forall a. a) y @ Bool
1468 --
1469 -- When we inline 'x' after eliminating 'lazy', we need to replace
1470 -- occurrences of 'x' with 'y @ bool', not just 'y'. Situations like
1471 -- this can easily arise with higher-rank types; thus, cpe_env must
1472 -- map to CoreExprs, not Ids.
1473
1474 data CorePrepEnv
1475 = CPE { cpe_dynFlags :: DynFlags
1476 , cpe_env :: IdEnv CoreExpr -- Clone local Ids
1477 -- ^ This environment is used for three operations:
1478 --
1479 -- 1. To support cloning of local Ids so that they are
1480 -- all unique (see item (6) of CorePrep overview).
1481 --
1482 -- 2. To support beta-reduction of runRW, see
1483 -- Note [runRW magic] and Note [runRW arg].
1484 --
1485 -- 3. To let us inline trivial RHSs of non top-level let-bindings,
1486 -- see Note [lazyId magic], Note [Inlining in CorePrep]
1487 -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
1488 , cpe_mkIntegerId :: Id
1489 , cpe_integerSDataCon :: Maybe DataCon
1490 }
1491
1492 lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
1493 lookupMkIntegerName dflags hsc_env
1494 = guardIntegerUse dflags $ liftM tyThingId $
1495 lookupGlobal hsc_env mkIntegerName
1496
1497 lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
1498 lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
1499 IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
1500 lookupGlobal hsc_env integerSDataConName
1501 IntegerSimple -> return Nothing
1502
1503 -- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
1504 guardIntegerUse :: DynFlags -> IO a -> IO a
1505 guardIntegerUse dflags act
1506 | thisPackage dflags == primUnitId
1507 = return $ panic "Can't use Integer in ghc-prim"
1508 | thisPackage dflags == integerUnitId
1509 = return $ panic "Can't use Integer in integer-*"
1510 | otherwise = act
1511
1512 mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
1513 mkInitialCorePrepEnv dflags hsc_env
1514 = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
1515 integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
1516 return $ CPE {
1517 cpe_dynFlags = dflags,
1518 cpe_env = emptyVarEnv,
1519 cpe_mkIntegerId = mkIntegerId,
1520 cpe_integerSDataCon = integerSDataCon
1521 }
1522
1523 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
1524 extendCorePrepEnv cpe id id'
1525 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }
1526
1527 extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
1528 extendCorePrepEnvExpr cpe id expr
1529 = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }
1530
1531 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
1532 extendCorePrepEnvList cpe prs
1533 = cpe { cpe_env = extendVarEnvList (cpe_env cpe)
1534 (map (\(id, id') -> (id, Var id')) prs) }
1535
1536 lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
1537 lookupCorePrepEnv cpe id
1538 = case lookupVarEnv (cpe_env cpe) id of
1539 Nothing -> Var id
1540 Just exp -> exp
1541
1542 getMkIntegerId :: CorePrepEnv -> Id
1543 getMkIntegerId = cpe_mkIntegerId
1544
1545 ------------------------------------------------------------------------------
1546 -- Cloning binders
1547 -- ---------------------------------------------------------------------------
1548
1549 cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
1550 cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
1551
1552 cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
1553 cpCloneBndr env bndr
1554 | not (isId bndr)
1555 = return (env, bndr)
1556
1557 | otherwise
1558 = do { bndr' <- clone_it bndr
1559
1560 -- Drop (now-useless) rules/unfoldings
1561 -- See Note [Drop unfoldings and rules]
1562 -- and Note [Preserve evaluated-ness in CorePrep]
1563 ; let unfolding' = zapUnfolding (realIdUnfolding bndr)
1564 -- Simplifier will set the Id's unfolding
1565
1566 bndr'' = bndr' `setIdUnfolding` unfolding'
1567 `setIdSpecialisation` emptyRuleInfo
1568
1569 ; return (extendCorePrepEnv env bndr bndr'', bndr'') }
1570 where
1571 clone_it bndr
1572 | isLocalId bndr, not (isCoVar bndr)
1573 = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }
1574 | otherwise -- Top level things, which we don't want
1575 -- to clone, have become GlobalIds by now
1576 -- And we don't clone tyvars, or coercion variables
1577 = return bndr
1578
1579 {- Note [Drop unfoldings and rules]
1580 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1581 We want to drop the unfolding/rules on every Id:
1582
1583 - We are now past interface-file generation, and in the
1584 codegen pipeline, so we really don't need full unfoldings/rules
1585
1586 - The unfolding/rule may be keeping stuff alive that we'd like
1587 to discard. See Note [Dead code in CorePrep]
1588
1589 - Getting rid of unnecessary unfoldings reduces heap usage
1590
1591 - We are changing uniques, so if we didn't discard unfoldings/rules
1592 we'd have to substitute in them
1593
1594 HOWEVER, we want to preserve evaluated-ness; see
1595 Note [Preserve evaluated-ness in CorePrep]
1596
1597 Note [Preserve evaluated-ness in CorePrep]
1598 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1599 We want to preserve the evaluated-ness of each binder (via
1600 evaldUnfolding) for two reasons
1601
1602 * In the code generator if we have
1603 case x of y { Red -> e1; DEFAULT -> y }
1604 we can return 'y' rather than entering it, if we know
1605 it is evaluated (Trac #14626)
1606
1607 * In the DataToTag magic (in CorePrep itself) we rely on
1608 evaluated-ness. See Note Note [dataToTag magic].
1609 -}
1610
1611 ------------------------------------------------------------------------------
1612 -- Cloning ccall Ids; each must have a unique name,
1613 -- to give the code generator a handle to hang it on
1614 -- ---------------------------------------------------------------------------
1615
1616 fiddleCCall :: Id -> UniqSM Id
1617 fiddleCCall id
1618 | isFCallId id = (id `setVarUnique`) <$> getUniqueM
1619 | otherwise = return id
1620
1621 ------------------------------------------------------------------------------
1622 -- Generating new binders
1623 -- ---------------------------------------------------------------------------
1624
1625 newVar :: Type -> UniqSM Id
1626 newVar ty
1627 = seqType ty `seq` do
1628 uniq <- getUniqueM
1629 return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)
1630
1631
1632 ------------------------------------------------------------------------------
1633 -- Floating ticks
1634 -- ---------------------------------------------------------------------------
1635 --
1636 -- Note [Floating Ticks in CorePrep]
1637 --
1638 -- It might seem counter-intuitive to float ticks by default, given
1639 -- that we don't actually want to move them if we can help it. On the
1640 -- other hand, nothing gets very far in CorePrep anyway, and we want
1641 -- to preserve the order of let bindings and tick annotations in
1642 -- relation to each other. For example, if we just wrapped let floats
1643 -- when they pass through ticks, we might end up performing the
1644 -- following transformation:
1645 --
1646 -- src<...> let foo = bar in baz
1647 -- ==> let foo = src<...> bar in src<...> baz
1648 --
1649 -- Because the let-binding would float through the tick, and then
1650 -- immediately materialize, achieving nothing but decreasing tick
1651 -- accuracy. The only special case is the following scenario:
1652 --
1653 -- let foo = src<...> (let a = b in bar) in baz
1654 -- ==> let foo = src<...> bar; a = src<...> b in baz
1655 --
1656 -- Here we would not want the source tick to end up covering "baz" and
1657 -- therefore refrain from pushing ticks outside. Instead, we copy them
1658 -- into the floating binds (here "a") in cpePair. Note that where "b"
1659 -- or "bar" are (value) lambdas we have to push the annotations
1660 -- further inside in order to uphold our rules.
1661 --
1662 -- All of this is implemented below in @wrapTicks@.
1663
1664 -- | Like wrapFloats, but only wraps tick floats
1665 wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
1666 wrapTicks (Floats flag floats0) expr =
1667 (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))
1668 where (floats1, ticks1) = foldlOL go ([], []) $ floats0
1669 -- Deeply nested constructors will produce long lists of
1670 -- redundant source note floats here. We need to eliminate
1671 -- those early, as relying on mkTick to spot it after the fact
1672 -- can yield O(n^3) complexity [#11095]
1673 go (floats, ticks) (FloatTick t)
1674 = ASSERT(tickishPlace t == PlaceNonLam)
1675 (floats, if any (flip tickishContains t) ticks
1676 then ticks else t:ticks)
1677 go (floats, ticks) f
1678 = (foldr wrap f (reverse ticks):floats, ticks)
1679
1680 wrap t (FloatLet bind) = FloatLet (wrapBind t bind)
1681 wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
1682 wrap _ other = pprPanic "wrapTicks: unexpected float!"
1683 (ppr other)
1684 wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
1685 wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs)