1{- 2(c) The AQUA Project, Glasgow University, 1993-1998 3 4\section[Simplify]{The main module of the simplifier} 5-} 6 7{-# LANGUAGE CPP #-} 8 9{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 10module Simplify ( simplTopBinds, simplExpr, simplRules ) where 11 12#include "HsVersions.h" 13 14import GhcPrelude 15 16import DynFlags 17import SimplMonad 18import Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) 19import SimplEnv 20import SimplUtils 21import OccurAnal ( occurAnalyseExpr ) 22import FamInstEnv ( FamInstEnv ) 23import Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 24import Id 25import MkId ( seqId ) 26import MkCore ( FloatBind, mkImpossibleExpr, castBottomExpr ) 27import qualified MkCore as MkCore 28import IdInfo 29import Name ( mkSystemVarName, isExternalName, getOccFS ) 30import Coercion hiding ( substCo, substCoVar ) 31import OptCoercion ( optCoercion ) 32import FamInstEnv ( topNormaliseType_maybe ) 33import DataCon ( DataCon, dataConWorkId, dataConRepStrictness 34 , dataConRepArgTys, isUnboxedTupleCon 35 , StrictnessMark (..) ) 36import CoreMonad ( Tick(..), SimplMode(..) ) 37import CoreSyn 38import Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrictDmd ) 39import PprCore ( pprCoreExpr ) 40import CoreUnfold 41import CoreUtils 42import CoreOpt ( pushCoTyArg, pushCoValArg 43 , joinPointBinding_maybe, joinPointBindings_maybe ) 44import Rules ( mkRuleInfo, lookupRule, getRules ) 45import Demand ( mkClosedStrictSig, topDmd, seqDmd, botRes ) 46import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, 47 RecFlag(..), Arity ) 48import MonadUtils ( mapAccumLM, liftIO ) 49import Var ( isTyCoVar ) 50import Maybes ( orElse ) 51import Control.Monad 52import Outputable 53import FastString 54import Pair 55import Util 56import ErrUtils 57import Module ( moduleName, pprModuleName ) 58import PrimOp ( PrimOp (SeqOp) ) 59 60 61{- 62The guts of the simplifier is in this module, but the driver loop for 63the simplifier is in SimplCore.hs. 64 65Note [The big picture] 66~~~~~~~~~~~~~~~~~~~~~~ 67The general shape of the simplifier is this: 68 69 simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) 70 simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) 71 72 * SimplEnv contains 73 - Simplifier mode (which includes DynFlags for convenience) 74 - Ambient substitution 75 - InScopeSet 76 77 * SimplFloats contains 78 - Let-floats (which includes ok-for-spec case-floats) 79 - Join floats 80 - InScopeSet (including all the floats) 81 82 * Expressions 83 simplExpr :: SimplEnv -> InExpr -> SimplCont 84 -> SimplM (SimplFloats, OutExpr) 85 The result of simplifying an /expression/ is (floats, expr) 86 - A bunch of floats (let bindings, join bindings) 87 - A simplified expression. 88 The overall result is effectively (let floats in expr) 89 90 * Bindings 91 simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) 92 The result of simplifying a binding is 93 - A bunch of floats, the last of which is the simplified binding 94 There may be auxiliary bindings too; see prepareRhs 95 - An environment suitable for simplifying the scope of the binding 96 97 The floats may also be empty, if the binding is inlined unconditionally; 98 in that case the returned SimplEnv will have an augmented substitution. 99 100 The returned floats and env both have an in-scope set, and they are 101 guaranteed to be the same. 102 103 104Note [Shadowing] 105~~~~~~~~~~~~~~~~ 106The simplifier used to guarantee that the output had no shadowing, but 107it does not do so any more. (Actually, it never did!) The reason is 108documented with simplifyArgs. 109 110 111Eta expansion 112~~~~~~~~~~~~~~ 113For eta expansion, we want to catch things like 114 115 case e of (a,b) -> \x -> case a of (p,q) -> \y -> r 116 117If the \x was on the RHS of a let, we'd eta expand to bring the two 118lambdas together. And in general that's a good thing to do. Perhaps 119we should eta expand wherever we find a (value) lambda? Then the eta 120expansion at a let RHS can concentrate solely on the PAP case. 121 122Note [In-scope set as a substitution] 123~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 124As per Note [Lookups in in-scope set], an in-scope set can act as 125a substitution. Specifically, it acts as a substitution from variable to 126variables /with the same unique/. 127 128Why do we need this? Well, during the course of the simplifier, we may want to 129adjust inessential properties of a variable. For instance, when performing a 130beta-reduction, we change 131 132 (\x. e) u ==> let x = u in e 133 134We typically want to add an unfolding to `x` so that it inlines to (the 135simplification of) `u`. 136 137We do that by adding the unfolding to the binder `x`, which is added to the 138in-scope set. When simplifying occurrences of `x` (every occurrence!), they are 139replaced by their “updated” version from the in-scope set, hence inherit the 140unfolding. This happens in `SimplEnv.substId`. 141 142Another example. Consider 143 144 case x of y { Node a b -> ...y... 145 ; Leaf v -> ...y... } 146 147In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we 148want y's unfolding to be (Leaf v). We achieve this by adding the appropriate 149unfolding to y, and re-adding it to the in-scope set. See the calls to 150`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. 151 152It's quite convenient. This way we don't need to manipulate the substitution all 153the time: every update to a binder is automatically reflected to its bound 154occurrences. 155 156************************************************************************ 157* * 158\subsection{Bindings} 159* * 160************************************************************************ 161-} 162 163simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) 164-- See Note [The big picture] 165simplTopBinds env0 binds0 166 = do { -- Put all the top-level binders into scope at the start 167 -- so that if a transformation rule has unexpectedly brought 168 -- anything into scope, then we don't get a complaint about that. 169 -- It's rather as if the top-level binders were imported. 170 -- See note [Glomming] in OccurAnal. 171 ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) 172 ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 173 ; freeTick SimplifierDone 174 ; return (floats, env2) } 175 where 176 -- We need to track the zapped top-level binders, because 177 -- they should have their fragile IdInfo zapped (notably occurrence info) 178 -- That's why we run down binds and bndrs' simultaneously. 179 -- 180 simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) 181 simpl_binds env [] = return (emptyFloats env, env) 182 simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind 183 ; (floats, env2) <- simpl_binds env1 binds 184 ; return (float `addFloats` floats, env2) } 185 186 simpl_bind env (Rec pairs) 187 = simplRecBind env TopLevel Nothing pairs 188 simpl_bind env (NonRec b r) 189 = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing 190 ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r } 191 192{- 193************************************************************************ 194* * 195 Lazy bindings 196* * 197************************************************************************ 198 199simplRecBind is used for 200 * recursive bindings only 201-} 202 203simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont 204 -> [(InId, InExpr)] 205 -> SimplM (SimplFloats, SimplEnv) 206simplRecBind env0 top_lvl mb_cont pairs0 207 = do { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0 208 ; (rec_floats, env1) <- go env_with_info triples 209 ; return (mkRecFloats rec_floats, env1) } 210 where 211 add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) 212 -- Add the (substituted) rules to the binder 213 add_rules env (bndr, rhs) 214 = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont 215 ; return (env', (bndr, bndr', rhs)) } 216 217 go env [] = return (emptyFloats env, env) 218 219 go env ((old_bndr, new_bndr, rhs) : pairs) 220 = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont 221 old_bndr new_bndr rhs 222 ; (floats, env2) <- go env1 pairs 223 ; return (float `addFloats` floats, env2) } 224 225{- 226simplOrTopPair is used for 227 * recursive bindings (whether top level or not) 228 * top-level non-recursive bindings 229 230It assumes the binder has already been simplified, but not its IdInfo. 231-} 232 233simplRecOrTopPair :: SimplEnv 234 -> TopLevelFlag -> RecFlag -> MaybeJoinCont 235 -> InId -> OutBndr -> InExpr -- Binder and rhs 236 -> SimplM (SimplFloats, SimplEnv) 237 238simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs 239 | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env 240 = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} 241 trace_bind "pre-inline-uncond" $ 242 do { tick (PreInlineUnconditionally old_bndr) 243 ; return ( emptyFloats env, env' ) } 244 245 | Just cont <- mb_cont 246 = {-#SCC "simplRecOrTopPair-join" #-} 247 ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr ) 248 trace_bind "join" $ 249 simplJoinBind env cont old_bndr new_bndr rhs env 250 251 | otherwise 252 = {-#SCC "simplRecOrTopPair-normal" #-} 253 trace_bind "normal" $ 254 simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env 255 256 where 257 dflags = seDynFlags env 258 259 -- trace_bind emits a trace for each top-level binding, which 260 -- helps to locate the tracing for inlining and rule firing 261 trace_bind what thing_inside 262 | not (dopt Opt_D_verbose_core2core dflags) 263 = thing_inside 264 | otherwise 265 = pprTrace ("SimplBind " ++ what) (ppr old_bndr) thing_inside 266 267-------------------------- 268simplLazyBind :: SimplEnv 269 -> TopLevelFlag -> RecFlag 270 -> InId -> OutId -- Binder, both pre-and post simpl 271 -- Not a JoinId 272 -- The OutId has IdInfo, except arity, unfolding 273 -- Ids only, no TyVars 274 -> InExpr -> SimplEnv -- The RHS and its environment 275 -> SimplM (SimplFloats, SimplEnv) 276-- Precondition: not a JoinId 277-- Precondition: rhs obeys the let/app invariant 278-- NOT used for JoinIds 279simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se 280 = ASSERT( isId bndr ) 281 ASSERT2( not (isJoinId bndr), ppr bndr ) 282 -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ 283 do { let rhs_env = rhs_se `setInScopeFromE` env 284 (tvs, body) = case collectTyAndValBinders rhs of 285 (tvs, [], body) 286 | surely_not_lam body -> (tvs, body) 287 _ -> ([], rhs) 288 289 surely_not_lam (Lam {}) = False 290 surely_not_lam (Tick t e) 291 | not (tickishFloatable t) = surely_not_lam e 292 -- eta-reduction could float 293 surely_not_lam _ = True 294 -- Do not do the "abstract tyvar" thing if there's 295 -- a lambda inside, because it defeats eta-reduction 296 -- f = /\a. \x. g a x 297 -- should eta-reduce. 298 299 300 ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs 301 -- See Note [Floating and type abstraction] in SimplUtils 302 303 -- Simplify the RHS 304 ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) 305 ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont 306 307 -- Never float join-floats out of a non-join let-binding 308 -- So wrap the body in the join-floats right now 309 -- Hence: body_floats1 consists only of let-floats 310 ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0 311 312 -- ANF-ise a constructor or PAP rhs 313 -- We get at most one float per argument here 314 ; (let_floats, body2) <- {-#SCC "prepareRhs" #-} prepareRhs (getMode env) top_lvl 315 (getOccFS bndr1) (idInfo bndr1) body1 316 ; let body_floats2 = body_floats1 `addLetFloats` let_floats 317 318 ; (rhs_floats, rhs') 319 <- if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2) 320 then -- No floating, revert to body1 321 {-#SCC "simplLazyBind-no-floating" #-} 322 do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont 323 ; return (emptyFloats env, rhs') } 324 325 else if null tvs then -- Simple floating 326 {-#SCC "simplLazyBind-simple-floating" #-} 327 do { tick LetFloatFromLet 328 ; return (body_floats2, body2) } 329 330 else -- Do type-abstraction first 331 {-#SCC "simplLazyBind-type-abstraction-first" #-} 332 do { tick LetFloatFromLet 333 ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl 334 tvs' body_floats2 body2 335 ; let floats = foldl' extendFloats (emptyFloats env) poly_binds 336 ; rhs' <- mkLam env tvs' body3 rhs_cont 337 ; return (floats, rhs') } 338 339 ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) 340 top_lvl Nothing bndr bndr1 rhs' 341 ; return (rhs_floats `addFloats` bind_float, env2) } 342 343-------------------------- 344simplJoinBind :: SimplEnv 345 -> SimplCont 346 -> InId -> OutId -- Binder, both pre-and post simpl 347 -- The OutId has IdInfo, except arity, 348 -- unfolding 349 -> InExpr -> SimplEnv -- The right hand side and its env 350 -> SimplM (SimplFloats, SimplEnv) 351simplJoinBind env cont old_bndr new_bndr rhs rhs_se 352 = do { let rhs_env = rhs_se `setInScopeFromE` env 353 ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont 354 ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' } 355 356-------------------------- 357simplNonRecX :: SimplEnv 358 -> InId -- Old binder; not a JoinId 359 -> OutExpr -- Simplified RHS 360 -> SimplM (SimplFloats, SimplEnv) 361-- A specialised variant of simplNonRec used when the RHS is already 362-- simplified, notably in knownCon. It uses case-binding where necessary. 363-- 364-- Precondition: rhs satisfies the let/app invariant 365 366simplNonRecX env bndr new_rhs 367 | ASSERT2( not (isJoinId bndr), ppr bndr ) 368 isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } 369 = return (emptyFloats env, env) -- Here c is dead, and we avoid 370 -- creating the binding c = (a,b) 371 372 | Coercion co <- new_rhs 373 = return (emptyFloats env, extendCvSubst env bndr co) 374 375 | otherwise 376 = do { (env', bndr') <- simplBinder env bndr 377 ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } 378 -- simplNonRecX is only used for NotTopLevel things 379 380-------------------------- 381completeNonRecX :: TopLevelFlag -> SimplEnv 382 -> Bool 383 -> InId -- Old binder; not a JoinId 384 -> OutId -- New binder 385 -> OutExpr -- Simplified RHS 386 -> SimplM (SimplFloats, SimplEnv) -- The new binding is in the floats 387-- Precondition: rhs satisfies the let/app invariant 388-- See Note [CoreSyn let/app invariant] in CoreSyn 389 390completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs 391 = ASSERT2( not (isJoinId new_bndr), ppr new_bndr ) 392 do { (prepd_floats, rhs1) <- prepareRhs (getMode env) top_lvl (getOccFS new_bndr) 393 (idInfo new_bndr) new_rhs 394 ; let floats = emptyFloats env `addLetFloats` prepd_floats 395 ; (rhs_floats, rhs2) <- 396 if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1 397 then -- Add the floats to the main env 398 do { tick LetFloatFromLet 399 ; return (floats, rhs1) } 400 else -- Do not float; wrap the floats around the RHS 401 return (emptyFloats env, wrapFloats floats rhs1) 402 403 ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) 404 NotTopLevel Nothing 405 old_bndr new_bndr rhs2 406 ; return (rhs_floats `addFloats` bind_float, env2) } 407 408 409{- ********************************************************************* 410* * 411 prepareRhs, makeTrivial 412* * 413************************************************************************ 414 415Note [prepareRhs] 416~~~~~~~~~~~~~~~~~ 417prepareRhs takes a putative RHS, checks whether it's a PAP or 418constructor application and, if so, converts it to ANF, so that the 419resulting thing can be inlined more easily. Thus 420 x = (f a, g b) 421becomes 422 t1 = f a 423 t2 = g b 424 x = (t1,t2) 425 426We also want to deal well cases like this 427 v = (f e1 `cast` co) e2 428Here we want to make e1,e2 trivial and get 429 x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 430That's what the 'go' loop in prepareRhs does 431-} 432 433prepareRhs :: SimplMode -> TopLevelFlag 434 -> FastString -- Base for any new variables 435 -> IdInfo -- IdInfo for the LHS of this binding 436 -> OutExpr 437 -> SimplM (LetFloats, OutExpr) 438-- Transforms a RHS into a better RHS by adding floats 439-- e.g x = Just e 440-- becomes a = e 441-- x = Just a 442-- See Note [prepareRhs] 443prepareRhs mode top_lvl occ info (Cast rhs co) -- Note [Float coercions] 444 | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type 445 , not (isUnliftedType ty1) -- see Note [Float coercions (unlifted)] 446 = do { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs 447 ; return (floats, Cast rhs' co) } 448 where 449 sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info 450 `setDemandInfo` demandInfo info 451 452prepareRhs mode top_lvl occ _ rhs0 453 = do { (_is_exp, floats, rhs1) <- go 0 rhs0 454 ; return (floats, rhs1) } 455 where 456 go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr) 457 go n_val_args (Cast rhs co) 458 = do { (is_exp, floats, rhs') <- go n_val_args rhs 459 ; return (is_exp, floats, Cast rhs' co) } 460 go n_val_args (App fun (Type ty)) 461 = do { (is_exp, floats, rhs') <- go n_val_args fun 462 ; return (is_exp, floats, App rhs' (Type ty)) } 463 go n_val_args (App fun arg) 464 = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun 465 ; case is_exp of 466 False -> return (False, emptyLetFloats, App fun arg) 467 True -> do { (floats2, arg') <- makeTrivial mode top_lvl topDmd occ arg 468 ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } } 469 go n_val_args (Var fun) 470 = return (is_exp, emptyLetFloats, Var fun) 471 where 472 is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP 473 -- See Note [CONLIKE pragma] in BasicTypes 474 -- The definition of is_exp should match that in 475 -- OccurAnal.occAnalApp 476 477 go n_val_args (Tick t rhs) 478 -- We want to be able to float bindings past this 479 -- tick. Non-scoping ticks don't care. 480 | tickishScoped t == NoScope 481 = do { (is_exp, floats, rhs') <- go n_val_args rhs 482 ; return (is_exp, floats, Tick t rhs') } 483 484 -- On the other hand, for scoping ticks we need to be able to 485 -- copy them on the floats, which in turn is only allowed if 486 -- we can obtain non-counting ticks. 487 | (not (tickishCounts t) || tickishCanSplit t) 488 = do { (is_exp, floats, rhs') <- go n_val_args rhs 489 ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) 490 floats' = mapLetFloats floats tickIt 491 ; return (is_exp, floats', Tick t rhs') } 492 493 go _ other 494 = return (False, emptyLetFloats, other) 495 496{- 497Note [Float coercions] 498~~~~~~~~~~~~~~~~~~~~~~ 499When we find the binding 500 x = e `cast` co 501we'd like to transform it to 502 x' = e 503 x = x `cast` co -- A trivial binding 504There's a chance that e will be a constructor application or function, or something 505like that, so moving the coercion to the usage site may well cancel the coercions 506and lead to further optimisation. Example: 507 508 data family T a :: * 509 data instance T Int = T Int 510 511 foo :: Int -> Int -> Int 512 foo m n = ... 513 where 514 x = T m 515 go 0 = 0 516 go n = case x of { T m -> go (n-m) } 517 -- This case should optimise 518 519Note [Preserve strictness when floating coercions] 520~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 521In the Note [Float coercions] transformation, keep the strictness info. 522Eg 523 f = e `cast` co -- f has strictness SSL 524When we transform to 525 f' = e -- f' also has strictness SSL 526 f = f' `cast` co -- f still has strictness SSL 527 528Its not wrong to drop it on the floor, but better to keep it. 529 530Note [Float coercions (unlifted)] 531~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 532BUT don't do [Float coercions] if 'e' has an unlifted type. 533This *can* happen: 534 535 foo :: Int = (error (# Int,Int #) "urk") 536 `cast` CoUnsafe (# Int,Int #) Int 537 538If do the makeTrivial thing to the error call, we'll get 539 foo = case error (# Int,Int #) "urk" of v -> v `cast` ... 540But 'v' isn't in scope! 541 542These strange casts can happen as a result of case-of-case 543 bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of 544 (# p,q #) -> p+q 545-} 546 547makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec) 548makeTrivialArg mode arg@(ValArg { as_arg = e, as_dmd = dmd }) 549 = do { (floats, e') <- makeTrivial mode NotTopLevel dmd (fsLit "arg") e 550 ; return (floats, arg { as_arg = e' }) } 551makeTrivialArg _ arg 552 = return (emptyLetFloats, arg) -- CastBy, TyArg 553 554makeTrivial :: SimplMode -> TopLevelFlag -> Demand 555 -> FastString -- ^ A "friendly name" to build the new binder from 556 -> OutExpr -- ^ This expression satisfies the let/app invariant 557 -> SimplM (LetFloats, OutExpr) 558-- Binds the expression to a variable, if it's not trivial, returning the variable 559-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] 560makeTrivial mode top_lvl dmd occ_fs expr 561 = makeTrivialWithInfo mode top_lvl occ_fs (vanillaIdInfo `setDemandInfo` dmd) expr 562 563makeTrivialWithInfo :: SimplMode -> TopLevelFlag 564 -> FastString -- ^ a "friendly name" to build the new binder from 565 -> IdInfo 566 -> OutExpr -- ^ This expression satisfies the let/app invariant 567 -> SimplM (LetFloats, OutExpr) 568-- Propagate strictness and demand info to the new binder 569-- Note [Preserve strictness when floating coercions] 570-- Returned SimplEnv has same substitution as incoming one 571makeTrivialWithInfo mode top_lvl occ_fs info expr 572 | exprIsTrivial expr -- Already trivial 573 || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise 574 -- See Note [Cannot trivialise] 575 = return (emptyLetFloats, expr) 576 577 | otherwise 578 = do { (floats, expr1) <- prepareRhs mode top_lvl occ_fs info expr 579 ; if exprIsTrivial expr1 -- See Note [Trivial after prepareRhs] 580 then return (floats, expr1) 581 else do 582 { uniq <- getUniqueM 583 ; let name = mkSystemVarName uniq occ_fs 584 var = mkLocalIdOrCoVarWithInfo name expr_ty info 585 586 -- Now something very like completeBind, 587 -- but without the postInlineUnconditinoally part 588 ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1 589 ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2 590 591 ; let final_id = addLetBndrInfo var arity is_bot unf 592 bind = NonRec final_id expr2 593 594 ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }} 595 where 596 expr_ty = exprType expr 597 598bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool 599-- True iff we can have a binding of this expression at this level 600-- Precondition: the type is the type of the expression 601bindingOk top_lvl expr expr_ty 602 | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty 603 | otherwise = True 604 605{- Note [Trivial after prepareRhs] 606~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 607If we call makeTrival on (e |> co), the recursive use of prepareRhs 608may leave us with 609 { a1 = e } and (a1 |> co) 610Now the latter is trivial, so we don't want to let-bind it. 611 612Note [Cannot trivialise] 613~~~~~~~~~~~~~~~~~~~~~~~~ 614Consider: 615 f :: Int -> Addr# 616 617 foo :: Bar 618 foo = Bar (f 3) 619 620Then we can't ANF-ise foo, even though we'd like to, because 621we can't make a top-level binding for the Addr# (f 3). And if 622so we don't want to turn it into 623 foo = let x = f 3 in Bar x 624because we'll just end up inlining x back, and that makes the 625simplifier loop. Better not to ANF-ise it at all. 626 627Literal strings are an exception. 628 629 foo = Ptr "blob"# 630 631We want to turn this into: 632 633 foo1 = "blob"# 634 foo = Ptr foo1 635 636See Note [CoreSyn top-level string literals] in CoreSyn. 637 638************************************************************************ 639* * 640 Completing a lazy binding 641* * 642************************************************************************ 643 644completeBind 645 * deals only with Ids, not TyVars 646 * takes an already-simplified binder and RHS 647 * is used for both recursive and non-recursive bindings 648 * is used for both top-level and non-top-level bindings 649 650It does the following: 651 - tries discarding a dead binding 652 - tries PostInlineUnconditionally 653 - add unfolding [this is the only place we add an unfolding] 654 - add arity 655 656It does *not* attempt to do let-to-case. Why? Because it is used for 657 - top-level bindings (when let-to-case is impossible) 658 - many situations where the "rhs" is known to be a WHNF 659 (so let-to-case is inappropriate). 660 661Nor does it do the atomic-argument thing 662-} 663 664completeBind :: SimplEnv 665 -> TopLevelFlag -- Flag stuck into unfolding 666 -> MaybeJoinCont -- Required only for join point 667 -> InId -- Old binder 668 -> OutId -> OutExpr -- New binder and RHS 669 -> SimplM (SimplFloats, SimplEnv) 670-- completeBind may choose to do its work 671-- * by extending the substitution (e.g. let x = y in ...) 672-- * or by adding to the floats in the envt 673-- 674-- Binder /can/ be a JoinId 675-- Precondition: rhs obeys the let/app invariant 676completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs 677 | isCoVar old_bndr 678 = case new_rhs of 679 Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) 680 _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) 681 682 | otherwise 683 = ASSERT( isId new_bndr ) 684 do { let old_info = idInfo old_bndr 685 old_unf = unfoldingInfo old_info 686 occ_info = occInfo old_info 687 688 -- Do eta-expansion on the RHS of the binding 689 -- See Note [Eta-expanding at let bindings] in SimplUtils 690 ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env) 691 new_bndr new_rhs 692 693 -- Simplify the unfolding 694 ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr 695 final_rhs (idType new_bndr) old_unf 696 697 ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding 698 -- See Note [In-scope set as a substitution] 699 700 ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs 701 702 then -- Inline and discard the binding 703 do { tick (PostInlineUnconditionally old_bndr) 704 ; return ( emptyFloats env 705 , extendIdSubst env old_bndr $ 706 DoneEx final_rhs (isJoinId_maybe new_bndr)) } 707 -- Use the substitution to make quite, quite sure that the 708 -- substitution will happen, since we are going to discard the binding 709 710 else -- Keep the binding 711 -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $ 712 return (mkFloatBind env (NonRec final_bndr final_rhs)) } 713 714addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId 715addLetBndrInfo new_bndr new_arity is_bot new_unf 716 = new_bndr `setIdInfo` info5 717 where 718 info1 = idInfo new_bndr `setArityInfo` new_arity 719 720 -- Unfolding info: Note [Setting the new unfolding] 721 info2 = info1 `setUnfoldingInfo` new_unf 722 723 -- Demand info: Note [Setting the demand info] 724 -- We also have to nuke demand info if for some reason 725 -- eta-expansion *reduces* the arity of the binding to less 726 -- than that of the strictness sig. This can happen: see Note [Arity decrease]. 727 info3 | isEvaldUnfolding new_unf 728 || (case strictnessInfo info2 of 729 StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty) 730 = zapDemandInfo info2 `orElse` info2 731 | otherwise 732 = info2 733 734 -- Bottoming bindings: see Note [Bottoming bindings] 735 info4 | is_bot = info3 `setStrictnessInfo` 736 mkClosedStrictSig (replicate new_arity topDmd) botRes 737 | otherwise = info3 738 739 -- Zap call arity info. We have used it by now (via 740 -- `tryEtaExpandRhs`), and the simplifier can invalidate this 741 -- information, leading to broken code later (e.g. #13479) 742 info5 = zapCallArityInfo info4 743 744 745{- Note [Arity decrease] 746~~~~~~~~~~~~~~~~~~~~~~~~ 747Generally speaking the arity of a binding should not decrease. But it *can* 748legitimately happen because of RULES. Eg 749 f = g Int 750where g has arity 2, will have arity 2. But if there's a rewrite rule 751 g Int --> h 752where h has arity 1, then f's arity will decrease. Here's a real-life example, 753which is in the output of Specialise: 754 755 Rec { 756 $dm {Arity 2} = \d.\x. op d 757 {-# RULES forall d. $dm Int d = $s$dm #-} 758 759 dInt = MkD .... opInt ... 760 opInt {Arity 1} = $dm dInt 761 762 $s$dm {Arity 0} = \x. op dInt } 763 764Here opInt has arity 1; but when we apply the rule its arity drops to 0. 765That's why Specialise goes to a little trouble to pin the right arity 766on specialised functions too. 767 768Note [Bottoming bindings] 769~~~~~~~~~~~~~~~~~~~~~~~~~ 770Suppose we have 771 let x = error "urk" 772 in ...(case x of <alts>)... 773or 774 let f = \x. error (x ++ "urk") 775 in ...(case f "foo" of <alts>)... 776 777Then we'd like to drop the dead <alts> immediately. So it's good to 778propagate the info that x's RHS is bottom to x's IdInfo as rapidly as 779possible. 780 781We use tryEtaExpandRhs on every binding, and it turns ou that the 782arity computation it performs (via CoreArity.findRhsArity) already 783does a simple bottoming-expression analysis. So all we need to do 784is propagate that info to the binder's IdInfo. 785 786This showed up in #12150; see comment:16. 787 788Note [Setting the demand info] 789~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 790If the unfolding is a value, the demand info may 791go pear-shaped, so we nuke it. Example: 792 let x = (a,b) in 793 case x of (p,q) -> h p q x 794Here x is certainly demanded. But after we've nuked 795the case, we'll get just 796 let x = (a,b) in h a b x 797and now x is not demanded (I'm assuming h is lazy) 798This really happens. Similarly 799 let f = \x -> e in ...f..f... 800After inlining f at some of its call sites the original binding may 801(for example) be no longer strictly demanded. 802The solution here is a bit ad hoc... 803 804 805************************************************************************ 806* * 807\subsection[Simplify-simplExpr]{The main function: simplExpr} 808* * 809************************************************************************ 810 811The reason for this OutExprStuff stuff is that we want to float *after* 812simplifying a RHS, not before. If we do so naively we get quadratic 813behaviour as things float out. 814 815To see why it's important to do it after, consider this (real) example: 816 817 let t = f x 818 in fst t 819==> 820 let t = let a = e1 821 b = e2 822 in (a,b) 823 in fst t 824==> 825 let a = e1 826 b = e2 827 t = (a,b) 828 in 829 a -- Can't inline a this round, cos it appears twice 830==> 831 e1 832 833Each of the ==> steps is a round of simplification. We'd save a 834whole round if we float first. This can cascade. Consider 835 836 let f = g d 837 in \x -> ...f... 838==> 839 let f = let d1 = ..d.. in \y -> e 840 in \x -> ...f... 841==> 842 let d1 = ..d.. 843 in \x -> ...(\y ->e)... 844 845Only in this second round can the \y be applied, and it 846might do the same again. 847-} 848 849simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr 850simplExpr env (Type ty) 851 = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] 852 ; return (Type ty') } 853 854simplExpr env expr 855 = simplExprC env expr (mkBoringStop expr_out_ty) 856 where 857 expr_out_ty :: OutType 858 expr_out_ty = substTy env (exprType expr) 859 -- NB: Since 'expr' is term-valued, not (Type ty), this call 860 -- to exprType will succeed. exprType fails on (Type ty). 861 862simplExprC :: SimplEnv 863 -> InExpr -- A term-valued expression, never (Type ty) 864 -> SimplCont 865 -> SimplM OutExpr 866 -- Simplify an expression, given a continuation 867simplExprC env expr cont 868 = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $ 869 do { (floats, expr') <- simplExprF env expr cont 870 ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ 871 -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ 872 -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ 873 return (wrapFloats floats expr') } 874 875-------------------------------------------------- 876simplExprF :: SimplEnv 877 -> InExpr -- A term-valued expression, never (Type ty) 878 -> SimplCont 879 -> SimplM (SimplFloats, OutExpr) 880 881simplExprF env e cont 882 = {- pprTrace "simplExprF" (vcat 883 [ ppr e 884 , text "cont =" <+> ppr cont 885 , text "inscope =" <+> ppr (seInScope env) 886 , text "tvsubst =" <+> ppr (seTvSubst env) 887 , text "idsubst =" <+> ppr (seIdSubst env) 888 , text "cvsubst =" <+> ppr (seCvSubst env) 889 ]) $ -} 890 simplExprF1 env e cont 891 892simplExprF1 :: SimplEnv -> InExpr -> SimplCont 893 -> SimplM (SimplFloats, OutExpr) 894 895simplExprF1 _ (Type ty) _ 896 = pprPanic "simplExprF: type" (ppr ty) 897 -- simplExprF does only with term-valued expressions 898 -- The (Type ty) case is handled separately by simplExpr 899 -- and by the other callers of simplExprF 900 901simplExprF1 env (Var v) cont = {-#SCC "simplIdF" #-} simplIdF env v cont 902simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont 903simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont 904simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont 905simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont 906 907simplExprF1 env (App fun arg) cont 908 = {-#SCC "simplExprF1-App" #-} case arg of 909 Type ty -> do { -- The argument type will (almost) certainly be used 910 -- in the output program, so just force it now. 911 -- See Note [Avoiding space leaks in OutType] 912 arg' <- simplType env ty 913 914 -- But use substTy, not simplType, to avoid forcing 915 -- the hole type; it will likely not be needed. 916 -- See Note [The hole type in ApplyToTy] 917 ; let hole' = substTy env (exprType fun) 918 919 ; simplExprF env fun $ 920 ApplyToTy { sc_arg_ty = arg' 921 , sc_hole_ty = hole' 922 , sc_cont = cont } } 923 _ -> simplExprF env fun $ 924 ApplyToVal { sc_arg = arg, sc_env = env 925 , sc_dup = NoDup, sc_cont = cont } 926 927simplExprF1 env expr@(Lam {}) cont 928 = {-#SCC "simplExprF1-Lam" #-} 929 simplLam env zapped_bndrs body cont 930 -- The main issue here is under-saturated lambdas 931 -- (\x1. \x2. e) arg1 932 -- Here x1 might have "occurs-once" occ-info, because occ-info 933 -- is computed assuming that a group of lambdas is applied 934 -- all at once. If there are too few args, we must zap the 935 -- occ-info, UNLESS the remaining binders are one-shot 936 where 937 (bndrs, body) = collectBinders expr 938 zapped_bndrs | need_to_zap = map zap bndrs 939 | otherwise = bndrs 940 941 need_to_zap = any zappable_bndr (drop n_args bndrs) 942 n_args = countArgs cont 943 -- NB: countArgs counts all the args (incl type args) 944 -- and likewise drop counts all binders (incl type lambdas) 945 946 zappable_bndr b = isId b && not (isOneShotBndr b) 947 zap b | isTyVar b = b 948 | otherwise = zapLamIdInfo b 949 950simplExprF1 env (Case scrut bndr _ alts) cont 951 = {-#SCC "simplExprF1-Case" #-} 952 simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr 953 , sc_alts = alts 954 , sc_env = env, sc_cont = cont }) 955 956simplExprF1 env (Let (Rec pairs) body) cont 957 | Just pairs' <- joinPointBindings_maybe pairs 958 = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont 959 960 | otherwise 961 = {-#SCC "simplRecE" #-} simplRecE env pairs body cont 962 963simplExprF1 env (Let (NonRec bndr rhs) body) cont 964 | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) 965 = {-#SCC "simplExprF1-NonRecLet-Type" #-} 966 ASSERT( isTyVar bndr ) 967 do { ty' <- simplType env ty 968 ; simplExprF (extendTvSubst env bndr ty') body cont } 969 970 | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs 971 = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont 972 973 | otherwise 974 = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont 975 976{- Note [Avoiding space leaks in OutType] 977~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 978Since the simplifier is run for multiple iterations, we need to ensure 979that any thunks in the output of one simplifier iteration are forced 980by the evaluation of the next simplifier iteration. Otherwise we may 981retain multiple copies of the Core program and leak a terrible amount 982of memory (as in #13426). 983 984The simplifier is naturally strict in the entire "Expr part" of the 985input Core program, because any expression may contain binders, which 986we must find in order to extend the SimplEnv accordingly. But types 987do not contain binders and so it is tempting to write things like 988 989 simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! 990 991This is Bad because the result includes a thunk (substTy env ty) which 992retains a reference to the whole simplifier environment; and the next 993simplifier iteration will not force this thunk either, because the 994line above is not strict in ty. 995 996So instead our strategy is for the simplifier to fully evaluate 997OutTypes when it emits them into the output Core program, for example 998 999 simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good 1000 ; return (Type ty') } 1001 1002where the only difference from above is that simplType calls seqType 1003on the result of substTy. 1004 1005However, SimplCont can also contain OutTypes and it's not necessarily 1006a good idea to force types on the way in to SimplCont, because they 1007may end up not being used and forcing them could be a lot of wasted 1008work. T5631 is a good example of this. 1009 1010- For ApplyToTy's sc_arg_ty, we force the type on the way in because 1011 the type will almost certainly appear as a type argument in the 1012 output program. 1013 1014- For the hole types in Stop and ApplyToTy, we force the type when we 1015 emit it into the output program, after obtaining it from 1016 contResultType. (The hole type in ApplyToTy is only directly used 1017 to form the result type in a new Stop continuation.) 1018-} 1019 1020--------------------------------- 1021-- Simplify a join point, adding the context. 1022-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: 1023-- \x1 .. xn -> e => \x1 .. xn -> E[e] 1024-- Note that we need the arity of the join point, since e may be a lambda 1025-- (though this is unlikely). See Note [Case-of-case and join points]. 1026simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont 1027 -> SimplM OutExpr 1028simplJoinRhs env bndr expr cont 1029 | Just arity <- isJoinId_maybe bndr 1030 = do { let (join_bndrs, join_body) = collectNBinders arity expr 1031 ; (env', join_bndrs') <- simplLamBndrs env join_bndrs 1032 ; join_body' <- simplExprC env' join_body cont 1033 ; return $ mkLams join_bndrs' join_body' } 1034 1035 | otherwise 1036 = pprPanic "simplJoinRhs" (ppr bndr) 1037 1038--------------------------------- 1039simplType :: SimplEnv -> InType -> SimplM OutType 1040 -- Kept monadic just so we can do the seqType 1041 -- See Note [Avoiding space leaks in OutType] 1042simplType env ty 1043 = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ 1044 seqType new_ty `seq` return new_ty 1045 where 1046 new_ty = substTy env ty 1047 1048--------------------------------- 1049simplCoercionF :: SimplEnv -> InCoercion -> SimplCont 1050 -> SimplM (SimplFloats, OutExpr) 1051simplCoercionF env co cont 1052 = do { co' <- simplCoercion env co 1053 ; rebuild env (Coercion co') cont } 1054 1055simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion 1056simplCoercion env co 1057 = do { dflags <- getDynFlags 1058 ; let opt_co = optCoercion dflags (getTCvSubst env) co 1059 ; seqCo opt_co `seq` return opt_co } 1060 1061----------------------------------- 1062-- | Push a TickIt context outwards past applications and cases, as 1063-- long as this is a non-scoping tick, to let case and application 1064-- optimisations apply. 1065 1066simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont 1067 -> SimplM (SimplFloats, OutExpr) 1068simplTick env tickish expr cont 1069 -- A scoped tick turns into a continuation, so that we can spot 1070 -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do 1071 -- it this way, then it would take two passes of the simplifier to 1072 -- reduce ((scc t (\x . e)) e'). 1073 -- NB, don't do this with counting ticks, because if the expr is 1074 -- bottom, then rebuildCall will discard the continuation. 1075 1076-- XXX: we cannot do this, because the simplifier assumes that 1077-- the context can be pushed into a case with a single branch. e.g. 1078-- scc<f> case expensive of p -> e 1079-- becomes 1080-- case expensive of p -> scc<f> e 1081-- 1082-- So I'm disabling this for now. It just means we will do more 1083-- simplifier iterations that necessary in some cases. 1084 1085-- | tickishScoped tickish && not (tickishCounts tickish) 1086-- = simplExprF env expr (TickIt tickish cont) 1087 1088 -- For unscoped or soft-scoped ticks, we are allowed to float in new 1089 -- cost, so we simply push the continuation inside the tick. This 1090 -- has the effect of moving the tick to the outside of a case or 1091 -- application context, allowing the normal case and application 1092 -- optimisations to fire. 1093 | tickish `tickishScopesLike` SoftScope 1094 = do { (floats, expr') <- simplExprF env expr cont 1095 ; return (floats, mkTick tickish expr') 1096 } 1097 1098 -- Push tick inside if the context looks like this will allow us to 1099 -- do a case-of-case - see Note [case-of-scc-of-case] 1100 | Select {} <- cont, Just expr' <- push_tick_inside 1101 = simplExprF env expr' cont 1102 1103 -- We don't want to move the tick, but we might still want to allow 1104 -- floats to pass through with appropriate wrapping (or not, see 1105 -- wrap_floats below) 1106 --- | not (tickishCounts tickish) || tickishCanSplit tickish 1107 -- = wrap_floats 1108 1109 | otherwise 1110 = no_floating_past_tick 1111 1112 where 1113 1114 -- Try to push tick inside a case, see Note [case-of-scc-of-case]. 1115 push_tick_inside = 1116 case expr0 of 1117 Case scrut bndr ty alts 1118 -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) 1119 _other -> Nothing 1120 where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) 1121 movable t = not (tickishCounts t) || 1122 t `tickishScopesLike` NoScope || 1123 tickishCanSplit t 1124 tickScrut e = foldr mkTick e ticks 1125 -- Alternatives get annotated with all ticks that scope in some way, 1126 -- but we don't want to count entries. 1127 tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope) 1128 ts_scope = map mkNoCount $ 1129 filter (not . (`tickishScopesLike` NoScope)) ticks 1130 1131 no_floating_past_tick = 1132 do { let (inc,outc) = splitCont cont 1133 ; (floats, expr1) <- simplExprF env expr inc 1134 ; let expr2 = wrapFloats floats expr1 1135 tickish' = simplTickish env tickish 1136 ; rebuild env (mkTick tickish' expr2) outc 1137 } 1138 1139-- Alternative version that wraps outgoing floats with the tick. This 1140-- results in ticks being duplicated, as we don't make any attempt to 1141-- eliminate the tick if we re-inline the binding (because the tick 1142-- semantics allows unrestricted inlining of HNFs), so I'm not doing 1143-- this any more. FloatOut will catch any real opportunities for 1144-- floating. 1145-- 1146-- wrap_floats = 1147-- do { let (inc,outc) = splitCont cont 1148-- ; (env', expr') <- simplExprF (zapFloats env) expr inc 1149-- ; let tickish' = simplTickish env tickish 1150-- ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0), 1151-- mkTick (mkNoCount tickish') rhs) 1152-- -- when wrapping a float with mkTick, we better zap the Id's 1153-- -- strictness info and arity, because it might be wrong now. 1154-- ; let env'' = addFloats env (mapFloats env' wrap_float) 1155-- ; rebuild env'' expr' (TickIt tickish' outc) 1156-- } 1157 1158 1159 simplTickish env tickish 1160 | Breakpoint n ids <- tickish 1161 = Breakpoint n (map (getDoneId . substId env) ids) 1162 | otherwise = tickish 1163 1164 -- Push type application and coercion inside a tick 1165 splitCont :: SimplCont -> (SimplCont, SimplCont) 1166 splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) 1167 where (inc,outc) = splitCont tail 1168 splitCont (CastIt co c) = (CastIt co inc, outc) 1169 where (inc,outc) = splitCont c 1170 splitCont other = (mkBoringStop (contHoleType other), other) 1171 1172 getDoneId (DoneId id) = id 1173 getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst 1174 getDoneId other = pprPanic "getDoneId" (ppr other) 1175 1176-- Note [case-of-scc-of-case] 1177-- It's pretty important to be able to transform case-of-case when 1178-- there's an SCC in the way. For example, the following comes up 1179-- in nofib/real/compress/Encode.hs: 1180-- 1181-- case scctick<code_string.r1> 1182-- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje 1183-- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> 1184-- (ww1_s13f, ww2_s13g, ww3_s13h) 1185-- } 1186-- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> 1187-- tick<code_string.f1> 1188-- (ww_s12Y, 1189-- ww1_s12Z, 1190-- PTTrees.PT 1191-- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) 1192-- } 1193-- 1194-- We really want this case-of-case to fire, because then the 3-tuple 1195-- will go away (indeed, the CPR optimisation is relying on this 1196-- happening). But the scctick is in the way - we need to push it 1197-- inside to expose the case-of-case. So we perform this 1198-- transformation on the inner case: 1199-- 1200-- scctick c (case e of { p1 -> e1; ...; pn -> en }) 1201-- ==> 1202-- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } 1203-- 1204-- So we've moved a constant amount of work out of the scc to expose 1205-- the case. We only do this when the continuation is interesting: in 1206-- for now, it has to be another Case (maybe generalise this later). 1207 1208{- 1209************************************************************************ 1210* * 1211\subsection{The main rebuilder} 1212* * 1213************************************************************************ 1214-} 1215 1216rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) 1217-- At this point the substitution in the SimplEnv should be irrelevant; 1218-- only the in-scope set matters 1219rebuild env expr cont 1220 = case cont of 1221 Stop {} -> return (emptyFloats env, expr) 1222 TickIt t cont -> rebuild env (mkTick t expr) cont 1223 CastIt co cont -> rebuild env (mkCast expr co) cont 1224 -- NB: mkCast implements the (Coercion co |> g) optimisation 1225 1226 Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } 1227 -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont 1228 1229 StrictArg { sc_fun = fun, sc_cont = cont } 1230 -> rebuildCall env (fun `addValArgTo` expr) cont 1231 StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body 1232 , sc_env = se, sc_cont = cont } 1233 -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr 1234 -- expr satisfies let/app since it started life 1235 -- in a call to simplNonRecE 1236 ; (floats2, expr') <- simplLam env' bs body cont 1237 ; return (floats1 `addFloats` floats2, expr') } 1238 1239 ApplyToTy { sc_arg_ty = ty, sc_cont = cont} 1240 -> rebuild env (App expr (Type ty)) cont 1241 1242 ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont} 1243 -- See Note [Avoid redundant simplification] 1244 -> do { (_, _, arg') <- simplArg env dup_flag se arg 1245 ; rebuild env (App expr arg') cont } 1246 1247{- 1248************************************************************************ 1249* * 1250\subsection{Lambdas} 1251* * 1252************************************************************************ 1253-} 1254 1255{- Note [Optimising reflexivity] 1256~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1257It's important (for compiler performance) to get rid of reflexivity as soon 1258as it appears. See #11735, #14737, and #15019. 1259 1260In particular, we want to behave well on 1261 1262 * e |> co1 |> co2 1263 where the two happen to cancel out entirely. That is quite common; 1264 e.g. a newtype wrapping and unwrapping cancel. 1265 1266 1267 * (f |> co) @t1 @t2 ... @tn x1 .. xm 1268 Here we wil use pushCoTyArg and pushCoValArg successively, which 1269 build up NthCo stacks. Silly to do that if co is reflexive. 1270 1271However, we don't want to call isReflexiveCo too much, because it uses 1272type equality which is expensive on big types (#14737 comment:7). 1273 1274A good compromise (determined experimentally) seems to be to call 1275isReflexiveCo 1276 * when composing casts, and 1277 * at the end 1278 1279In investigating this I saw missed opportunities for on-the-fly 1280coercion shrinkage. See #15090. 1281-} 1282 1283 1284simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont 1285 -> SimplM (SimplFloats, OutExpr) 1286simplCast env body co0 cont0 1287 = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 1288 ; cont1 <- {-#SCC "simplCast-addCoerce" #-} 1289 if isReflCo co1 1290 then return cont0 -- See Note [Optimising reflexivity] 1291 else addCoerce co1 cont0 1292 ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } 1293 where 1294 -- If the first parameter is MRefl, then simplifying revealed a 1295 -- reflexive coercion. Omit. 1296 addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont 1297 addCoerceM MRefl cont = return cont 1298 addCoerceM (MCo co) cont = addCoerce co cont 1299 1300 addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont 1301 addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity] 1302 | isReflexiveCo co' = return cont 1303 | otherwise = addCoerce co' cont 1304 where 1305 co' = mkTransCo co1 co2 1306 1307 addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) 1308 | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty 1309 -- N.B. As mentioned in Note [The hole type in ApplyToTy] this is 1310 -- only needed by `sc_hole_ty` which is often not forced. 1311 -- Consequently it is worthwhile using a lazy pattern match here to 1312 -- avoid unnecessary coercionKind evaluations. 1313 , ~(Pair hole_ty _) <- coercionKind co 1314 = {-#SCC "addCoerce-pushCoTyArg" #-} 1315 do { tail' <- addCoerceM m_co' tail 1316 ; return (cont { sc_arg_ty = arg_ty' 1317 , sc_hole_ty = hole_ty -- NB! As the cast goes past, the 1318 -- type of the hole changes (#16312) 1319 , sc_cont = tail' }) } 1320 1321 addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se 1322 , sc_dup = dup, sc_cont = tail }) 1323 | Just (co1, m_co2) <- pushCoValArg co 1324 , Pair _ new_ty <- coercionKind co1 1325 , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg 1326 -- See Note [Levity polymorphism invariants] in CoreSyn 1327 -- test: typecheck/should_run/EtaExpandLevPoly 1328 = {-#SCC "addCoerce-pushCoValArg" #-} 1329 do { tail' <- addCoerceM m_co2 tail 1330 ; if isReflCo co1 1331 then return (cont { sc_cont = tail' }) 1332 -- Avoid simplifying if possible; 1333 -- See Note [Avoiding exponential behaviour] 1334 else do 1335 { (dup', arg_se', arg') <- simplArg env dup arg_se arg 1336 -- When we build the ApplyTo we can't mix the OutCoercion 1337 -- 'co' with the InExpr 'arg', so we simplify 1338 -- to make it all consistent. It's a bit messy. 1339 -- But it isn't a common case. 1340 -- Example of use: #995 1341 ; return (ApplyToVal { sc_arg = mkCast arg' co1 1342 , sc_env = arg_se' 1343 , sc_dup = dup' 1344 , sc_cont = tail' }) } } 1345 1346 addCoerce co cont 1347 | isReflexiveCo co = return cont -- Having this at the end makes a huge 1348 -- difference in T12227, for some reason 1349 -- See Note [Optimising reflexivity] 1350 | otherwise = return (CastIt co cont) 1351 1352simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr 1353 -> SimplM (DupFlag, StaticEnv, OutExpr) 1354simplArg env dup_flag arg_env arg 1355 | isSimplified dup_flag 1356 = return (dup_flag, arg_env, arg) 1357 | otherwise 1358 = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg 1359 ; return (Simplified, zapSubstEnv arg_env, arg') } 1360 1361{- 1362************************************************************************ 1363* * 1364\subsection{Lambdas} 1365* * 1366************************************************************************ 1367-} 1368 1369simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont 1370 -> SimplM (SimplFloats, OutExpr) 1371 1372simplLam env [] body cont 1373 = simplExprF env body cont 1374 1375simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) 1376 = do { tick (BetaReduction bndr) 1377 ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont } 1378 1379simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se 1380 , sc_cont = cont, sc_dup = dup }) 1381 | isSimplified dup -- Don't re-simplify if we've simplified it once 1382 -- See Note [Avoiding exponential behaviour] 1383 = do { tick (BetaReduction bndr) 1384 ; (floats1, env') <- simplNonRecX env zapped_bndr arg 1385 ; (floats2, expr') <- simplLam env' bndrs body cont 1386 ; return (floats1 `addFloats` floats2, expr') } 1387 1388 | otherwise 1389 = do { tick (BetaReduction bndr) 1390 ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont } 1391 where 1392 zapped_bndr -- See Note [Zap unfolding when beta-reducing] 1393 | isId bndr = zapStableUnfolding bndr 1394 | otherwise = bndr 1395 1396 -- Discard a non-counting tick on a lambda. This may change the 1397 -- cost attribution slightly (moving the allocation of the 1398 -- lambda elsewhere), but we don't care: optimisation changes 1399 -- cost attribution all the time. 1400simplLam env bndrs body (TickIt tickish cont) 1401 | not (tickishCounts tickish) 1402 = simplLam env bndrs body cont 1403 1404 -- Not enough args, so there are real lambdas left to put in the result 1405simplLam env bndrs body cont 1406 = do { (env', bndrs') <- simplLamBndrs env bndrs 1407 ; body' <- simplExpr env' body 1408 ; new_lam <- mkLam env bndrs' body' cont 1409 ; rebuild env' new_lam cont } 1410 1411------------- 1412simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) 1413-- Used for lambda binders. These sometimes have unfoldings added by 1414-- the worker/wrapper pass that must be preserved, because they can't 1415-- be reconstructed from context. For example: 1416-- f x = case x of (a,b) -> fw a b x 1417-- fw a b x{=(a,b)} = ... 1418-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise. 1419simplLamBndr env bndr 1420 | isId bndr && isFragileUnfolding old_unf -- Special case 1421 = do { (env1, bndr1) <- simplBinder env bndr 1422 ; unf' <- simplStableUnfolding env1 NotTopLevel Nothing bndr 1423 old_unf (idType bndr1) 1424 ; let bndr2 = bndr1 `setIdUnfolding` unf' 1425 ; return (modifyInScope env1 bndr2, bndr2) } 1426 1427 | otherwise 1428 = simplBinder env bndr -- Normal case 1429 where 1430 old_unf = idUnfolding bndr 1431 1432simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) 1433simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs 1434 1435------------------ 1436simplNonRecE :: SimplEnv 1437 -> InId -- The binder, always an Id 1438 -- Never a join point 1439 -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) 1440 -> ([InBndr], InExpr) -- Body of the let/lambda 1441 -- \xs.e 1442 -> SimplCont 1443 -> SimplM (SimplFloats, OutExpr) 1444 1445-- simplNonRecE is used for 1446-- * non-top-level non-recursive non-join-point lets in expressions 1447-- * beta reduction 1448-- 1449-- simplNonRec env b (rhs, rhs_se) (bs, body) k 1450-- = let env in 1451-- cont< let b = rhs_se(rhs) in \bs.body > 1452-- 1453-- It deals with strict bindings, via the StrictBind continuation, 1454-- which may abort the whole process 1455-- 1456-- Precondition: rhs satisfies the let/app invariant 1457-- Note [CoreSyn let/app invariant] in CoreSyn 1458-- 1459-- The "body" of the binding comes as a pair of ([InId],InExpr) 1460-- representing a lambda; so we recurse back to simplLam 1461-- Why? Because of the binder-occ-info-zapping done before 1462-- the call to simplLam in simplExprF (Lam ...) 1463 1464simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont 1465 | ASSERT( isId bndr && not (isJoinId bndr) ) True 1466 , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se 1467 = do { tick (PreInlineUnconditionally bndr) 1468 ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ 1469 simplLam env' bndrs body cont } 1470 1471 -- Deal with strict bindings 1472 | isStrictId bndr -- Includes coercions, and unlifted types 1473 , sm_case_case (getMode env) 1474 = simplExprF (rhs_se `setInScopeFromE` env) rhs 1475 (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body 1476 , sc_env = env, sc_cont = cont, sc_dup = NoDup }) 1477 1478 -- Deal with lazy bindings 1479 | otherwise 1480 = ASSERT( not (isTyVar bndr) ) 1481 do { (env1, bndr1) <- simplNonRecBndr env bndr 1482 ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing 1483 ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se 1484 ; (floats2, expr') <- simplLam env3 bndrs body cont 1485 ; return (floats1 `addFloats` floats2, expr') } 1486 1487------------------ 1488simplRecE :: SimplEnv 1489 -> [(InId, InExpr)] 1490 -> InExpr 1491 -> SimplCont 1492 -> SimplM (SimplFloats, OutExpr) 1493 1494-- simplRecE is used for 1495-- * non-top-level recursive lets in expressions 1496simplRecE env pairs body cont 1497 = do { let bndrs = map fst pairs 1498 ; MASSERT(all (not . isJoinId) bndrs) 1499 ; env1 <- simplRecBndrs env bndrs 1500 -- NB: bndrs' don't have unfoldings or rules 1501 -- We add them as we go down 1502 ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs 1503 ; (floats2, expr') <- simplExprF env2 body cont 1504 ; return (floats1 `addFloats` floats2, expr') } 1505 1506{- Note [Avoiding exponential behaviour] 1507~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1508One way in which we can get exponential behaviour is if we simplify a 1509big expression, and the re-simplify it -- and then this happens in a 1510deeply-nested way. So we must be jolly careful about re-simplifying 1511an expression. That is why completeNonRecX does not try 1512preInlineUnconditionally. 1513 1514Example: 1515 f BIG, where f has a RULE 1516Then 1517 * We simplify BIG before trying the rule; but the rule does not fire 1518 * We inline f = \x. x True 1519 * So if we did preInlineUnconditionally we'd re-simplify (BIG True) 1520 1521However, if BIG has /not/ already been simplified, we'd /like/ to 1522simplify BIG True; maybe good things happen. That is why 1523 1524* simplLam has 1525 - a case for (isSimplified dup), which goes via simplNonRecX, and 1526 - a case for the un-simplified case, which goes via simplNonRecE 1527 1528* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, 1529 in at least two places 1530 - In simplCast/addCoerce, where we check for isReflCo 1531 - In rebuildCall we avoid simplifying arguments before we have to 1532 (see Note [Trying rewrite rules]) 1533 1534 1535Note [Zap unfolding when beta-reducing] 1536~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1537Lambda-bound variables can have stable unfoldings, such as 1538 $j = \x. \b{Unf=Just x}. e 1539See Note [Case binders and join points] below; the unfolding for lets 1540us optimise e better. However when we beta-reduce it we want to 1541revert to using the actual value, otherwise we can end up in the 1542stupid situation of 1543 let x = blah in 1544 let b{Unf=Just x} = y 1545 in ...b... 1546Here it'd be far better to drop the unfolding and use the actual RHS. 1547 1548************************************************************************ 1549* * 1550 Join points 1551* * 1552********************************************************************* -} 1553 1554{- Note [Rules and unfolding for join points] 1555~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1556Suppose we have 1557 1558 simplExpr (join j x = rhs ) cont 1559 ( {- RULE j (p:ps) = blah -} ) 1560 ( {- StableUnfolding j = blah -} ) 1561 (in blah ) 1562 1563Then we will push 'cont' into the rhs of 'j'. But we should *also* push 1564'cont' into the RHS of 1565 * Any RULEs for j, e.g. generated by SpecConstr 1566 * Any stable unfolding for j, e.g. the result of an INLINE pragma 1567 1568Simplifying rules and stable-unfoldings happens a bit after 1569simplifying the right-hand side, so we remember whether or not it 1570is a join point, and what 'cont' is, in a value of type MaybeJoinCont 1571 1572#13900 wsa caused by forgetting to push 'cont' into the RHS 1573of a SpecConstr-generated RULE for a join point. 1574-} 1575 1576type MaybeJoinCont = Maybe SimplCont 1577 -- Nothing => Not a join point 1578 -- Just k => This is a join binding with continuation k 1579 -- See Note [Rules and unfolding for join points] 1580 1581simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr 1582 -> InExpr -> SimplCont 1583 -> SimplM (SimplFloats, OutExpr) 1584simplNonRecJoinPoint env bndr rhs body cont 1585 | ASSERT( isJoinId bndr ) True 1586 , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env 1587 = do { tick (PreInlineUnconditionally bndr) 1588 ; simplExprF env' body cont } 1589 1590 | otherwise 1591 = wrapJoinCont env cont $ \ env cont -> 1592 do { -- We push join_cont into the join RHS and the body; 1593 -- and wrap wrap_cont around the whole thing 1594 ; let res_ty = contResultType cont 1595 ; (env1, bndr1) <- simplNonRecJoinBndr env res_ty bndr 1596 ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (Just cont) 1597 ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env 1598 ; (floats2, body') <- simplExprF env3 body cont 1599 ; return (floats1 `addFloats` floats2, body') } 1600 1601 1602------------------ 1603simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] 1604 -> InExpr -> SimplCont 1605 -> SimplM (SimplFloats, OutExpr) 1606simplRecJoinPoint env pairs body cont 1607 = wrapJoinCont env cont $ \ env cont -> 1608 do { let bndrs = map fst pairs 1609 res_ty = contResultType cont 1610 ; env1 <- simplRecJoinBndrs env res_ty bndrs 1611 -- NB: bndrs' don't have unfoldings or rules 1612 -- We add them as we go down 1613 ; (floats1, env2) <- simplRecBind env1 NotTopLevel (Just cont) pairs 1614 ; (floats2, body') <- simplExprF env2 body cont 1615 ; return (floats1 `addFloats` floats2, body') } 1616 1617-------------------- 1618wrapJoinCont :: SimplEnv -> SimplCont 1619 -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) 1620 -> SimplM (SimplFloats, OutExpr) 1621-- Deal with making the continuation duplicable if necessary, 1622-- and with the no-case-of-case situation. 1623wrapJoinCont env cont thing_inside 1624 | contIsStop cont -- Common case; no need for fancy footwork 1625 = thing_inside env cont 1626 1627 | not (sm_case_case (getMode env)) 1628 -- See Note [Join points wih -fno-case-of-case] 1629 = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) 1630 ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 1631 ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont 1632 ; return (floats2 `addFloats` floats3, expr3) } 1633 1634 | otherwise 1635 -- Normal case; see Note [Join points and case-of-case] 1636 = do { (floats1, cont') <- mkDupableCont env cont 1637 ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' 1638 ; return (floats1 `addFloats` floats2, result) } 1639 1640 1641-------------------- 1642trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont 1643-- Drop outer context from join point invocation (jump) 1644-- See Note [Join points and case-of-case] 1645 1646trimJoinCont _ Nothing cont 1647 = cont -- Not a jump 1648trimJoinCont var (Just arity) cont 1649 = trim arity cont 1650 where 1651 trim 0 cont@(Stop {}) 1652 = cont 1653 trim 0 cont 1654 = mkBoringStop (contResultType cont) 1655 trim n cont@(ApplyToVal { sc_cont = k }) 1656 = cont { sc_cont = trim (n-1) k } 1657 trim n cont@(ApplyToTy { sc_cont = k }) 1658 = cont { sc_cont = trim (n-1) k } -- join arity counts types! 1659 trim _ cont 1660 = pprPanic "completeCall" $ ppr var $$ ppr cont 1661 1662 1663{- Note [Join points and case-of-case] 1664~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1665When we perform the case-of-case transform (or otherwise push continuations 1666inward), we want to treat join points specially. Since they're always 1667tail-called and we want to maintain this invariant, we can do this (for any 1668evaluation context E): 1669 1670 E[join j = e 1671 in case ... of 1672 A -> jump j 1 1673 B -> jump j 2 1674 C -> f 3] 1675 1676 --> 1677 1678 join j = E[e] 1679 in case ... of 1680 A -> jump j 1 1681 B -> jump j 2 1682 C -> E[f 3] 1683 1684As is evident from the example, there are two components to this behavior: 1685 1686 1. When entering the RHS of a join point, copy the context inside. 1687 2. When a join point is invoked, discard the outer context. 1688 1689We need to be very careful here to remain consistent---neither part is 1690optional! 1691 1692We need do make the continuation E duplicable (since we are duplicating it) 1693with mkDuableCont. 1694 1695 1696Note [Join points wih -fno-case-of-case] 1697~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1698Supose case-of-case is switched off, and we are simplifying 1699 1700 case (join j x = <j-rhs> in 1701 case y of 1702 A -> j 1 1703 B -> j 2 1704 C -> e) of <outer-alts> 1705 1706Usually, we'd push the outer continuation (case . of <outer-alts>) into 1707both the RHS and the body of the join point j. But since we aren't doing 1708case-of-case we may then end up with this totally bogus result 1709 1710 join x = case <j-rhs> of <outer-alts> in 1711 case (case y of 1712 A -> j 1 1713 B -> j 2 1714 C -> e) of <outer-alts> 1715 1716This would be OK in the language of the paper, but not in GHC: j is no longer 1717a join point. We can only do the "push contination into the RHS of the 1718join point j" if we also push the contination right down to the /jumps/ to 1719j, so that it can evaporate there. If we are doing case-of-case, we'll get to 1720 1721 join x = case <j-rhs> of <outer-alts> in 1722 case y of 1723 A -> j 1 1724 B -> j 2 1725 C -> case e of <outer-alts> 1726 1727which is great. 1728 1729Bottom line: if case-of-case is off, we must stop pushing the continuation 1730inwards altogether at any join point. Instead simplify the (join ... in ...) 1731with a Stop continuation, and wrap the original continuation around the 1732outside. Surprisingly tricky! 1733 1734 1735************************************************************************ 1736* * 1737 Variables 1738* * 1739************************************************************************ 1740-} 1741 1742simplVar :: SimplEnv -> InVar -> SimplM OutExpr 1743-- Look up an InVar in the environment 1744simplVar env var 1745 | isTyVar var = return (Type (substTyVar env var)) 1746 | isCoVar var = return (Coercion (substCoVar env var)) 1747 | otherwise 1748 = case substId env var of 1749 ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e 1750 DoneId var1 -> return (Var var1) 1751 DoneEx e _ -> return e 1752 1753simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) 1754simplIdF env var cont 1755 = case substId env var of 1756 ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont 1757 -- Don't trim; haven't already simplified e, 1758 -- so the cont is not embodied in e 1759 1760 DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont) 1761 1762 DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont) 1763 -- Note [zapSubstEnv] 1764 -- The template is already simplified, so don't re-substitute. 1765 -- This is VITAL. Consider 1766 -- let x = e in 1767 -- let y = \z -> ...x... in 1768 -- \ x -> ...y... 1769 -- We'll clone the inner \x, adding x->x' in the id_subst 1770 -- Then when we inline y, we must *not* replace x by x' in 1771 -- the inlined copy!! 1772 1773--------------------------------------------------------- 1774-- Dealing with a call site 1775 1776completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) 1777completeCall env var cont 1778 | Just expr <- callSiteInline dflags var active_unf 1779 lone_variable arg_infos interesting_cont 1780 -- Inline the variable's RHS 1781 = do { checkedTick (UnfoldingDone var) 1782 ; dump_inline expr cont 1783 ; simplExprF (zapSubstEnv env) expr cont } 1784 1785 | otherwise 1786 -- Don't inline; instead rebuild the call 1787 = do { rule_base <- getSimplRules 1788 ; let info = mkArgInfo env var (getRules rule_base var) 1789 n_val_args call_cont 1790 ; rebuildCall env info cont } 1791 1792 where 1793 dflags = seDynFlags env 1794 (lone_variable, arg_infos, call_cont) = contArgs cont 1795 n_val_args = length arg_infos 1796 interesting_cont = interestingCallContext env call_cont 1797 active_unf = activeUnfolding (getMode env) var 1798 1799 dump_inline unfolding cont 1800 | not (dopt Opt_D_dump_inlinings dflags) = return () 1801 | not (dopt Opt_D_verbose_core2core dflags) 1802 = when (isExternalName (idName var)) $ 1803 liftIO $ printOutputForUser dflags alwaysQualify $ 1804 sep [text "Inlining done:", nest 4 (ppr var)] 1805 | otherwise 1806 = liftIO $ printOutputForUser dflags alwaysQualify $ 1807 sep [text "Inlining done: " <> ppr var, 1808 nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), 1809 text "Cont: " <+> ppr cont])] 1810 1811rebuildCall :: SimplEnv 1812 -> ArgInfo 1813 -> SimplCont 1814 -> SimplM (SimplFloats, OutExpr) 1815-- We decided not to inline, so 1816-- - simplify the arguments 1817-- - try rewrite rules 1818-- - and rebuild 1819 1820---------- Bottoming applications -------------- 1821rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont 1822 -- When we run out of strictness args, it means 1823 -- that the call is definitely bottom; see SimplUtils.mkArgInfo 1824 -- Then we want to discard the entire strict continuation. E.g. 1825 -- * case (error "hello") of { ... } 1826 -- * (error "Hello") arg 1827 -- * f (error "Hello") where f is strict 1828 -- etc 1829 -- Then, especially in the first of these cases, we'd like to discard 1830 -- the continuation, leaving just the bottoming expression. But the 1831 -- type might not be right, so we may have to add a coerce. 1832 | not (contIsTrivial cont) -- Only do this if there is a non-trivial 1833 -- continuation to discard, else we do it 1834 -- again and again! 1835 = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] 1836 return (emptyFloats env, castBottomExpr res cont_ty) 1837 where 1838 res = argInfoExpr fun rev_args 1839 cont_ty = contResultType cont 1840 1841---------- Try rewrite RULES -------------- 1842-- See Note [Trying rewrite rules] 1843rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args 1844 , ai_rules = Just (nr_wanted, rules) }) cont 1845 | nr_wanted == 0 || no_more_args 1846 , let info' = info { ai_rules = Nothing } 1847 = -- We've accumulated a simplified call in <fun,rev_args> 1848 -- so try rewrite rules; see Note [RULEs apply to simplified arguments] 1849 -- See also Note [Rules for recursive functions] 1850 do { mb_match <- tryRules env rules fun (reverse rev_args) cont 1851 ; case mb_match of 1852 Just (env', rhs, cont') -> simplExprF env' rhs cont' 1853 Nothing -> rebuildCall env info' cont } 1854 where 1855 no_more_args = case cont of 1856 ApplyToTy {} -> False 1857 ApplyToVal {} -> False 1858 _ -> True 1859 1860 1861---------- Simplify applications and casts -------------- 1862rebuildCall env info (CastIt co cont) 1863 = rebuildCall env (addCastTo info co) cont 1864 1865rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) 1866 = rebuildCall env (addTyArgTo info arg_ty) cont 1867 1868rebuildCall env fun_info 1869 (ApplyToVal { sc_arg = arg, sc_env = arg_se 1870 , sc_dup = dup_flag, sc_cont = cont }) 1871 | isSimplified dup_flag -- See Note [Avoid redundant simplification] 1872 = rebuildCall env (addValArgTo fun_info arg) cont 1873 1874 -- Strict argument 1875 | isStrictArgInfo fun_info 1876 , sm_case_case (getMode env) 1877 = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ 1878 simplExprF (arg_se `setInScopeFromE` env) arg 1879 (StrictArg { sc_fun = fun_info 1880 , sc_dup = Simplified, sc_cont = cont }) 1881 -- Note [Shadowing] 1882 1883 | otherwise -- Lazy argument 1884 -- DO NOT float anything outside, hence simplExprC 1885 -- There is no benefit (unlike in a let-binding), and we'd 1886 -- have to be very careful about bogus strictness through 1887 -- floating a demanded let. 1888 = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg 1889 (mkLazyArgStop arg_ty (lazyArgContext fun_info)) 1890 ; rebuildCall env (addValArgTo fun_info arg') cont } 1891 where 1892 fun_ty = ai_type fun_info 1893 arg_ty = funArgTy fun_ty 1894 1895 1896---------- No further useful info, revert to generic rebuild ------------ 1897rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont 1898 = rebuild env (argInfoExpr fun rev_args) cont 1899 1900{- Note [Trying rewrite rules] 1901~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1902Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet 1903simplified. We want to simplify enough arguments to allow the rules 1904to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone 1905is sufficient. Example: class ops 1906 (+) dNumInt e2 e3 1907If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the 1908latter's strictness when simplifying e2, e3. Moreover, suppose we have 1909 RULE f Int = \x. x True 1910 1911Then given (f Int e1) we rewrite to 1912 (\x. x True) e1 1913without simplifying e1. Now we can inline x into its unique call site, 1914and absorb the True into it all in the same pass. If we simplified 1915e1 first, we couldn't do that; see Note [Avoiding exponential behaviour]. 1916 1917So we try to apply rules if either 1918 (a) no_more_args: we've run out of argument that the rules can "see" 1919 (b) nr_wanted: none of the rules wants any more arguments 1920 1921 1922Note [RULES apply to simplified arguments] 1923~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1924It's very desirable to try RULES once the arguments have been simplified, because 1925doing so ensures that rule cascades work in one pass. Consider 1926 {-# RULES g (h x) = k x 1927 f (k x) = x #-} 1928 ...f (g (h x))... 1929Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If 1930we match f's rules against the un-simplified RHS, it won't match. This 1931makes a particularly big difference when superclass selectors are involved: 1932 op ($p1 ($p2 (df d))) 1933We want all this to unravel in one sweep. 1934 1935Note [Avoid redundant simplification] 1936~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1937Because RULES apply to simplified arguments, there's a danger of repeatedly 1938simplifying already-simplified arguments. An important example is that of 1939 (>>=) d e1 e2 1940Here e1, e2 are simplified before the rule is applied, but don't really 1941participate in the rule firing. So we mark them as Simplified to avoid 1942re-simplifying them. 1943 1944Note [Shadowing] 1945~~~~~~~~~~~~~~~~ 1946This part of the simplifier may break the no-shadowing invariant 1947Consider 1948 f (...(\a -> e)...) (case y of (a,b) -> e') 1949where f is strict in its second arg 1950If we simplify the innermost one first we get (...(\a -> e)...) 1951Simplifying the second arg makes us float the case out, so we end up with 1952 case y of (a,b) -> f (...(\a -> e)...) e' 1953So the output does not have the no-shadowing invariant. However, there is 1954no danger of getting name-capture, because when the first arg was simplified 1955we used an in-scope set that at least mentioned all the variables free in its 1956static environment, and that is enough. 1957 1958We can't just do innermost first, or we'd end up with a dual problem: 1959 case x of (a,b) -> f e (...(\a -> e')...) 1960 1961I spent hours trying to recover the no-shadowing invariant, but I just could 1962not think of an elegant way to do it. The simplifier is already knee-deep in 1963continuations. We have to keep the right in-scope set around; AND we have 1964to get the effect that finding (error "foo") in a strict arg position will 1965discard the entire application and replace it with (error "foo"). Getting 1966all this at once is TOO HARD! 1967 1968 1969************************************************************************ 1970* * 1971 Rewrite rules 1972* * 1973************************************************************************ 1974-} 1975 1976tryRules :: SimplEnv -> [CoreRule] 1977 -> Id -> [ArgSpec] 1978 -> SimplCont 1979 -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) 1980 1981tryRules env rules fn args call_cont 1982 | null rules 1983 = return Nothing 1984 1985{- Disabled until we fix #8326 1986 | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#] 1987 , [_type_arg, val_arg] <- args 1988 , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont 1989 , isDeadBinder bndr 1990 = do { let enum_to_tag :: CoreAlt -> CoreAlt 1991 -- Takes K -> e into tagK# -> e 1992 -- where tagK# is the tag of constructor K 1993 enum_to_tag (DataAlt con, [], rhs) 1994 = ASSERT( isEnumerationTyCon (dataConTyCon con) ) 1995 (LitAlt tag, [], rhs) 1996 where 1997 tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG)) 1998 enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) 1999 2000 new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts 2001 new_bndr = setIdType bndr intPrimTy 2002 -- The binder is dead, but should have the right type 2003 ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } 2004-} 2005 2006 | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env) 2007 (activeRule (getMode env)) fn 2008 (argInfoAppArgs args) rules 2009 -- Fire a rule for the function 2010 = do { checkedTick (RuleFired (ruleName rule)) 2011 ; let cont' = pushSimplifiedArgs zapped_env 2012 (drop (ruleArity rule) args) 2013 call_cont 2014 -- (ruleArity rule) says how 2015 -- many args the rule consumed 2016 2017 occ_anald_rhs = occurAnalyseExpr rule_rhs 2018 -- See Note [Occurrence-analyse after rule firing] 2019 ; dump rule rule_rhs 2020 ; return (Just (zapped_env, occ_anald_rhs, cont')) } 2021 -- The occ_anald_rhs and cont' are all Out things 2022 -- hence zapping the environment 2023 2024 | otherwise -- No rule fires 2025 = do { nodump -- This ensures that an empty file is written 2026 ; return Nothing } 2027 2028 where 2029 dflags = seDynFlags env 2030 zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] 2031 2032 printRuleModule rule 2033 = parens (maybe (text "BUILTIN") 2034 (pprModuleName . moduleName) 2035 (ruleModule rule)) 2036 2037 dump rule rule_rhs 2038 | dopt Opt_D_dump_rule_rewrites dflags 2039 = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat 2040 [ text "Rule:" <+> ftext (ruleName rule) 2041 , text "Module:" <+> printRuleModule rule 2042 , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) 2043 , text "After: " <+> pprCoreExpr rule_rhs 2044 , text "Cont: " <+> ppr call_cont ] 2045 2046 | dopt Opt_D_dump_rule_firings dflags 2047 = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ 2048 ftext (ruleName rule) 2049 <+> printRuleModule rule 2050 2051 | otherwise 2052 = return () 2053 2054 nodump 2055 | dopt Opt_D_dump_rule_rewrites dflags 2056 = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty 2057 2058 | dopt Opt_D_dump_rule_firings dflags 2059 = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_firings "" empty 2060 2061 | otherwise 2062 = return () 2063 2064 log_rule dflags flag hdr details 2065 = liftIO . dumpSDoc dflags alwaysQualify flag "" $ 2066 sep [text hdr, nest 4 details] 2067 2068trySeqRules :: SimplEnv 2069 -> OutExpr -> InExpr -- Scrutinee and RHS 2070 -> SimplCont 2071 -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) 2072-- See Note [User-defined RULES for seq] 2073trySeqRules in_env scrut rhs cont 2074 = do { rule_base <- getSimplRules 2075 ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } 2076 where 2077 no_cast_scrut = drop_casts scrut 2078 scrut_ty = exprType no_cast_scrut 2079 seq_id_ty = idType seqId 2080 res1_ty = piResultTy seq_id_ty rhs_rep 2081 res2_ty = piResultTy res1_ty scrut_ty 2082 rhs_ty = substTy in_env (exprType rhs) 2083 rhs_rep = getRuntimeRep rhs_ty 2084 out_args = [ TyArg { as_arg_ty = rhs_rep 2085 , as_hole_ty = seq_id_ty } 2086 , TyArg { as_arg_ty = scrut_ty 2087 , as_hole_ty = res1_ty } 2088 , TyArg { as_arg_ty = rhs_ty 2089 , as_hole_ty = res2_ty } 2090 , ValArg { as_arg = no_cast_scrut 2091 , as_dmd = seqDmd } ] 2092 rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs 2093 , sc_env = in_env, sc_cont = cont } 2094 -- Lazily evaluated, so we don't do most of this 2095 2096 drop_casts (Cast e _) = drop_casts e 2097 drop_casts e = e 2098 2099{- Note [User-defined RULES for seq] 2100~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2101Given 2102 case (scrut |> co) of _ -> rhs 2103look for rules that match the expression 2104 seq @t1 @t2 scrut 2105where scrut :: t1 2106 rhs :: t2 2107 2108If you find a match, rewrite it, and apply to 'rhs'. 2109 2110Notice that we can simply drop casts on the fly here, which 2111makes it more likely that a rule will match. 2112 2113See Note [User-defined RULES for seq] in MkId. 2114 2115Note [Occurrence-analyse after rule firing] 2116~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2117After firing a rule, we occurrence-analyse the instantiated RHS before 2118simplifying it. Usually this doesn't make much difference, but it can 2119be huge. Here's an example (simplCore/should_compile/T7785) 2120 2121 map f (map f (map f xs) 2122 2123= -- Use build/fold form of map, twice 2124 map f (build (\cn. foldr (mapFB c f) n 2125 (build (\cn. foldr (mapFB c f) n xs)))) 2126 2127= -- Apply fold/build rule 2128 map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) 2129 2130= -- Beta-reduce 2131 -- Alas we have no occurrence-analysed, so we don't know 2132 -- that c is used exactly once 2133 map f (build (\cn. let c1 = mapFB c f in 2134 foldr (mapFB c1 f) n xs)) 2135 2136= -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) 2137 -- We can do this because (mapFB c n) is a PAP and hence expandable 2138 map f (build (\cn. let c1 = mapFB c n in 2139 foldr (mapFB c (f.f)) n x)) 2140 2141This is not too bad. But now do the same with the outer map, and 2142we get another use of mapFB, and t can interact with /both/ remaining 2143mapFB calls in the above expression. This is stupid because actually 2144that 'c1' binding is dead. The outer map introduces another c2. If 2145there is a deep stack of maps we get lots of dead bindings, and lots 2146of redundant work as we repeatedly simplify the result of firing rules. 2147 2148The easy thing to do is simply to occurrence analyse the result of 2149the rule firing. Note that this occ-anals not only the RHS of the 2150rule, but also the function arguments, which by now are OutExprs. 2151E.g. 2152 RULE f (g x) = x+1 2153 2154Call f (g BIG) --> (\x. x+1) BIG 2155 2156The rule binders are lambda-bound and applied to the OutExpr arguments 2157(here BIG) which lack all internal occurrence info. 2158 2159Is this inefficient? Not really: we are about to walk over the result 2160of the rule firing to simplify it, so occurrence analysis is at most 2161a constant factor. 2162 2163Possible improvement: occ-anal the rules when putting them in the 2164database; and in the simplifier just occ-anal the OutExpr arguments. 2165But that's more complicated and the rule RHS is usually tiny; so I'm 2166just doing the simple thing. 2167 2168Historical note: previously we did occ-anal the rules in Rule.hs, 2169but failed to occ-anal the OutExpr arguments, which led to the 2170nasty performance problem described above. 2171 2172 2173Note [Optimising tagToEnum#] 2174~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2175If we have an enumeration data type: 2176 2177 data Foo = A | B | C 2178 2179Then we want to transform 2180 2181 case tagToEnum# x of ==> case x of 2182 A -> e1 DEFAULT -> e1 2183 B -> e2 1# -> e2 2184 C -> e3 2# -> e3 2185 2186thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT 2187alternative we retain it (remember it comes first). If not the case must 2188be exhaustive, and we reflect that in the transformed version by adding 2189a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. 2190See #8317. 2191 2192Note [Rules for recursive functions] 2193~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2194You might think that we shouldn't apply rules for a loop breaker: 2195doing so might give rise to an infinite loop, because a RULE is 2196rather like an extra equation for the function: 2197 RULE: f (g x) y = x+y 2198 Eqn: f a y = a-y 2199 2200But it's too drastic to disable rules for loop breakers. 2201Even the foldr/build rule would be disabled, because foldr 2202is recursive, and hence a loop breaker: 2203 foldr k z (build g) = g k z 2204So it's up to the programmer: rules can cause divergence 2205 2206 2207************************************************************************ 2208* * 2209 Rebuilding a case expression 2210* * 2211************************************************************************ 2212 2213Note [Case elimination] 2214~~~~~~~~~~~~~~~~~~~~~~~ 2215The case-elimination transformation discards redundant case expressions. 2216Start with a simple situation: 2217 2218 case x# of ===> let y# = x# in e 2219 y# -> e 2220 2221(when x#, y# are of primitive type, of course). We can't (in general) 2222do this for algebraic cases, because we might turn bottom into 2223non-bottom! 2224 2225The code in SimplUtils.prepareAlts has the effect of generalise this 2226idea to look for a case where we're scrutinising a variable, and we 2227know that only the default case can match. For example: 2228 2229 case x of 2230 0# -> ... 2231 DEFAULT -> ...(case x of 2232 0# -> ... 2233 DEFAULT -> ...) ... 2234 2235Here the inner case is first trimmed to have only one alternative, the 2236DEFAULT, after which it's an instance of the previous case. This 2237really only shows up in eliminating error-checking code. 2238 2239Note that SimplUtils.mkCase combines identical RHSs. So 2240 2241 case e of ===> case e of DEFAULT -> r 2242 True -> r 2243 False -> r 2244 2245Now again the case may be elminated by the CaseElim transformation. 2246This includes things like (==# a# b#)::Bool so that we simplify 2247 case ==# a# b# of { True -> x; False -> x } 2248to just 2249 x 2250This particular example shows up in default methods for 2251comparison operations (e.g. in (>=) for Int.Int32) 2252 2253Note [Case to let transformation] 2254~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2255If a case over a lifted type has a single alternative, and is being 2256used as a strict 'let' (all isDeadBinder bndrs), we may want to do 2257this transformation: 2258 2259 case e of r ===> let r = e in ...r... 2260 _ -> ...r... 2261 2262We treat the unlifted and lifted cases separately: 2263 2264* Unlifted case: 'e' satisfies exprOkForSpeculation 2265 (ok-for-spec is needed to satisfy the let/app invariant). 2266 This turns case a +# b of r -> ...r... 2267 into let r = a +# b in ...r... 2268 and thence .....(a +# b).... 2269 2270 However, if we have 2271 case indexArray# a i of r -> ...r... 2272 we might like to do the same, and inline the (indexArray# a i). 2273 But indexArray# is not okForSpeculation, so we don't build a let 2274 in rebuildCase (lest it get floated *out*), so the inlining doesn't 2275 happen either. Annoying. 2276 2277* Lifted case: we need to be sure that the expression is already 2278 evaluated (exprIsHNF). If it's not already evaluated 2279 - we risk losing exceptions, divergence or 2280 user-specified thunk-forcing 2281 - even if 'e' is guaranteed to converge, we don't want to 2282 create a thunk (call by need) instead of evaluating it 2283 right away (call by value) 2284 2285 However, we can turn the case into a /strict/ let if the 'r' is 2286 used strictly in the body. Then we won't lose divergence; and 2287 we won't build a thunk because the let is strict. 2288 See also Note [Case-to-let for strictly-used binders] 2289 2290 NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore. 2291 We want to turn 2292 case (absentError "foo") of r -> ...MkT r... 2293 into 2294 let r = absentError "foo" in ...MkT r... 2295 2296 2297Note [Case-to-let for strictly-used binders] 2298~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2299If we have this: 2300 case <scrut> of r { _ -> ..r.. } 2301 2302where 'r' is used strictly in (..r..), we can safely transform to 2303 let r = <scrut> in ...r... 2304 2305This is a Good Thing, because 'r' might be dead (if the body just 2306calls error), or might be used just once (in which case it can be 2307inlined); or we might be able to float the let-binding up or down. 2308E.g. #15631 has an example. 2309 2310Note that this can change the error behaviour. For example, we might 2311transform 2312 case x of { _ -> error "bad" } 2313 --> error "bad" 2314which is might be puzzling if 'x' currently lambda-bound, but later gets 2315let-bound to (error "good"). 2316 2317Nevertheless, the paper "A semantics for imprecise exceptions" allows 2318this transformation. If you want to fix the evaluation order, use 2319'pseq'. See #8900 for an example where the loss of this 2320transformation bit us in practice. 2321 2322See also Note [Empty case alternatives] in CoreSyn. 2323 2324Historical notes 2325 2326There have been various earlier versions of this patch: 2327 2328* By Sept 18 the code looked like this: 2329 || scrut_is_demanded_var scrut 2330 2331 scrut_is_demanded_var :: CoreExpr -> Bool 2332 scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s 2333 scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr) 2334 scrut_is_demanded_var _ = False 2335 2336 This only fired if the scrutinee was a /variable/, which seems 2337 an unnecessary restriction. So in #15631 I relaxed it to allow 2338 arbitrary scrutinees. Less code, less to explain -- but the change 2339 had 0.00% effect on nofib. 2340 2341* Previously, in Jan 13 the code looked like this: 2342 || case_bndr_evald_next rhs 2343 2344 case_bndr_evald_next :: CoreExpr -> Bool 2345 -- See Note [Case binder next] 2346 case_bndr_evald_next (Var v) = v == case_bndr 2347 case_bndr_evald_next (Cast e _) = case_bndr_evald_next e 2348 case_bndr_evald_next (App e _) = case_bndr_evald_next e 2349 case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e 2350 case_bndr_evald_next _ = False 2351 2352 This patch was part of fixing #7542. See also 2353 Note [Eta reduction of an eval'd function] in CoreUtils.) 2354 2355 2356Further notes about case elimination 2357~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2358Consider: test :: Integer -> IO () 2359 test = print 2360 2361Turns out that this compiles to: 2362 Print.test 2363 = \ eta :: Integer 2364 eta1 :: Void# -> 2365 case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> 2366 case hPutStr stdout 2367 (PrelNum.jtos eta ($w[] @ Char)) 2368 eta1 2369 of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} 2370 2371Notice the strange '<' which has no effect at all. This is a funny one. 2372It started like this: 2373 2374f x y = if x < 0 then jtos x 2375 else if y==0 then "" else jtos x 2376 2377At a particular call site we have (f v 1). So we inline to get 2378 2379 if v < 0 then jtos x 2380 else if 1==0 then "" else jtos x 2381 2382Now simplify the 1==0 conditional: 2383 2384 if v<0 then jtos v else jtos v 2385 2386Now common-up the two branches of the case: 2387 2388 case (v<0) of DEFAULT -> jtos v 2389 2390Why don't we drop the case? Because it's strict in v. It's technically 2391wrong to drop even unnecessary evaluations, and in practice they 2392may be a result of 'seq' so we *definitely* don't want to drop those. 2393I don't really know how to improve this situation. 2394 2395 2396Note [FloatBinds from constructor wrappers] 2397~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2398If we have FloatBinds coming from the constructor wrapper 2399(as in Note [exprIsConApp_maybe on data constructors with wrappers]), 2400ew cannot float past them. We'd need to float the FloatBind 2401together with the simplify floats, unfortunately the 2402simplifier doesn't have case-floats. The simplest thing we can 2403do is to wrap all the floats here. The next iteration of the 2404simplifier will take care of all these cases and lets. 2405 2406Given data T = MkT !Bool, this allows us to simplify 2407case $WMkT b of { MkT x -> f x } 2408to 2409case b of { b' -> f b' }. 2410 2411We could try and be more clever (like maybe wfloats only contain 2412let binders, so we could float them). But the need for the 2413extra complication is not clear. 2414-} 2415 2416--------------------------------------------------------- 2417-- Eliminate the case if possible 2418 2419rebuildCase, reallyRebuildCase 2420 :: SimplEnv 2421 -> OutExpr -- Scrutinee 2422 -> InId -- Case binder 2423 -> [InAlt] -- Alternatives (increasing order) 2424 -> SimplCont 2425 -> SimplM (SimplFloats, OutExpr) 2426 2427-------------------------------------------------- 2428-- 1. Eliminate the case if there's a known constructor 2429-------------------------------------------------- 2430 2431rebuildCase env scrut case_bndr alts cont 2432 | Lit lit <- scrut -- No need for same treatment as constructors 2433 -- because literals are inlined more vigorously 2434 , not (litIsLifted lit) 2435 = do { tick (KnownBranch case_bndr) 2436 ; case findAlt (LitAlt lit) alts of 2437 Nothing -> missingAlt env case_bndr alts cont 2438 Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs } 2439 2440 | Just (in_scope', wfloats, con, ty_args, other_args) 2441 <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut 2442 -- Works when the scrutinee is a variable with a known unfolding 2443 -- as well as when it's an explicit constructor application 2444 , let env0 = setInScopeSet env in_scope' 2445 = do { tick (KnownBranch case_bndr) 2446 ; case findAlt (DataAlt con) alts of 2447 Nothing -> missingAlt env0 case_bndr alts cont 2448 Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con) 2449 `mkTyApps` ty_args 2450 `mkApps` other_args 2451 in simple_rhs env0 wfloats con_app bs rhs 2452 Just (_, bs, rhs) -> knownCon env0 scrut wfloats con ty_args other_args 2453 case_bndr bs rhs cont 2454 } 2455 where 2456 simple_rhs env wfloats scrut' bs rhs = 2457 ASSERT( null bs ) 2458 do { (floats1, env') <- simplNonRecX env case_bndr scrut' 2459 -- scrut is a constructor application, 2460 -- hence satisfies let/app invariant 2461 ; (floats2, expr') <- simplExprF env' rhs cont 2462 ; case wfloats of 2463 [] -> return (floats1 `addFloats` floats2, expr') 2464 _ -> return 2465 -- See Note [FloatBinds from constructor wrappers] 2466 ( emptyFloats env, 2467 MkCore.wrapFloats wfloats $ 2468 wrapFloats (floats1 `addFloats` floats2) expr' )} 2469 2470 2471-------------------------------------------------- 2472-- 2. Eliminate the case if scrutinee is evaluated 2473-------------------------------------------------- 2474 2475rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont 2476 -- See if we can get rid of the case altogether 2477 -- See Note [Case elimination] 2478 -- mkCase made sure that if all the alternatives are equal, 2479 -- then there is now only one (DEFAULT) rhs 2480 2481 -- 2a. Dropping the case altogether, if 2482 -- a) it binds nothing (so it's really just a 'seq') 2483 -- b) evaluating the scrutinee has no side effects 2484 | is_plain_seq 2485 , exprOkForSideEffects scrut 2486 -- The entire case is dead, so we can drop it 2487 -- if the scrutinee converges without having imperative 2488 -- side effects or raising a Haskell exception 2489 -- See Note [PrimOp can_fail and has_side_effects] in PrimOp 2490 = simplExprF env rhs cont 2491 2492 -- 2b. Turn the case into a let, if 2493 -- a) it binds only the case-binder 2494 -- b) unlifted case: the scrutinee is ok-for-speculation 2495 -- lifted case: the scrutinee is in HNF (or will later be demanded) 2496 -- See Note [Case to let transformation] 2497 | all_dead_bndrs 2498 , doCaseToLet scrut case_bndr 2499 = do { tick (CaseElim case_bndr) 2500 ; (floats1, env') <- simplNonRecX env case_bndr scrut 2501 ; (floats2, expr') <- simplExprF env' rhs cont 2502 ; return (floats1 `addFloats` floats2, expr') } 2503 2504 -- 2c. Try the seq rules if 2505 -- a) it binds only the case binder 2506 -- b) a rule for seq applies 2507 -- See Note [User-defined RULES for seq] in MkId 2508 | is_plain_seq 2509 = do { mb_rule <- trySeqRules env scrut rhs cont 2510 ; case mb_rule of 2511 Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' 2512 Nothing -> reallyRebuildCase env scrut case_bndr alts cont } 2513 where 2514 all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] 2515 is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect 2516 2517rebuildCase env scrut case_bndr alts cont 2518 = reallyRebuildCase env scrut case_bndr alts cont 2519 2520 2521doCaseToLet :: OutExpr -- Scrutinee 2522 -> InId -- Case binder 2523 -> Bool 2524-- The situation is case scrut of b { DEFAULT -> body } 2525-- Can we transform thus? let { b = scrut } in body 2526doCaseToLet scrut case_bndr 2527 | isTyCoVar case_bndr -- Respect CoreSyn 2528 = isTyCoArg scrut -- Note [CoreSyn type and coercion invariant] 2529 2530 | isUnliftedType (idType case_bndr) 2531 = exprOkForSpeculation scrut 2532 2533 | otherwise -- Scrut has a lifted type 2534 = exprIsHNF scrut 2535 || isStrictDmd (idDemandInfo case_bndr) 2536 -- See Note [Case-to-let for strictly-used binders] 2537 2538-------------------------------------------------- 2539-- 3. Catch-all case 2540-------------------------------------------------- 2541 2542reallyRebuildCase env scrut case_bndr alts cont 2543 | not (sm_case_case (getMode env)) 2544 = do { case_expr <- simplAlts env scrut case_bndr alts 2545 (mkBoringStop (contHoleType cont)) 2546 ; rebuild env case_expr cont } 2547 2548 | otherwise 2549 = do { (floats, cont') <- mkDupableCaseCont env alts cont 2550 ; case_expr <- simplAlts (env `setInScopeFromF` floats) 2551 scrut case_bndr alts cont' 2552 ; return (floats, case_expr) } 2553 2554{- 2555simplCaseBinder checks whether the scrutinee is a variable, v. If so, 2556try to eliminate uses of v in the RHSs in favour of case_bndr; that 2557way, there's a chance that v will now only be used once, and hence 2558inlined. 2559 2560Historical note: we use to do the "case binder swap" in the Simplifier 2561so there were additional complications if the scrutinee was a variable. 2562Now the binder-swap stuff is done in the occurrence analyser; see 2563OccurAnal Note [Binder swap]. 2564 2565Note [knownCon occ info] 2566~~~~~~~~~~~~~~~~~~~~~~~~ 2567If the case binder is not dead, then neither are the pattern bound 2568variables: 2569 case <any> of x { (a,b) -> 2570 case x of { (p,q) -> p } } 2571Here (a,b) both look dead, but come alive after the inner case is eliminated. 2572The point is that we bring into the envt a binding 2573 let x = (a,b) 2574after the outer case, and that makes (a,b) alive. At least we do unless 2575the case binder is guaranteed dead. 2576 2577Note [Case alternative occ info] 2578~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2579When we are simply reconstructing a case (the common case), we always 2580zap the occurrence info on the binders in the alternatives. Even 2581if the case binder is dead, the scrutinee is usually a variable, and *that* 2582can bring the case-alternative binders back to life. 2583See Note [Add unfolding for scrutinee] 2584 2585Note [Improving seq] 2586~~~~~~~~~~~~~~~~~~~ 2587Consider 2588 type family F :: * -> * 2589 type instance F Int = Int 2590 2591We'd like to transform 2592 case e of (x :: F Int) { DEFAULT -> rhs } 2593===> 2594 case e `cast` co of (x'::Int) 2595 I# x# -> let x = x' `cast` sym co 2596 in rhs 2597 2598so that 'rhs' can take advantage of the form of x'. Notice that Note 2599[Case of cast] (in OccurAnal) may then apply to the result. 2600 2601We'd also like to eliminate empty types (#13468). So if 2602 2603 data Void 2604 type instance F Bool = Void 2605 2606then we'd like to transform 2607 case (x :: F Bool) of { _ -> error "urk" } 2608===> 2609 case (x |> co) of (x' :: Void) of {} 2610 2611Nota Bene: we used to have a built-in rule for 'seq' that dropped 2612casts, so that 2613 case (x |> co) of { _ -> blah } 2614dropped the cast; in order to improve the chances of trySeqRules 2615firing. But that works in the /opposite/ direction to Note [Improving 2616seq] so there's a danger of flip/flopping. Better to make trySeqRules 2617insensitive to the cast, which is now is. 2618 2619The need for [Improving seq] showed up in Roman's experiments. Example: 2620 foo :: F Int -> Int -> Int 2621 foo t n = t `seq` bar n 2622 where 2623 bar 0 = 0 2624 bar n = bar (n - case t of TI i -> i) 2625Here we'd like to avoid repeated evaluating t inside the loop, by 2626taking advantage of the `seq`. 2627 2628At one point I did transformation in LiberateCase, but it's more 2629robust here. (Otherwise, there's a danger that we'll simply drop the 2630'seq' altogether, before LiberateCase gets to see it.) 2631-} 2632 2633simplAlts :: SimplEnv 2634 -> OutExpr -- Scrutinee 2635 -> InId -- Case binder 2636 -> [InAlt] -- Non-empty 2637 -> SimplCont 2638 -> SimplM OutExpr -- Returns the complete simplified case expression 2639 2640simplAlts env0 scrut case_bndr alts cont' 2641 = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr 2642 , text "cont':" <+> ppr cont' 2643 , text "in_scope" <+> ppr (seInScope env0) ]) 2644 ; (env1, case_bndr1) <- simplBinder env0 case_bndr 2645 ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding 2646 env2 = modifyInScope env1 case_bndr2 2647 -- See Note [Case binder evaluated-ness] 2648 2649 ; fam_envs <- getFamEnvs 2650 ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut 2651 case_bndr case_bndr2 alts 2652 2653 ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts 2654 -- NB: it's possible that the returned in_alts is empty: this is handled 2655 -- by the caller (rebuildCase) in the missingAlt function 2656 2657 ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts 2658 ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $ 2659 2660 ; let alts_ty' = contResultType cont' 2661 -- See Note [Avoiding space leaks in OutType] 2662 ; seqType alts_ty' `seq` 2663 mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' } 2664 2665 2666------------------------------------ 2667improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv 2668 -> OutExpr -> InId -> OutId -> [InAlt] 2669 -> SimplM (SimplEnv, OutExpr, OutId) 2670-- Note [Improving seq] 2671improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] 2672 | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) 2673 = do { case_bndr2 <- newId (fsLit "nt") ty2 2674 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing 2675 env2 = extendIdSubst env case_bndr rhs 2676 ; return (env2, scrut `Cast` co, case_bndr2) } 2677 2678improveSeq _ env scrut _ case_bndr1 _ 2679 = return (env, scrut, case_bndr1) 2680 2681 2682------------------------------------ 2683simplAlt :: SimplEnv 2684 -> Maybe OutExpr -- The scrutinee 2685 -> [AltCon] -- These constructors can't be present when 2686 -- matching the DEFAULT alternative 2687 -> OutId -- The case binder 2688 -> SimplCont 2689 -> InAlt 2690 -> SimplM OutAlt 2691 2692simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs) 2693 = ASSERT( null bndrs ) 2694 do { let env' = addBinderUnfolding env case_bndr' 2695 (mkOtherCon imposs_deflt_cons) 2696 -- Record the constructors that the case-binder *can't* be. 2697 ; rhs' <- simplExprC env' rhs cont' 2698 ; return (DEFAULT, [], rhs') } 2699 2700simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs) 2701 = ASSERT( null bndrs ) 2702 do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) 2703 ; rhs' <- simplExprC env' rhs cont' 2704 ; return (LitAlt lit, [], rhs') } 2705 2706simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs) 2707 = do { -- See Note [Adding evaluatedness info to pattern-bound variables] 2708 let vs_with_evals = addEvals scrut' con vs 2709 ; (env', vs') <- simplLamBndrs env vs_with_evals 2710 2711 -- Bind the case-binder to (con args) 2712 ; let inst_tys' = tyConAppArgs (idType case_bndr') 2713 con_app :: OutExpr 2714 con_app = mkConApp2 con inst_tys' vs' 2715 2716 ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app 2717 ; rhs' <- simplExprC env'' rhs cont' 2718 ; return (DataAlt con, vs', rhs') } 2719 2720{- Note [Adding evaluatedness info to pattern-bound variables] 2721~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2722addEvals records the evaluated-ness of the bound variables of 2723a case pattern. This is *important*. Consider 2724 2725 data T = T !Int !Int 2726 2727 case x of { T a b -> T (a+1) b } 2728 2729We really must record that b is already evaluated so that we don't 2730go and re-evaluate it when constructing the result. 2731See Note [Data-con worker strictness] in MkId.hs 2732 2733NB: simplLamBinders preserves this eval info 2734 2735In addition to handling data constructor fields with !s, addEvals 2736also records the fact that the result of seq# is always in WHNF. 2737See Note [seq# magic] in PrelRules. Example (#15226): 2738 2739 case seq# v s of 2740 (# s', v' #) -> E 2741 2742we want the compiler to be aware that v' is in WHNF in E. 2743 2744Open problem: we don't record that v itself is in WHNF (and we can't 2745do it here). The right thing is to do some kind of binder-swap; 2746see #15226 for discussion. 2747-} 2748 2749addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id] 2750-- See Note [Adding evaluatedness info to pattern-bound variables] 2751addEvals scrut con vs 2752 -- Deal with seq# applications 2753 | Just scr <- scrut 2754 , isUnboxedTupleCon con 2755 , [s,x] <- vs 2756 -- Use stripNArgs rather than collectArgsTicks to avoid building 2757 -- a list of arguments only to throw it away immediately. 2758 , Just (Var f) <- stripNArgs 4 scr 2759 , Just SeqOp <- isPrimOpId_maybe f 2760 , let x' = zapIdOccInfoAndSetEvald MarkedStrict x 2761 = [s, x'] 2762 2763 -- Deal with banged datacon fields 2764addEvals _scrut con vs = go vs the_strs 2765 where 2766 the_strs = dataConRepStrictness con 2767 2768 go [] [] = [] 2769 go (v:vs') strs | isTyVar v = v : go vs' strs 2770 go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs 2771 go _ _ = pprPanic "Simplify.addEvals" 2772 (ppr con $$ 2773 ppr vs $$ 2774 ppr_with_length (map strdisp the_strs) $$ 2775 ppr_with_length (dataConRepArgTys con) $$ 2776 ppr_with_length (dataConRepStrictness con)) 2777 where 2778 ppr_with_length list 2779 = ppr list <+> parens (text "length =" <+> ppr (length list)) 2780 strdisp MarkedStrict = "MarkedStrict" 2781 strdisp NotMarkedStrict = "NotMarkedStrict" 2782 2783zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id 2784zapIdOccInfoAndSetEvald str v = 2785 setCaseBndrEvald str $ -- Add eval'dness info 2786 zapIdOccInfo v -- And kill occ info; 2787 -- see Note [Case alternative occ info] 2788 2789addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv 2790addAltUnfoldings env scrut case_bndr con_app 2791 = do { let con_app_unf = mk_simple_unf con_app 2792 env1 = addBinderUnfolding env case_bndr con_app_unf 2793 2794 -- See Note [Add unfolding for scrutinee] 2795 env2 = case scrut of 2796 Just (Var v) -> addBinderUnfolding env1 v con_app_unf 2797 Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ 2798 mk_simple_unf (Cast con_app (mkSymCo co)) 2799 _ -> env1 2800 2801 ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) 2802 ; return env2 } 2803 where 2804 mk_simple_unf = mkSimpleUnfolding (seDynFlags env) 2805 2806addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv 2807addBinderUnfolding env bndr unf 2808 | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf 2809 = WARN( not (eqType (idType bndr) (exprType tmpl)), 2810 ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) ) 2811 modifyInScope env (bndr `setIdUnfolding` unf) 2812 2813 | otherwise 2814 = modifyInScope env (bndr `setIdUnfolding` unf) 2815 2816zapBndrOccInfo :: Bool -> Id -> Id 2817-- Consider case e of b { (a,b) -> ... } 2818-- Then if we bind b to (a,b) in "...", and b is not dead, 2819-- then we must zap the deadness info on a,b 2820zapBndrOccInfo keep_occ_info pat_id 2821 | keep_occ_info = pat_id 2822 | otherwise = zapIdOccInfo pat_id 2823 2824{- Note [Case binder evaluated-ness] 2825~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2826We pin on a (OtherCon []) unfolding to the case-binder of a Case, 2827even though it'll be over-ridden in every case alternative with a more 2828informative unfolding. Why? Because suppose a later, less clever, pass 2829simply replaces all occurrences of the case binder with the binder itself; 2830then Lint may complain about the let/app invariant. Example 2831 case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in .... 2832 ; K -> blah } 2833 2834The let/app invariant requires that y is evaluated in the call to 2835reallyUnsafePtrEq#, which it is. But we still want that to be true if we 2836propagate binders to occurrences. 2837 2838This showed up in #13027. 2839 2840Note [Add unfolding for scrutinee] 2841~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2842In general it's unlikely that a variable scrutinee will appear 2843in the case alternatives case x of { ...x unlikely to appear... } 2844because the binder-swap in OccAnal has got rid of all such occurrences 2845See Note [Binder swap] in OccAnal. 2846 2847BUT it is still VERY IMPORTANT to add a suitable unfolding for a 2848variable scrutinee, in simplAlt. Here's why 2849 case x of y 2850 (a,b) -> case b of c 2851 I# v -> ...(f y)... 2852There is no occurrence of 'b' in the (...(f y)...). But y gets 2853the unfolding (a,b), and *that* mentions b. If f has a RULE 2854 RULE f (p, I# q) = ... 2855we want that rule to match, so we must extend the in-scope env with a 2856suitable unfolding for 'y'. It's *essential* for rule matching; but 2857it's also good for case-elimintation -- suppose that 'f' was inlined 2858and did multi-level case analysis, then we'd solve it in one 2859simplifier sweep instead of two. 2860 2861Exactly the same issue arises in SpecConstr; 2862see Note [Add scrutinee to ValueEnv too] in SpecConstr 2863 2864HOWEVER, given 2865 case x of y { Just a -> r1; Nothing -> r2 } 2866we do not want to add the unfolding x -> y to 'x', which might seem cool, 2867since 'y' itself has different unfoldings in r1 and r2. Reason: if we 2868did that, we'd have to zap y's deadness info and that is a very useful 2869piece of information. 2870 2871So instead we add the unfolding x -> Just a, and x -> Nothing in the 2872respective RHSs. 2873 2874 2875************************************************************************ 2876* * 2877\subsection{Known constructor} 2878* * 2879************************************************************************ 2880 2881We are a bit careful with occurrence info. Here's an example 2882 2883 (\x* -> case x of (a*, b) -> f a) (h v, e) 2884 2885where the * means "occurs once". This effectively becomes 2886 case (h v, e) of (a*, b) -> f a) 2887and then 2888 let a* = h v; b = e in f a 2889and then 2890 f (h v) 2891 2892All this should happen in one sweep. 2893-} 2894 2895knownCon :: SimplEnv 2896 -> OutExpr -- The scrutinee 2897 -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) 2898 -> InId -> [InBndr] -> InExpr -- The alternative 2899 -> SimplCont 2900 -> SimplM (SimplFloats, OutExpr) 2901 2902knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont 2903 = do { (floats1, env1) <- bind_args env bs dc_args 2904 ; (floats2, env2) <- bind_case_bndr env1 2905 ; (floats3, expr') <- simplExprF env2 rhs cont 2906 ; case dc_floats of 2907 [] -> 2908 return (floats1 `addFloats` floats2 `addFloats` floats3, expr') 2909 _ -> 2910 return ( emptyFloats env 2911 -- See Note [FloatBinds from constructor wrappers] 2912 , MkCore.wrapFloats dc_floats $ 2913 wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } 2914 where 2915 zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId 2916 2917 -- Ugh! 2918 bind_args env' [] _ = return (emptyFloats env', env') 2919 2920 bind_args env' (b:bs') (Type ty : args) 2921 = ASSERT( isTyVar b ) 2922 bind_args (extendTvSubst env' b ty) bs' args 2923 2924 bind_args env' (b:bs') (Coercion co : args) 2925 = ASSERT( isCoVar b ) 2926 bind_args (extendCvSubst env' b co) bs' args 2927 2928 bind_args env' (b:bs') (arg : args) 2929 = ASSERT( isId b ) 2930 do { let b' = zap_occ b 2931 -- Note that the binder might be "dead", because it doesn't 2932 -- occur in the RHS; and simplNonRecX may therefore discard 2933 -- it via postInlineUnconditionally. 2934 -- Nevertheless we must keep it if the case-binder is alive, 2935 -- because it may be used in the con_app. See Note [knownCon occ info] 2936 ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let/app invariant 2937 ; (floats2, env3) <- bind_args env2 bs' args 2938 ; return (floats1 `addFloats` floats2, env3) } 2939 2940 bind_args _ _ _ = 2941 pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ 2942 text "scrut:" <+> ppr scrut 2943 2944 -- It's useful to bind bndr to scrut, rather than to a fresh 2945 -- binding x = Con arg1 .. argn 2946 -- because very often the scrut is a variable, so we avoid 2947 -- creating, and then subsequently eliminating, a let-binding 2948 -- BUT, if scrut is a not a variable, we must be careful 2949 -- about duplicating the arg redexes; in that case, make 2950 -- a new con-app from the args 2951 bind_case_bndr env 2952 | isDeadBinder bndr = return (emptyFloats env, env) 2953 | exprIsTrivial scrut = return (emptyFloats env 2954 , extendIdSubst env bndr (DoneEx scrut Nothing)) 2955 | otherwise = do { dc_args <- mapM (simplVar env) bs 2956 -- dc_ty_args are aready OutTypes, 2957 -- but bs are InBndrs 2958 ; let con_app = Var (dataConWorkId dc) 2959 `mkTyApps` dc_ty_args 2960 `mkApps` dc_args 2961 ; simplNonRecX env bndr con_app } 2962 2963------------------- 2964missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont 2965 -> SimplM (SimplFloats, OutExpr) 2966 -- This isn't strictly an error, although it is unusual. 2967 -- It's possible that the simplifier might "see" that 2968 -- an inner case has no accessible alternatives before 2969 -- it "sees" that the entire branch of an outer case is 2970 -- inaccessible. So we simply put an error case here instead. 2971missingAlt env case_bndr _ cont 2972 = WARN( True, text "missingAlt" <+> ppr case_bndr ) 2973 -- See Note [Avoiding space leaks in OutType] 2974 let cont_ty = contResultType cont 2975 in seqType cont_ty `seq` 2976 return (emptyFloats env, mkImpossibleExpr cont_ty) 2977 2978{- 2979************************************************************************ 2980* * 2981\subsection{Duplicating continuations} 2982* * 2983************************************************************************ 2984 2985Consider 2986 let x* = case e of { True -> e1; False -> e2 } 2987 in b 2988where x* is a strict binding. Then mkDupableCont will be given 2989the continuation 2990 case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop 2991and will split it into 2992 dupable: case [] of { True -> $j1; False -> $j2 } ; stop 2993 join floats: $j1 = e1, $j2 = e2 2994 non_dupable: let x* = [] in b; stop 2995 2996Putting this back together would give 2997 let x* = let { $j1 = e1; $j2 = e2 } in 2998 case e of { True -> $j1; False -> $j2 } 2999 in b 3000(Of course we only do this if 'e' wants to duplicate that continuation.) 3001Note how important it is that the new join points wrap around the 3002inner expression, and not around the whole thing. 3003 3004In contrast, any let-bindings introduced by mkDupableCont can wrap 3005around the entire thing. 3006 3007Note [Bottom alternatives] 3008~~~~~~~~~~~~~~~~~~~~~~~~~~ 3009When we have 3010 case (case x of { A -> error .. ; B -> e; C -> error ..) 3011 of alts 3012then we can just duplicate those alts because the A and C cases 3013will disappear immediately. This is more direct than creating 3014join points and inlining them away. See #4930. 3015-} 3016 3017-------------------- 3018mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont 3019 -> SimplM (SimplFloats, SimplCont) 3020mkDupableCaseCont env alts cont 3021 | altsWouldDup alts = mkDupableCont env cont 3022 | otherwise = return (emptyFloats env, cont) 3023 3024altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative 3025altsWouldDup [] = False -- See Note [Bottom alternatives] 3026altsWouldDup [_] = False 3027altsWouldDup (alt:alts) 3028 | is_bot_alt alt = altsWouldDup alts 3029 | otherwise = not (all is_bot_alt alts) 3030 where 3031 is_bot_alt (_,_,rhs) = exprIsBottom rhs 3032 3033------------------------- 3034mkDupableCont :: SimplEnv 3035 -> SimplCont 3036 -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with 3037 -- extra let/join-floats and in-scope variables 3038 , SimplCont) -- dup_cont: duplicable continuation 3039mkDupableCont env cont 3040 = mkDupableContWithDmds env (repeat topDmd) cont 3041 3042mkDupableContWithDmds 3043 :: SimplEnv -> [Demand] -- Demands on arguments; always infinite 3044 -> SimplCont -> SimplM ( SimplFloats, SimplCont) 3045 3046mkDupableContWithDmds env _ cont 3047 | contIsDupable cont 3048 = return (emptyFloats env, cont) 3049 3050mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn 3051 3052mkDupableContWithDmds env dmds (CastIt ty cont) 3053 = do { (floats, cont') <- mkDupableContWithDmds env dmds cont 3054 ; return (floats, CastIt ty cont') } 3055 3056-- Duplicating ticks for now, not sure if this is good or not 3057mkDupableContWithDmds env dmds (TickIt t cont) 3058 = do { (floats, cont') <- mkDupableContWithDmds env dmds cont 3059 ; return (floats, TickIt t cont') } 3060 3061mkDupableContWithDmds env _ 3062 (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs 3063 , sc_body = body, sc_env = se, sc_cont = cont}) 3064-- See Note [Duplicating StrictBind] 3065-- K[ let x = <> in b ] --> join j x = K[ b ] 3066-- j <> 3067 = do { let sb_env = se `setInScopeFromE` env 3068 ; (sb_env1, bndr') <- simplBinder sb_env bndr 3069 ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont 3070 -- No need to use mkDupableCont before simplLam; we 3071 -- use cont once here, and then share the result if necessary 3072 3073 ; let join_body = wrapFloats floats1 join_inner 3074 res_ty = contResultType cont 3075 3076 ; mkDupableStrictBind env bndr' join_body res_ty } 3077 3078mkDupableContWithDmds env _ 3079 (StrictArg { sc_fun = fun, sc_cont = cont }) 3080 -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable 3081 | thumbsUpPlanA cont 3082 = -- Use Plan A of Note [Duplicating StrictArg] 3083 do { let (_ : dmds) = ai_dmds fun 3084 ; (floats1, cont') <- mkDupableContWithDmds env dmds cont 3085 -- Use the demands from the function to add the right 3086 -- demand info on any bindings we make for further args 3087 ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env)) 3088 (ai_args fun) 3089 ; return ( foldl' addLetFloats floats1 floats_s 3090 , StrictArg { sc_fun = fun { ai_args = args' } 3091 , sc_cont = cont' 3092 , sc_dup = OkToDup} ) } 3093 3094 | otherwise 3095 = -- Use Plan B of Note [Duplicating StrictArg] 3096 -- K[ f a b <> ] --> join j x = K[ f a b x ] 3097 -- j <> 3098 do { let fun_ty = ai_type fun 3099 ; let arg_ty = funArgTy fun_ty 3100 rhs_ty = contResultType cont 3101 ; arg_bndr <- newId (fsLit "arg") arg_ty -- ToDo: check this linearity argument 3102 ; let env' = env `addNewInScopeIds` [arg_bndr] 3103 ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr)) cont 3104 ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } 3105 where 3106 thumbsUpPlanA (StrictArg {}) = False 3107 thumbsUpPlanA (CastIt _ k) = thumbsUpPlanA k 3108 thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k 3109 thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k 3110 thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k 3111 thumbsUpPlanA (Select {}) = True 3112 thumbsUpPlanA (StrictBind {}) = True 3113 thumbsUpPlanA (Stop {}) = True 3114 3115mkDupableContWithDmds env dmds 3116 (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) 3117 = do { (floats, cont') <- mkDupableContWithDmds env dmds cont 3118 ; return (floats, ApplyToTy { sc_cont = cont' 3119 , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } 3120 3121mkDupableContWithDmds env dmds 3122 (ApplyToVal { sc_arg = arg, sc_dup = dup 3123 , sc_env = se, sc_cont = cont }) 3124 = -- e.g. [...hole...] (...arg...) 3125 -- ==> 3126 -- let a = ...arg... 3127 -- in [...hole...] a 3128 -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable 3129 do { let (dmd:_) = dmds -- Never fails 3130 ; (floats1, cont') <- mkDupableContWithDmds env dmds cont 3131 ; let env' = env `setInScopeFromF` floats1 3132 ; (_, se', arg') <- simplArg env' dup se arg 3133 ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel dmd (fsLit "karg") arg' 3134 ; let all_floats = floats1 `addLetFloats` let_floats2 3135 ; return ( all_floats 3136 , ApplyToVal { sc_arg = arg'' 3137 , sc_env = se' `setInScopeFromF` all_floats 3138 -- Ensure that sc_env includes the free vars of 3139 -- arg'' in its in-scope set, even if makeTrivial 3140 -- has turned arg'' into a fresh variable 3141 -- See Note [StaticEnv invariant] in SimplUtils 3142 , sc_dup = OkToDup, sc_cont = cont' }) } 3143 3144mkDupableContWithDmds env _ 3145 (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) 3146 = -- e.g. (case [...hole...] of { pi -> ei }) 3147 -- ===> 3148 -- let ji = \xij -> ei 3149 -- in case [...hole...] of { pi -> ji xij } 3150 -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable 3151 do { tick (CaseOfCase case_bndr) 3152 ; (floats, alt_cont) <- mkDupableCaseCont env alts cont 3153 -- NB: We call mkDupableCaseCont here to make cont duplicable 3154 -- (if necessary, depending on the number of alts) 3155 -- And this is important: see Note [Fusing case continuations] 3156 3157 ; let alt_env = se `setInScopeFromF` floats 3158 ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr 3159 ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts 3160 -- Safe to say that there are no handled-cons for the DEFAULT case 3161 -- NB: simplBinder does not zap deadness occ-info, so 3162 -- a dead case_bndr' will still advertise its deadness 3163 -- This is really important because in 3164 -- case e of b { (# p,q #) -> ... } 3165 -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), 3166 -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. 3167 -- In the new alts we build, we have the new case binder, so it must retain 3168 -- its deadness. 3169 -- NB: we don't use alt_env further; it has the substEnv for 3170 -- the alternatives, and we don't want that 3171 3172 ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (seDynFlags env) case_bndr') 3173 emptyJoinFloats alts' 3174 3175 ; let all_floats = floats `addJoinFloats` join_floats 3176 -- Note [Duplicated env] 3177 ; return (all_floats 3178 , Select { sc_dup = OkToDup 3179 , sc_bndr = case_bndr' 3180 , sc_alts = alts'' 3181 , sc_env = zapSubstEnv se `setInScopeFromF` all_floats 3182 -- See Note [StaticEnv invariant] in SimplUtils 3183 , sc_cont = mkBoringStop (contResultType cont) } ) } 3184 3185mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType 3186 -> SimplM (SimplFloats, SimplCont) 3187mkDupableStrictBind env arg_bndr join_rhs res_ty 3188 | exprIsDupable (seDynFlags env) join_rhs 3189 = return (emptyFloats env 3190 , StrictBind { sc_bndr = arg_bndr, sc_bndrs = [] 3191 , sc_body = join_rhs 3192 , sc_env = zapSubstEnv env 3193 -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils 3194 , sc_dup = OkToDup 3195 , sc_cont = mkBoringStop res_ty } ) 3196 | otherwise 3197 = do { join_bndr <- newJoinId [arg_bndr] res_ty 3198 ; let arg_info = ArgInfo { ai_fun = join_bndr 3199 , ai_type = idType join_bndr 3200 , ai_rules = Nothing, ai_args = [] 3201 , ai_encl = False, ai_dmds = repeat topDmd 3202 , ai_discs = repeat 0 } 3203 ; return ( addJoinFloats (emptyFloats env) $ 3204 unitJoinFloat $ 3205 NonRec join_bndr $ 3206 Lam (setOneShotLambda arg_bndr) join_rhs 3207 , StrictArg { sc_dup = OkToDup 3208 , sc_fun = arg_info 3209 , sc_cont = mkBoringStop res_ty 3210 } ) } 3211 3212mkDupableAlt :: DynFlags -> OutId 3213 -> JoinFloats -> OutAlt 3214 -> SimplM (JoinFloats, OutAlt) 3215mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs') 3216 | exprIsDupable dflags rhs' -- Note [Small alternative rhs] 3217 = return (jfloats, (con, bndrs', rhs')) 3218 3219 | otherwise 3220 = do { let rhs_ty' = exprType rhs' 3221 scrut_ty = idType case_bndr 3222 case_bndr_w_unf 3223 = case con of 3224 DEFAULT -> case_bndr 3225 DataAlt dc -> setIdUnfolding case_bndr unf 3226 where 3227 -- See Note [Case binders and join points] 3228 unf = mkInlineUnfolding rhs 3229 rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' 3230 3231 LitAlt {} -> WARN( True, text "mkDupableAlt" 3232 <+> ppr case_bndr <+> ppr con ) 3233 case_bndr 3234 -- The case binder is alive but trivial, so why has 3235 -- it not been substituted away? 3236 3237 final_bndrs' 3238 | isDeadBinder case_bndr = filter abstract_over bndrs' 3239 | otherwise = bndrs' ++ [case_bndr_w_unf] 3240 3241 abstract_over bndr 3242 | isTyVar bndr = True -- Abstract over all type variables just in case 3243 | otherwise = not (isDeadBinder bndr) 3244 -- The deadness info on the new Ids is preserved by simplBinders 3245 final_args = varsToCoreExprs final_bndrs' 3246 -- Note [Join point abstraction] 3247 3248 -- We make the lambdas into one-shot-lambdas. The 3249 -- join point is sure to be applied at most once, and doing so 3250 -- prevents the body of the join point being floated out by 3251 -- the full laziness pass 3252 really_final_bndrs = map one_shot final_bndrs' 3253 one_shot v | isId v = setOneShotLambda v 3254 | otherwise = v 3255 join_rhs = mkLams really_final_bndrs rhs' 3256 3257 ; join_bndr <- newJoinId final_bndrs' rhs_ty' 3258 3259 ; let join_call = mkApps (Var join_bndr) final_args 3260 alt' = (con, bndrs', join_call) 3261 3262 ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) 3263 , alt') } 3264 -- See Note [Duplicated env] 3265 3266{- 3267Note [Fusing case continuations] 3268~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3269It's important to fuse two successive case continuations when the 3270first has one alternative. That's why we call prepareCaseCont here. 3271Consider this, which arises from thunk splitting (see Note [Thunk 3272splitting] in WorkWrap): 3273 3274 let 3275 x* = case (case v of {pn -> rn}) of 3276 I# a -> I# a 3277 in body 3278 3279The simplifier will find 3280 (Var v) with continuation 3281 Select (pn -> rn) ( 3282 Select [I# a -> I# a] ( 3283 StrictBind body Stop 3284 3285So we'll call mkDupableCont on 3286 Select [I# a -> I# a] (StrictBind body Stop) 3287There is just one alternative in the first Select, so we want to 3288simplify the rhs (I# a) with continuation (StrictBind body Stop) 3289Supposing that body is big, we end up with 3290 let $j a = <let x = I# a in body> 3291 in case v of { pn -> case rn of 3292 I# a -> $j a } 3293This is just what we want because the rn produces a box that 3294the case rn cancels with. 3295 3296See #4957 a fuller example. 3297 3298Note [Case binders and join points] 3299~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3300Consider this 3301 case (case .. ) of c { 3302 I# c# -> ....c.... 3303 3304If we make a join point with c but not c# we get 3305 $j = \c -> ....c.... 3306 3307But if later inlining scrutinises the c, thus 3308 3309 $j = \c -> ... case c of { I# y -> ... } ... 3310 3311we won't see that 'c' has already been scrutinised. This actually 3312happens in the 'tabulate' function in wave4main, and makes a significant 3313difference to allocation. 3314 3315An alternative plan is this: 3316 3317 $j = \c# -> let c = I# c# in ...c.... 3318 3319but that is bad if 'c' is *not* later scrutinised. 3320 3321So instead we do both: we pass 'c' and 'c#' , and record in c's inlining 3322(a stable unfolding) that it's really I# c#, thus 3323 3324 $j = \c# -> \c[=I# c#] -> ...c.... 3325 3326Absence analysis may later discard 'c'. 3327 3328NB: take great care when doing strictness analysis; 3329 see Note [Lambda-bound unfoldings] in DmdAnal. 3330 3331Also note that we can still end up passing stuff that isn't used. Before 3332strictness analysis we have 3333 let $j x y c{=(x,y)} = (h c, ...) 3334 in ... 3335After strictness analysis we see that h is strict, we end up with 3336 let $j x y c{=(x,y)} = ($wh x y, ...) 3337and c is unused. 3338 3339Note [Duplicated env] 3340~~~~~~~~~~~~~~~~~~~~~ 3341Some of the alternatives are simplified, but have not been turned into a join point 3342So they *must* have a zapped subst-env. So we can't use completeNonRecX to 3343bind the join point, because it might to do PostInlineUnconditionally, and 3344we'd lose that when zapping the subst-env. We could have a per-alt subst-env, 3345but zapping it (as we do in mkDupableCont, the Select case) is safe, and 3346at worst delays the join-point inlining. 3347 3348Note [Small alternative rhs] 3349~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3350It is worth checking for a small RHS because otherwise we 3351get extra let bindings that may cause an extra iteration of the simplifier to 3352inline back in place. Quite often the rhs is just a variable or constructor. 3353The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra 3354iterations because the version with the let bindings looked big, and so wasn't 3355inlined, but after the join points had been inlined it looked smaller, and so 3356was inlined. 3357 3358NB: we have to check the size of rhs', not rhs. 3359Duplicating a small InAlt might invalidate occurrence information 3360However, if it *is* dupable, we return the *un* simplified alternative, 3361because otherwise we'd need to pair it up with an empty subst-env.... 3362but we only have one env shared between all the alts. 3363(Remember we must zap the subst-env before re-simplifying something). 3364Rather than do this we simply agree to re-simplify the original (small) thing later. 3365 3366Note [Funky mkLamTypes] 3367~~~~~~~~~~~~~~~~~~~~~~ 3368Notice the funky mkLamTypes. If the constructor has existentials 3369it's possible that the join point will be abstracted over 3370type variables as well as term variables. 3371 Example: Suppose we have 3372 data T = forall t. C [t] 3373 Then faced with 3374 case (case e of ...) of 3375 C t xs::[t] -> rhs 3376 We get the join point 3377 let j :: forall t. [t] -> ... 3378 j = /\t \xs::[t] -> rhs 3379 in 3380 case (case e of ...) of 3381 C t xs::[t] -> j t xs 3382 3383Note [Duplicating StrictArg] 3384~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3385Dealing with making a StrictArg continuation duplicable has turned out 3386to be one of the trickiest corners of the simplifier, giving rise 3387to several cases in which the simplier expanded the program's size 3388*exponentially*. They include 3389 #13253 exponential inlining 3390 #10421 ditto 3391 #18140 strict constructors 3392 #18282 another nested-function call case 3393 3394Suppose we have a call 3395 f e1 (case x of { True -> r1; False -> r2 }) e3 3396and f is strict in its second argument. Then we end up in 3397mkDupableCont with a StrictArg continuation for (f e1 <> e3). 3398There are two ways to make it duplicable. 3399 3400* Plan A: move the entire call inwards, being careful not 3401 to duplicate e1 or e3, thus: 3402 let a1 = e1 3403 a3 = e3 3404 in case x of { True -> f a1 r1 a3 3405 ; False -> f a1 r2 a3 } 3406 3407* Plan B: make a join point: 3408 join $j x = f e1 x e3 3409 in case x of { True -> jump $j r1 3410 ; False -> jump $j r2 } 3411 Notice that Plan B is very like the way we handle strict 3412 bindings; see Note [Duplicating StrictBind]. 3413 3414Plan A is good. Here's an example from #3116 3415 go (n+1) (case l of 3416 1 -> bs' 3417 _ -> Chunk p fpc (o+1) (l-1) bs') 3418 3419If we pushed the entire call for 'go' inside the case, we get 3420call-pattern specialisation for 'go', which is *crucial* for 3421this particular program. 3422 3423Here is another example. 3424 && E (case x of { T -> F; F -> T }) 3425 3426Pushing the call inward (being careful not to duplicate E) 3427 let a = E 3428 in case x of { T -> && a F; F -> && a T } 3429 3430and now the (&& a F) etc can optimise. Moreover there might 3431be a RULE for the function that can fire when it "sees" the 3432particular case alterantive. 3433 3434But Plan A can have terrible, terrible behaviour. Here is a classic 3435case: 3436 f (f (f (f (f True)))) 3437 3438Suppose f is strict, and has a body that is small enough to inline. 3439The innermost call inlines (seeing the True) to give 3440 f (f (f (f (case v of { True -> e1; False -> e2 })))) 3441 3442Now, suppose we naively push the entire continuation into both 3443case branches (it doesn't look large, just f.f.f.f). We get 3444 case v of 3445 True -> f (f (f (f e1))) 3446 False -> f (f (f (f e2))) 3447 3448And now the process repeats, so we end up with an exponentially large 3449number of copies of f. No good! 3450 3451CONCLUSION: we want Plan A in general, but do Plan B is there a 3452danger of this nested call behaviour. The function that decides 3453this is called thumbsUpPlanA. 3454 3455Note [Keeping demand info in StrictArg Plan A] 3456~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3457Following on from Note [Duplicating StrictArg], another common code 3458pattern that can go bad is this: 3459 f (case x1 of { T -> F; F -> T }) 3460 (case x2 of { T -> F; F -> T }) 3461 ...etc... 3462when f is strict in all its arguments. (It might, for example, be a 3463strict data constructor whose wrapper has not yet been inlined.) 3464 3465We use Plan A (because there is no nesting) giving 3466 let a2 = case x2 of ... 3467 a3 = case x3 of ... 3468 in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... } 3469 3470Now we must be careful! a2 and a3 are small, and the OneOcc code in 3471postInlineUnconditionally may inline them both at both sites; see Note 3472Note [Inline small things to avoid creating a thunk] in 3473Simplify.Utils. But if we do inline them, the entire process will 3474repeat -- back to exponential behaviour. 3475 3476So we are careful to keep the demand-info on a2 and a3. Then they'll 3477be /strict/ let-bindings, which will be dealt with by StrictBind. 3478That's why contIsDupableWithDmds is careful to propagage demand 3479info to the auxiliary bindings it creates. See the Demand argument 3480to makeTrivial. 3481 3482Note [Duplicating StrictBind] 3483~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3484We make a StrictBind duplicable in a very similar way to 3485that for case expressions. After all, 3486 let x* = e in b is similar to case e of x -> b 3487 3488So we potentially make a join-point for the body, thus: 3489 let x = <> in b ==> join j x = b 3490 in j <> 3491 3492Just like StrictArg in fact -- and indeed they share code. 3493 3494Note [Join point abstraction] Historical note 3495~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3496NB: This note is now historical, describing how (in the past) we used 3497to add a void argument to nullary join points. But now that "join 3498point" is not a fuzzy concept but a formal syntactic construct (as 3499distinguished by the JoinId constructor of IdDetails), each of these 3500concerns is handled separately, with no need for a vestigial extra 3501argument. 3502 3503Join points always have at least one value argument, 3504for several reasons 3505 3506* If we try to lift a primitive-typed something out 3507 for let-binding-purposes, we will *caseify* it (!), 3508 with potentially-disastrous strictness results. So 3509 instead we turn it into a function: \v -> e 3510 where v::Void#. The value passed to this function is void, 3511 which generates (almost) no code. 3512 3513* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now 3514 we make the join point into a function whenever used_bndrs' 3515 is empty. This makes the join-point more CPR friendly. 3516 Consider: let j = if .. then I# 3 else I# 4 3517 in case .. of { A -> j; B -> j; C -> ... } 3518 3519 Now CPR doesn't w/w j because it's a thunk, so 3520 that means that the enclosing function can't w/w either, 3521 which is a lose. Here's the example that happened in practice: 3522 kgmod :: Int -> Int -> Int 3523 kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 3524 then 78 3525 else 5 3526 3527* Let-no-escape. We want a join point to turn into a let-no-escape 3528 so that it is implemented as a jump, and one of the conditions 3529 for LNE is that it's not updatable. In CoreToStg, see 3530 Note [What is a non-escaping let] 3531 3532* Floating. Since a join point will be entered once, no sharing is 3533 gained by floating out, but something might be lost by doing 3534 so because it might be allocated. 3535 3536I have seen a case alternative like this: 3537 True -> \v -> ... 3538It's a bit silly to add the realWorld dummy arg in this case, making 3539 $j = \s v -> ... 3540 True -> $j s 3541(the \v alone is enough to make CPR happy) but I think it's rare 3542 3543There's a slight infelicity here: we pass the overall 3544case_bndr to all the join points if it's used in *any* RHS, 3545because we don't know its usage in each RHS separately 3546 3547 3548 3549************************************************************************ 3550* * 3551 Unfoldings 3552* * 3553************************************************************************ 3554-} 3555 3556simplLetUnfolding :: SimplEnv-> TopLevelFlag 3557 -> MaybeJoinCont 3558 -> InId 3559 -> OutExpr -> OutType 3560 -> Unfolding -> SimplM Unfolding 3561simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf 3562 | isStableUnfolding unf 3563 = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty 3564 | isExitJoinId id 3565 = return noUnfolding -- See Note [Do not inline exit join points] in Exitify 3566 | otherwise 3567 = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs 3568 3569------------------- 3570mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource 3571 -> InId -> OutExpr -> SimplM Unfolding 3572mkLetUnfolding dflags top_lvl src id new_rhs 3573 = is_bottoming `seq` -- See Note [Force bottoming field] 3574 return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs) 3575 -- We make an unfolding *even for loop-breakers*. 3576 -- Reason: (a) It might be useful to know that they are WHNF 3577 -- (b) In TidyPgm we currently assume that, if we want to 3578 -- expose the unfolding then indeed we *have* an unfolding 3579 -- to expose. (We could instead use the RHS, but currently 3580 -- we don't.) The simple thing is always to have one. 3581 where 3582 is_top_lvl = isTopLevel top_lvl 3583 is_bottoming = isBottomingId id 3584 3585------------------- 3586simplStableUnfolding :: SimplEnv -> TopLevelFlag 3587 -> MaybeJoinCont -- Just k => a join point with continuation k 3588 -> InId 3589 -> Unfolding -> OutType -> SimplM Unfolding 3590-- Note [Setting the new unfolding] 3591simplStableUnfolding env top_lvl mb_cont id unf rhs_ty 3592 = case unf of 3593 NoUnfolding -> return unf 3594 BootUnfolding -> return unf 3595 OtherCon {} -> return unf 3596 3597 DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } 3598 -> do { (env', bndrs') <- simplBinders unf_env bndrs 3599 ; args' <- mapM (simplExpr env') args 3600 ; return (mkDFunUnfolding bndrs' con args') } 3601 3602 CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } 3603 | isStableSource src 3604 -> do { expr' <- case mb_cont of -- See Note [Rules and unfolding for join points] 3605 Just cont -> simplJoinRhs unf_env id expr cont 3606 Nothing -> simplExprC unf_env expr (mkBoringStop rhs_ty) 3607 ; case guide of 3608 UnfWhen { ug_arity = arity 3609 , ug_unsat_ok = sat_ok 3610 , ug_boring_ok = boring_ok 3611 } 3612 -- Happens for INLINE things 3613 -> let guide' = 3614 UnfWhen { ug_arity = arity 3615 , ug_unsat_ok = sat_ok 3616 , ug_boring_ok = 3617 boring_ok || inlineBoringOk expr' 3618 } 3619 -- Refresh the boring-ok flag, in case expr' 3620 -- has got small. This happens, notably in the inlinings 3621 -- for dfuns for single-method classes; see 3622 -- Note [Single-method classes] in TcInstDcls. 3623 -- A test case is #4138 3624 -- But retain a previous boring_ok of True; e.g. see 3625 -- the way it is set in calcUnfoldingGuidanceWithArity 3626 in return (mkCoreUnfolding src is_top_lvl expr' guide') 3627 -- See Note [Top-level flag on inline rules] in CoreUnfold 3628 3629 _other -- Happens for INLINABLE things 3630 -> mkLetUnfolding dflags top_lvl src id expr' } 3631 -- If the guidance is UnfIfGoodArgs, this is an INLINABLE 3632 -- unfolding, and we need to make sure the guidance is kept up 3633 -- to date with respect to any changes in the unfolding. 3634 3635 | otherwise -> return noUnfolding -- Discard unstable unfoldings 3636 where 3637 dflags = seDynFlags env 3638 is_top_lvl = isTopLevel top_lvl 3639 act = idInlineActivation id 3640 unf_env = updMode (updModeForStableUnfoldings act) env 3641 -- See Note [Simplifying inside stable unfoldings] in SimplUtils 3642 3643{- 3644Note [Force bottoming field] 3645~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3646We need to force bottoming, or the new unfolding holds 3647on to the old unfolding (which is part of the id). 3648 3649Note [Setting the new unfolding] 3650~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3651* If there's an INLINE pragma, we simplify the RHS gently. Maybe we 3652 should do nothing at all, but simplifying gently might get rid of 3653 more crap. 3654 3655* If not, we make an unfolding from the new RHS. But *only* for 3656 non-loop-breakers. Making loop breakers not have an unfolding at all 3657 means that we can avoid tests in exprIsConApp, for example. This is 3658 important: if exprIsConApp says 'yes' for a recursive thing, then we 3659 can get into an infinite loop 3660 3661If there's a stable unfolding on a loop breaker (which happens for 3662INLINABLE), we hang on to the inlining. It's pretty dodgy, but the 3663user did say 'INLINE'. May need to revisit this choice. 3664 3665************************************************************************ 3666* * 3667 Rules 3668* * 3669************************************************************************ 3670 3671Note [Rules in a letrec] 3672~~~~~~~~~~~~~~~~~~~~~~~~ 3673After creating fresh binders for the binders of a letrec, we 3674substitute the RULES and add them back onto the binders; this is done 3675*before* processing any of the RHSs. This is important. Manuel found 3676cases where he really, really wanted a RULE for a recursive function 3677to apply in that function's own right-hand side. 3678 3679See Note [Forming Rec groups] in OccurAnal 3680-} 3681 3682addBndrRules :: SimplEnv -> InBndr -> OutBndr 3683 -> MaybeJoinCont -- Just k for a join point binder 3684 -- Nothing otherwise 3685 -> SimplM (SimplEnv, OutBndr) 3686-- Rules are added back into the bin 3687addBndrRules env in_id out_id mb_cont 3688 | null old_rules 3689 = return (env, out_id) 3690 | otherwise 3691 = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont 3692 ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules 3693 ; return (modifyInScope env final_id, final_id) } 3694 where 3695 old_rules = ruleInfoRules (idSpecialisation in_id) 3696 3697simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] 3698 -> MaybeJoinCont -> SimplM [CoreRule] 3699simplRules env mb_new_id rules mb_cont 3700 = mapM simpl_rule rules 3701 where 3702 simpl_rule rule@(BuiltinRule {}) 3703 = return rule 3704 3705 simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args 3706 , ru_fn = fn_name, ru_rhs = rhs }) 3707 = do { (env', bndrs') <- simplBinders env bndrs 3708 ; let rhs_ty = substTy env' (exprType rhs) 3709 rhs_cont = case mb_cont of -- See Note [Rules and unfolding for join points] 3710 Nothing -> mkBoringStop rhs_ty 3711 Just cont -> ASSERT2( join_ok, bad_join_msg ) 3712 cont 3713 rule_env = updMode updModeForRules env' 3714 fn_name' = case mb_new_id of 3715 Just id -> idName id 3716 Nothing -> fn_name 3717 3718 -- join_ok is an assertion check that the join-arity of the 3719 -- binder matches that of the rule, so that pushing the 3720 -- continuation into the RHS makes sense 3721 join_ok = case mb_new_id of 3722 Just id | Just join_arity <- isJoinId_maybe id 3723 -> length args == join_arity 3724 _ -> False 3725 bad_join_msg = vcat [ ppr mb_new_id, ppr rule 3726 , ppr (fmap isJoinId_maybe mb_new_id) ] 3727 3728 ; args' <- mapM (simplExpr rule_env) args 3729 ; rhs' <- simplExprC rule_env rhs rhs_cont 3730 ; return (rule { ru_bndrs = bndrs' 3731 , ru_fn = fn_name' 3732 , ru_args = args' 3733 , ru_rhs = rhs' }) } 3734