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