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