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