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