1{- 2(c) The University of Glasgow 2006 3(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 4 5 6Utility functions on @Core@ syntax 7-} 8 9{-# LANGUAGE CPP #-} 10 11-- | Commonly useful utilities for manipulating the Core language 12module GHC.Core.Utils ( 13 -- * Constructing expressions 14 mkCast, 15 mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, 16 bindNonRec, needsCaseBinding, 17 mkAltExpr, mkDefaultCase, mkSingleAltCase, 18 19 -- * Taking expressions apart 20 findDefault, addDefault, findAlt, isDefaultAlt, 21 mergeAlts, trimConArgs, 22 filterAlts, combineIdenticalAlts, refineDefaultAlt, 23 scaleAltsBy, 24 25 -- * Properties of expressions 26 exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, 27 mkFunctionType, 28 isExprLevPoly, 29 exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd, 30 getIdFromTrivialExpr_maybe, 31 exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, 32 exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, 33 exprIsConLike, 34 isCheapApp, isExpandableApp, 35 exprIsTickedString, exprIsTickedString_maybe, 36 exprIsTopLevelBindable, 37 altsAreExhaustive, 38 39 -- * Equality 40 cheapEqExpr, cheapEqExpr', eqExpr, 41 diffExpr, diffBinds, 42 43 -- * Lambdas and eta reduction 44 tryEtaReduce, zapLamBndrs, 45 46 -- * Manipulating data constructors and types 47 exprToType, exprToCoercion_maybe, 48 applyTypeToArgs, applyTypeToArg, 49 dataConRepInstPat, dataConRepFSInstPat, 50 isEmptyTy, 51 52 -- * Working with ticks 53 stripTicksTop, stripTicksTopE, stripTicksTopT, 54 stripTicksE, stripTicksT, 55 56 -- * StaticPtr 57 collectMakeStaticArgs, 58 59 -- * Join points 60 isJoinBind, 61 62 -- * unsafeEqualityProof 63 isUnsafeEqualityProof, 64 65 -- * Dumping stuff 66 dumpIdInfoOfProgram 67 ) where 68 69#include "GhclibHsVersions.h" 70 71import GHC.Prelude 72import GHC.Platform 73 74import GHC.Driver.Ppr 75 76import GHC.Core 77import GHC.Builtin.Names (absentErrorIdKey, makeStaticName, unsafeEqualityProofName) 78import GHC.Core.Ppr 79import GHC.Core.FVs( exprFreeVars ) 80import GHC.Types.Var 81import GHC.Types.SrcLoc 82import GHC.Types.Var.Env 83import GHC.Types.Var.Set 84import GHC.Types.Name 85import GHC.Types.Literal 86import GHC.Types.Tickish 87import GHC.Core.DataCon 88import GHC.Builtin.PrimOps 89import GHC.Types.Id 90import GHC.Types.Id.Info 91import GHC.Core.Type as Type 92import GHC.Core.Predicate 93import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) 94import GHC.Core.Coercion 95import GHC.Core.TyCon 96import GHC.Core.Multiplicity 97import GHC.Types.Unique 98import GHC.Utils.Outputable 99import GHC.Utils.Panic 100import GHC.Data.FastString 101import GHC.Data.Maybe 102import GHC.Data.List.SetOps( minusList ) 103import GHC.Types.Basic ( Arity, FullArgCount ) 104import GHC.Utils.Misc 105import GHC.Data.Pair 106import Data.ByteString ( ByteString ) 107import Data.Function ( on ) 108import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) 109import Data.Ord ( comparing ) 110import GHC.Data.OrdList 111import qualified Data.Set as Set 112import GHC.Types.Unique.Set 113 114{- 115************************************************************************ 116* * 117\subsection{Find the type of a Core atom/expression} 118* * 119************************************************************************ 120-} 121 122exprType :: CoreExpr -> Type 123-- ^ Recover the type of a well-typed Core expression. Fails when 124-- applied to the actual 'GHC.Core.Type' expression as it cannot 125-- really be said to have a type 126exprType (Var var) = idType var 127exprType (Lit lit) = literalType lit 128exprType (Coercion co) = coercionType co 129exprType (Let bind body) 130 | NonRec tv rhs <- bind -- See Note [Type bindings] 131 , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) 132 | otherwise = exprType body 133exprType (Case _ _ ty _) = ty 134exprType (Cast _ co) = pSnd (coercionKind co) 135exprType (Tick _ e) = exprType e 136exprType (Lam binder expr) = mkLamType binder (exprType expr) 137exprType e@(App _ _) 138 = case collectArgs e of 139 (fun, args) -> applyTypeToArgs e (exprType fun) args 140 141exprType other = pprPanic "exprType" (pprCoreExpr other) 142 143coreAltType :: CoreAlt -> Type 144-- ^ Returns the type of the alternatives right hand side 145coreAltType alt@(Alt _ bs rhs) 146 = case occCheckExpand bs rhs_ty of 147 -- Note [Existential variables and silly type synonyms] 148 Just ty -> ty 149 Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty) 150 where 151 rhs_ty = exprType rhs 152 153coreAltsType :: [CoreAlt] -> Type 154-- ^ Returns the type of the first alternative, which should be the same as for all alternatives 155coreAltsType (alt:_) = coreAltType alt 156coreAltsType [] = panic "corAltsType" 157 158mkLamType :: Var -> Type -> Type 159-- ^ Makes a @(->)@ type or an implicit forall type, depending 160-- on whether it is given a type variable or a term variable. 161-- This is used, for example, when producing the type of a lambda. 162-- Always uses Inferred binders. 163mkLamTypes :: [Var] -> Type -> Type 164-- ^ 'mkLamType' for multiple type or value arguments 165 166mkLamType v body_ty 167 | isTyVar v 168 = mkForAllTy v Inferred body_ty 169 170 | isCoVar v 171 , v `elemVarSet` tyCoVarsOfType body_ty 172 = mkForAllTy v Required body_ty 173 174 | otherwise 175 = mkFunctionType (varMult v) (varType v) body_ty 176 177mkFunctionType :: Mult -> Type -> Type -> Type 178-- This one works out the AnonArgFlag from the argument type 179-- See GHC.Types.Var Note [AnonArgFlag] 180mkFunctionType mult arg_ty res_ty 181 | isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag] 182 = ASSERT(eqType mult Many) 183 mkInvisFunTy mult arg_ty res_ty 184 185 | otherwise 186 = mkVisFunTy mult arg_ty res_ty 187 188mkLamTypes vs ty = foldr mkLamType ty vs 189 190-- | Is this expression levity polymorphic? This should be the 191-- same as saying (isKindLevPoly . typeKind . exprType) but 192-- much faster. 193isExprLevPoly :: CoreExpr -> Bool 194isExprLevPoly = go 195 where 196 go (Var _) = False -- no levity-polymorphic binders 197 go (Lit _) = False -- no levity-polymorphic literals 198 go e@(App f _) | not (go_app f) = False 199 | otherwise = check_type e 200 go (Lam _ _) = False 201 go (Let _ e) = go e 202 go e@(Case {}) = check_type e -- checking type is fast 203 go e@(Cast {}) = check_type e 204 go (Tick _ e) = go e 205 go e@(Type {}) = pprPanic "isExprLevPoly ty" (ppr e) 206 go (Coercion {}) = False -- this case can happen in GHC.Core.Opt.SetLevels 207 208 check_type = isTypeLevPoly . exprType -- slow approach 209 210 -- if the function is a variable (common case), check its 211 -- levityInfo. This might mean we don't need to look up and compute 212 -- on the type. Spec of these functions: return False if there is 213 -- no possibility, ever, of this expression becoming levity polymorphic, 214 -- no matter what it's applied to; return True otherwise. 215 -- returning True is always safe. See also Note [Levity info] in 216 -- IdInfo 217 go_app (Var id) = not (isNeverLevPolyId id) 218 go_app (Lit _) = False 219 go_app (App f _) = go_app f 220 go_app (Lam _ e) = go_app e 221 go_app (Let _ e) = go_app e 222 go_app (Case _ _ ty _) = resultIsLevPoly ty 223 go_app (Cast _ co) = resultIsLevPoly (coercionRKind co) 224 go_app (Tick _ e) = go_app e 225 go_app e@(Type {}) = pprPanic "isExprLevPoly app ty" (ppr e) 226 go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e) 227 228 229{- 230Note [Type bindings] 231~~~~~~~~~~~~~~~~~~~~ 232Core does allow type bindings, although such bindings are 233not much used, except in the output of the desugarer. 234Example: 235 let a = Int in (\x:a. x) 236Given this, exprType must be careful to substitute 'a' in the 237result type (#8522). 238 239Note [Existential variables and silly type synonyms] 240~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 241Consider 242 data T = forall a. T (Funny a) 243 type Funny a = Bool 244 f :: T -> Bool 245 f (T x) = x 246 247Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. 248That means that 'exprType' and 'coreAltsType' may give a result that *appears* 249to mention an out-of-scope type variable. See #3409 for a more real-world 250example. 251 252Various possibilities suggest themselves: 253 254 - Ignore the problem, and make Lint not complain about such variables 255 256 - Expand all type synonyms (or at least all those that discard arguments) 257 This is tricky, because at least for top-level things we want to 258 retain the type the user originally specified. 259 260 - Expand synonyms on the fly, when the problem arises. That is what 261 we are doing here. It's not too expensive, I think. 262 263Note that there might be existentially quantified coercion variables, too. 264-} 265 266-- Not defined with applyTypeToArg because you can't print from GHC.Core. 267applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type 268-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. 269-- The first argument is just for debugging, and gives some context 270applyTypeToArgs e op_ty args 271 = go op_ty args 272 where 273 go op_ty [] = op_ty 274 go op_ty (Type ty : args) = go_ty_args op_ty [ty] args 275 go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args 276 go op_ty (_ : args) | Just (_, _, res_ty) <- splitFunTy_maybe op_ty 277 = go res_ty args 278 go _ args = pprPanic "applyTypeToArgs" (panic_msg args) 279 280 -- go_ty_args: accumulate type arguments so we can 281 -- instantiate all at once with piResultTys 282 go_ty_args op_ty rev_tys (Type ty : args) 283 = go_ty_args op_ty (ty:rev_tys) args 284 go_ty_args op_ty rev_tys (Coercion co : args) 285 = go_ty_args op_ty (mkCoercionTy co : rev_tys) args 286 go_ty_args op_ty rev_tys args 287 = go (piResultTys op_ty (reverse rev_tys)) args 288 289 panic_msg as = vcat [ text "Expression:" <+> pprCoreExpr e 290 , text "Type:" <+> ppr op_ty 291 , text "Args:" <+> ppr args 292 , text "Args':" <+> ppr as ] 293 294 295{- 296************************************************************************ 297* * 298\subsection{Attaching notes} 299* * 300************************************************************************ 301-} 302 303-- | Wrap the given expression in the coercion safely, dropping 304-- identity coercions and coalescing nested coercions 305mkCast :: CoreExpr -> CoercionR -> CoreExpr 306mkCast e co 307 | ASSERT2( coercionRole co == Representational 308 , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast") 309 <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) ) 310 isReflCo co 311 = e 312 313mkCast (Coercion e_co) co 314 | isCoVarType (coercionRKind co) 315 -- The guard here checks that g has a (~#) on both sides, 316 -- otherwise decomposeCo fails. Can in principle happen 317 -- with unsafeCoerce 318 = Coercion (mkCoCast e_co co) 319 320mkCast (Cast expr co2) co 321 = WARN(let { from_ty = coercionLKind co; 322 to_ty2 = coercionRKind co2 } in 323 not (from_ty `eqType` to_ty2), 324 vcat ([ text "expr:" <+> ppr expr 325 , text "co2:" <+> ppr co2 326 , text "co:" <+> ppr co ]) ) 327 mkCast expr (mkTransCo co2 co) 328 329mkCast (Tick t expr) co 330 = Tick t (mkCast expr co) 331 332mkCast expr co 333 = let from_ty = coercionLKind co in 334 WARN( not (from_ty `eqType` exprType expr), 335 text "Trying to coerce" <+> text "(" <> ppr expr 336 $$ text "::" <+> ppr (exprType expr) <> text ")" 337 $$ ppr co $$ ppr (coercionType co) 338 $$ callStackDoc ) 339 (Cast expr co) 340 341-- | Wraps the given expression in the source annotation, dropping the 342-- annotation if possible. 343mkTick :: CoreTickish -> CoreExpr -> CoreExpr 344mkTick t orig_expr = mkTick' id id orig_expr 345 where 346 -- Some ticks (cost-centres) can be split in two, with the 347 -- non-counting part having laxer placement properties. 348 canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t 349 350 mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through) 351 -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with) 352 -> CoreExpr -- ^ current expression 353 -> CoreExpr 354 mkTick' top rest expr = case expr of 355 356 -- Cost centre ticks should never be reordered relative to each 357 -- other. Therefore we can stop whenever two collide. 358 Tick t2 e 359 | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr 360 361 -- Otherwise we assume that ticks of different placements float 362 -- through each other. 363 | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e 364 365 -- For annotations this is where we make sure to not introduce 366 -- redundant ticks. 367 | tickishContains t t2 -> mkTick' top rest e 368 | tickishContains t2 t -> orig_expr 369 | otherwise -> mkTick' top (rest . Tick t2) e 370 371 -- Ticks don't care about types, so we just float all ticks 372 -- through them. Note that it's not enough to check for these 373 -- cases top-level. While mkTick will never produce Core with type 374 -- expressions below ticks, such constructs can be the result of 375 -- unfoldings. We therefore make an effort to put everything into 376 -- the right place no matter what we start with. 377 Cast e co -> mkTick' (top . flip Cast co) rest e 378 Coercion co -> Coercion co 379 380 Lam x e 381 -- Always float through type lambdas. Even for non-type lambdas, 382 -- floating is allowed for all but the most strict placement rule. 383 | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime 384 -> mkTick' (top . Lam x) rest e 385 386 -- If it is both counting and scoped, we split the tick into its 387 -- two components, often allowing us to keep the counting tick on 388 -- the outside of the lambda and push the scoped tick inside. 389 -- The point of this is that the counting tick can probably be 390 -- floated, and the lambda may then be in a position to be 391 -- beta-reduced. 392 | canSplit 393 -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e 394 395 App f arg 396 -- Always float through type applications. 397 | not (isRuntimeArg arg) 398 -> mkTick' (top . flip App arg) rest f 399 400 -- We can also float through constructor applications, placement 401 -- permitting. Again we can split. 402 | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) 403 -> if tickishPlace t == PlaceCostCentre 404 then top $ rest $ tickHNFArgs t expr 405 else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr 406 407 Var x 408 | notFunction && tickishPlace t == PlaceCostCentre 409 -> orig_expr 410 | notFunction && canSplit 411 -> top $ Tick (mkNoScope t) $ rest expr 412 where 413 -- SCCs can be eliminated on variables provided the variable 414 -- is not a function. In these cases the SCC makes no difference: 415 -- the cost of evaluating the variable will be attributed to its 416 -- definition site. When the variable refers to a function, however, 417 -- an SCC annotation on the variable affects the cost-centre stack 418 -- when the function is called, so we must retain those. 419 notFunction = not (isFunTy (idType x)) 420 421 Lit{} 422 | tickishPlace t == PlaceCostCentre 423 -> orig_expr 424 425 -- Catch-all: Annotate where we stand 426 _any -> top $ Tick t $ rest expr 427 428mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr 429mkTicks ticks expr = foldr mkTick expr ticks 430 431isSaturatedConApp :: CoreExpr -> Bool 432isSaturatedConApp e = go e [] 433 where go (App f a) as = go f (a:as) 434 go (Var fun) args 435 = isConLikeId fun && idArity fun == valArgCount args 436 go (Cast f _) as = go f as 437 go _ _ = False 438 439mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr 440mkTickNoHNF t e 441 | exprIsHNF e = tickHNFArgs t e 442 | otherwise = mkTick t e 443 444-- push a tick into the arguments of a HNF (call or constructor app) 445tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr 446tickHNFArgs t e = push t e 447 where 448 push t (App f (Type u)) = App (push t f) (Type u) 449 push t (App f arg) = App (push t f) (mkTick t arg) 450 push _t e = e 451 452-- | Strip ticks satisfying a predicate from top of an expression 453stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b) 454stripTicksTop p = go [] 455 where go ts (Tick t e) | p t = go (t:ts) e 456 go ts other = (reverse ts, other) 457 458-- | Strip ticks satisfying a predicate from top of an expression, 459-- returning the remaining expression 460stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b 461stripTicksTopE p = go 462 where go (Tick t e) | p t = go e 463 go other = other 464 465-- | Strip ticks satisfying a predicate from top of an expression, 466-- returning the ticks 467stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] 468stripTicksTopT p = go [] 469 where go ts (Tick t e) | p t = go (t:ts) e 470 go ts _ = ts 471 472-- | Completely strip ticks satisfying a predicate from an 473-- expression. Note this is O(n) in the size of the expression! 474stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b 475stripTicksE p expr = go expr 476 where go (App e a) = App (go e) (go a) 477 go (Lam b e) = Lam b (go e) 478 go (Let b e) = Let (go_bs b) (go e) 479 go (Case e b t as) = Case (go e) b t (map go_a as) 480 go (Cast e c) = Cast (go e) c 481 go (Tick t e) 482 | p t = go e 483 | otherwise = Tick t (go e) 484 go other = other 485 go_bs (NonRec b e) = NonRec b (go e) 486 go_bs (Rec bs) = Rec (map go_b bs) 487 go_b (b, e) = (b, go e) 488 go_a (Alt c bs e) = Alt c bs (go e) 489 490stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] 491stripTicksT p expr = fromOL $ go expr 492 where go (App e a) = go e `appOL` go a 493 go (Lam _ e) = go e 494 go (Let b e) = go_bs b `appOL` go e 495 go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) 496 go (Cast e _) = go e 497 go (Tick t e) 498 | p t = t `consOL` go e 499 | otherwise = go e 500 go _ = nilOL 501 go_bs (NonRec _ e) = go e 502 go_bs (Rec bs) = concatOL (map go_b bs) 503 go_b (_, e) = go e 504 go_a (Alt _ _ e) = go e 505 506{- 507************************************************************************ 508* * 509\subsection{Other expression construction} 510* * 511************************************************************************ 512-} 513 514bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr 515-- ^ @bindNonRec x r b@ produces either: 516-- 517-- > let x = r in b 518-- 519-- or: 520-- 521-- > case r of x { _DEFAULT_ -> b } 522-- 523-- depending on whether we have to use a @case@ or @let@ 524-- binding for the expression (see 'needsCaseBinding'). 525-- It's used by the desugarer to avoid building bindings 526-- that give Core Lint a heart attack, although actually 527-- the simplifier deals with them perfectly well. See 528-- also 'GHC.Core.Make.mkCoreLet' 529bindNonRec bndr rhs body 530 | isTyVar bndr = let_bind 531 | isCoVar bndr = if isCoArg rhs then let_bind 532 {- See Note [Binding coercions] -} else case_bind 533 | isJoinId bndr = let_bind 534 | needsCaseBinding (idType bndr) rhs = case_bind 535 | otherwise = let_bind 536 where 537 case_bind = mkDefaultCase rhs bndr body 538 let_bind = Let (NonRec bndr rhs) body 539 540-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression 541-- as per the invariants of 'CoreExpr': see "GHC.Core#let_app_invariant" 542needsCaseBinding :: Type -> CoreExpr -> Bool 543needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs) 544 -- Make a case expression instead of a let 545 -- These can arise either from the desugarer, 546 -- or from beta reductions: (\x.e) (x +# y) 547 548mkAltExpr :: AltCon -- ^ Case alternative constructor 549 -> [CoreBndr] -- ^ Things bound by the pattern match 550 -> [Type] -- ^ The type arguments to the case alternative 551 -> CoreExpr 552-- ^ This guy constructs the value that the scrutinee must have 553-- given that you are in one particular branch of a case 554mkAltExpr (DataAlt con) args inst_tys 555 = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) 556mkAltExpr (LitAlt lit) [] [] 557 = Lit lit 558mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" 559mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" 560 561mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr 562-- Make (case x of y { DEFAULT -> e } 563mkDefaultCase scrut case_bndr body 564 = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body] 565 566mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr 567-- Use this function if possible, when building a case, 568-- because it ensures that the type on the Case itself 569-- doesn't mention variables bound by the case 570-- See Note [Care with the type of a case expression] 571mkSingleAltCase scrut case_bndr con bndrs body 572 = Case scrut case_bndr case_ty [Alt con bndrs body] 573 where 574 body_ty = exprType body 575 576 case_ty -- See Note [Care with the type of a case expression] 577 | Just body_ty' <- occCheckExpand bndrs body_ty 578 = body_ty' 579 580 | otherwise 581 = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty) 582 583{- Note [Care with the type of a case expression] 584~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 585Consider a phantom type synonym 586 type S a = Int 587and we want to form the case expression 588 case x of K (a::*) -> (e :: S a) 589 590We must not make the type field of the case-expression (S a) because 591'a' isn't in scope. Hence the call to occCheckExpand. This caused 592issue #17056. 593 594NB: this situation can only arise with type synonyms, which can 595falsely "mention" type variables that aren't "really there", and which 596can be eliminated by expanding the synonym. 597 598Note [Binding coercions] 599~~~~~~~~~~~~~~~~~~~~~~~~ 600Consider binding a CoVar, c = e. Then, we must satisfy 601Note [Core type and coercion invariant] in GHC.Core, 602which allows only (Coercion co) on the RHS. 603 604************************************************************************ 605* * 606 Operations over case alternatives 607* * 608************************************************************************ 609 610The default alternative must be first, if it exists at all. 611This makes it easy to find, though it makes matching marginally harder. 612-} 613 614-- | Extract the default case alternative 615findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b)) 616findDefault (Alt DEFAULT args rhs : alts) = ASSERT( null args ) (alts, Just rhs) 617findDefault alts = (alts, Nothing) 618 619addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b] 620addDefault alts Nothing = alts 621addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts 622 623isDefaultAlt :: Alt b -> Bool 624isDefaultAlt (Alt DEFAULT _ _) = True 625isDefaultAlt _ = False 626 627-- | Find the case alternative corresponding to a particular 628-- constructor: panics if no such constructor exists 629findAlt :: AltCon -> [Alt b] -> Maybe (Alt b) 630 -- A "Nothing" result *is* legitimate 631 -- See Note [Unreachable code] 632findAlt con alts 633 = case alts of 634 (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt) 635 _ -> go alts Nothing 636 where 637 go [] deflt = deflt 638 go (alt@(Alt con1 _ _) : alts) deflt 639 = case con `cmpAltCon` con1 of 640 LT -> deflt -- Missed it already; the alts are in increasing order 641 EQ -> Just alt 642 GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt 643 644{- Note [Unreachable code] 645~~~~~~~~~~~~~~~~~~~~~~~~~~ 646It is possible (although unusual) for GHC to find a case expression 647that cannot match. For example: 648 649 data Col = Red | Green | Blue 650 x = Red 651 f v = case x of 652 Red -> ... 653 _ -> ...(case x of { Green -> e1; Blue -> e2 })... 654 655Suppose that for some silly reason, x isn't substituted in the case 656expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff 657gets in the way; cf #3118.) Then the full-laziness pass might produce 658this 659 660 x = Red 661 lvl = case x of { Green -> e1; Blue -> e2 }) 662 f v = case x of 663 Red -> ... 664 _ -> ...lvl... 665 666Now if x gets inlined, we won't be able to find a matching alternative 667for 'Red'. That's because 'lvl' is unreachable. So rather than crashing 668we generate (error "Inaccessible alternative"). 669 670Similar things can happen (augmented by GADTs) when the Simplifier 671filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase. 672-} 673 674--------------------------------- 675mergeAlts :: [Alt a] -> [Alt a] -> [Alt a] 676-- ^ Merge alternatives preserving order; alternatives in 677-- the first argument shadow ones in the second 678mergeAlts [] as2 = as2 679mergeAlts as1 [] = as1 680mergeAlts (a1:as1) (a2:as2) 681 = case a1 `cmpAlt` a2 of 682 LT -> a1 : mergeAlts as1 (a2:as2) 683 EQ -> a1 : mergeAlts as1 as2 -- Discard a2 684 GT -> a2 : mergeAlts (a1:as1) as2 685 686 687--------------------------------- 688trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] 689-- ^ Given: 690-- 691-- > case (C a b x y) of 692-- > C b x y -> ... 693-- 694-- We want to drop the leading type argument of the scrutinee 695-- leaving the arguments to match against the pattern 696 697trimConArgs DEFAULT args = ASSERT( null args ) [] 698trimConArgs (LitAlt _) args = ASSERT( null args ) [] 699trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args 700 701filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) 702 -> [Type] -- ^ And its type arguments 703 -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee 704 -> [Alt b] -- ^ Alternatives 705 -> ([AltCon], [Alt b]) 706 -- Returns: 707 -- 1. Constructors that will never be encountered by the 708 -- *default* case (if any). A superset of imposs_cons 709 -- 2. The new alternatives, trimmed by 710 -- a) remove imposs_cons 711 -- b) remove constructors which can't match because of GADTs 712 -- 713 -- NB: the final list of alternatives may be empty: 714 -- This is a tricky corner case. If the data type has no constructors, 715 -- which GHC allows, or if the imposs_cons covers all constructors (after taking 716 -- account of GADTs), then no alternatives can match. 717 -- 718 -- If callers need to preserve the invariant that there is always at least one branch 719 -- in a "case" statement then they will need to manually add a dummy case branch that just 720 -- calls "error" or similar. 721filterAlts _tycon inst_tys imposs_cons alts 722 = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) 723 where 724 (alts_wo_default, maybe_deflt) = findDefault alts 725 alt_cons = [con | Alt con _ _ <- alts_wo_default] 726 727 trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default 728 729 imposs_cons_set = Set.fromList imposs_cons 730 imposs_deflt_cons = 731 imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons 732 -- "imposs_deflt_cons" are handled 733 -- EITHER by the context, 734 -- OR by a non-DEFAULT branch in this case expression. 735 736 impossible_alt :: [Type] -> Alt b -> Bool 737 impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True 738 impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con 739 impossible_alt _ _ = False 740 741-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. 742-- See Note [Refine DEFAULT case alternatives] 743refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders 744 -> Mult -- ^ Multiplicity annotation of the case expression 745 -> TyCon -- ^ Type constructor of scrutinee's type 746 -> [Type] -- ^ Type arguments of scrutinee's type 747 -> [AltCon] -- ^ Constructors that cannot match the DEFAULT (if any) 748 -> [CoreAlt] 749 -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' 750refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts 751 | Alt DEFAULT _ rhs : rest_alts <- all_alts 752 , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. 753 , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: 754 -- case x of { DEFAULT -> e } 755 -- and we don't want to fill in a default for them! 756 , Just all_cons <- tyConDataCons_maybe tycon 757 , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] 758 -- We now know it's a data type, so we can use 759 -- UniqSet rather than Set (more efficient) 760 impossible con = con `elementOfUniqSet` imposs_data_cons 761 || dataConCannotMatch tys con 762 = case filterOut impossible all_cons of 763 -- Eliminate the default alternative 764 -- altogether if it can't match: 765 [] -> (False, rest_alts) 766 767 -- It matches exactly one constructor, so fill it in: 768 [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs]) 769 -- We need the mergeAlts to keep the alternatives in the right order 770 where 771 (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys 772 773 -- It matches more than one, so do nothing 774 _ -> (False, all_alts) 775 776 | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon) 777 , not (isFamilyTyCon tycon || isAbstractTyCon tycon) 778 -- Check for no data constructors 779 -- This can legitimately happen for abstract types and type families, 780 -- so don't report that 781 = (False, all_alts) 782 783 | otherwise -- The common case 784 = (False, all_alts) 785 786{- Note [Refine DEFAULT case alternatives] 787~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 788refineDefaultAlt replaces the DEFAULT alt with a constructor if there 789is one possible value it could be. 790 791The simplest example being 792 foo :: () -> () 793 foo x = case x of !_ -> () 794which rewrites to 795 foo :: () -> () 796 foo x = case x of () -> () 797 798There are two reasons in general why replacing a DEFAULT alternative 799with a specific constructor is desirable. 800 8011. We can simplify inner expressions. For example 802 803 data Foo = Foo1 () 804 805 test :: Foo -> () 806 test x = case x of 807 DEFAULT -> mid (case x of 808 Foo1 x1 -> x1) 809 810 refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then 811 x becomes bound to `Foo ip1` so is inlined into the other case 812 which causes the KnownBranch optimisation to kick in. If we don't 813 refine DEFAULT to `Foo ip1`, we are left with both case expressions. 814 8152. combineIdenticalAlts does a better job. For exapple (Simon Jacobi) 816 data D = C0 | C1 | C2 817 818 case e of 819 DEFAULT -> e0 820 C0 -> e1 821 C1 -> e1 822 823 When we apply combineIdenticalAlts to this expression, it can't 824 combine the alts for C0 and C1, as we already have a default case. 825 But if we apply refineDefaultAlt first, we get 826 case e of 827 C0 -> e1 828 C1 -> e1 829 C2 -> e0 830 and combineIdenticalAlts can turn that into 831 case e of 832 DEFAULT -> e1 833 C2 -> e0 834 835 It isn't obvious that refineDefaultAlt does this but if you look 836 at its one call site in GHC.Core.Opt.Simplify.Utils then the 837 `imposs_deflt_cons` argument is populated with constructors which 838 are matched elsewhere. 839 840Note [Combine identical alternatives] 841~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 842If several alternatives are identical, merge them into a single 843DEFAULT alternative. I've occasionally seen this making a big 844difference: 845 846 case e of =====> case e of 847 C _ -> f x D v -> ....v.... 848 D v -> ....v.... DEFAULT -> f x 849 DEFAULT -> f x 850 851The point is that we merge common RHSs, at least for the DEFAULT case. 852[One could do something more elaborate but I've never seen it needed.] 853To avoid an expensive test, we just merge branches equal to the *first* 854alternative; this picks up the common cases 855 a) all branches equal 856 b) some branches equal to the DEFAULT (which occurs first) 857 858The case where Combine Identical Alternatives transformation showed up 859was like this (base/Foreign/C/Err/Error.hs): 860 861 x | p `is` 1 -> e1 862 | p `is` 2 -> e2 863 ...etc... 864 865where @is@ was something like 866 867 p `is` n = p /= (-1) && p == n 868 869This gave rise to a horrible sequence of cases 870 871 case p of 872 (-1) -> $j p 873 1 -> e1 874 DEFAULT -> $j p 875 876and similarly in cascade for all the join points! 877 878Note [Combine identical alternatives: wrinkles] 879~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 880 881* It's important that we try to combine alternatives *before* 882 simplifying them, rather than after. Reason: because 883 Simplify.simplAlt may zap the occurrence info on the binders in the 884 alternatives, which in turn defeats combineIdenticalAlts use of 885 isDeadBinder (see #7360). 886 887 You can see this in the call to combineIdenticalAlts in 888 GHC.Core.Opt.Simplify.Utils.prepareAlts. Here the alternatives have type InAlt 889 (the "In" meaning input) rather than OutAlt. 890 891* combineIdenticalAlts does not work well for nullary constructors 892 case x of y 893 [] -> f [] 894 (_:_) -> f y 895 Here we won't see that [] and y are the same. Sigh! This problem 896 is solved in CSE, in GHC.Core.Opt.CSE.combineAlts, which does a better version 897 of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have 898 here. 899 See Note [Combine case alts: awkward corner] in GHC.Core.Opt.CSE). 900 901Note [Care with impossible-constructors when combining alternatives] 902~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 903Suppose we have (#10538) 904 data T = A | B | C | D 905 906 case x::T of (Imposs-default-cons {A,B}) 907 DEFAULT -> e1 908 A -> e2 909 B -> e1 910 911When calling combineIdentialAlts, we'll have computed that the 912"impossible constructors" for the DEFAULT alt is {A,B}, since if x is 913A or B we'll take the other alternatives. But suppose we combine B 914into the DEFAULT, to get 915 916 case x::T of (Imposs-default-cons {A}) 917 DEFAULT -> e1 918 A -> e2 919 920Then we must be careful to trim the impossible constructors to just {A}, 921else we risk compiling 'e1' wrong! 922 923Not only that, but we take care when there is no DEFAULT beforehand, 924because we are introducing one. Consider 925 926 case x of (Imposs-default-cons {A,B,C}) 927 A -> e1 928 B -> e2 929 C -> e1 930 931Then when combining the A and C alternatives we get 932 933 case x of (Imposs-default-cons {B}) 934 DEFAULT -> e1 935 B -> e2 936 937Note that we have a new DEFAULT branch that we didn't have before. So 938we need delete from the "impossible-default-constructors" all the 939known-con alternatives that we have eliminated. (In #11172 we 940missed the first one.) 941 942-} 943 944combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT 945 -> [CoreAlt] 946 -> (Bool, -- True <=> something happened 947 [AltCon], -- New constructors that cannot match DEFAULT 948 [CoreAlt]) -- New alternatives 949-- See Note [Combine identical alternatives] 950-- True <=> we did some combining, result is a single DEFAULT alternative 951combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts) 952 | all isDeadBinder bndrs1 -- Remember the default 953 , not (null elim_rest) -- alternative comes first 954 = (True, imposs_deflt_cons', deflt_alt : filtered_rest) 955 where 956 (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts 957 deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1) 958 959 -- See Note [Care with impossible-constructors when combining alternatives] 960 imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons 961 elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest 962 elim_con1 = case con1 of -- Don't forget con1! 963 DEFAULT -> [] -- See Note [ 964 _ -> [con1] 965 966 cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 967 identical_to_alt1 (Alt _con bndrs rhs) 968 = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 969 tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest 970 971combineIdenticalAlts imposs_cons alts 972 = (False, imposs_cons, alts) 973 974-- Scales the multiplicity of the binders of a list of case alternatives. That 975-- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled. 976scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt] 977scaleAltsBy w alts = map scaleAlt alts 978 where 979 scaleAlt :: CoreAlt -> CoreAlt 980 scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs 981 982 scaleBndr :: CoreBndr -> CoreBndr 983 scaleBndr b = scaleVarBy w b 984 985 986{- ********************************************************************* 987* * 988 exprIsTrivial 989* * 990************************************************************************ 991 992Note [exprIsTrivial] 993~~~~~~~~~~~~~~~~~~~~ 994@exprIsTrivial@ is true of expressions we are unconditionally happy to 995 duplicate; simple variables and constants, and type 996 applications. Note that primop Ids aren't considered 997 trivial unless 998 999Note [Variables are trivial] 1000~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1001There used to be a gruesome test for (hasNoBinding v) in the 1002Var case: 1003 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 1004The idea here is that a constructor worker, like \$wJust, is 1005really short for (\x -> \$wJust x), because \$wJust has no binding. 1006So it should be treated like a lambda. Ditto unsaturated primops. 1007But now constructor workers are not "have-no-binding" Ids. And 1008completely un-applied primops and foreign-call Ids are sufficiently 1009rare that I plan to allow them to be duplicated and put up with 1010saturating them. 1011 1012Note [Tick trivial] 1013~~~~~~~~~~~~~~~~~~~ 1014Ticks are only trivial if they are pure annotations. If we treat 1015"tick<n> x" as trivial, it will be inlined inside lambdas and the 1016entry count will be skewed, for example. Furthermore "scc<n> x" will 1017turn into just "x" in mkTick. 1018 1019Note [Empty case is trivial] 1020~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1021The expression (case (x::Int) Bool of {}) is just a type-changing 1022case used when we are sure that 'x' will not return. See 1023Note [Empty case alternatives] in GHC.Core. 1024 1025If the scrutinee is trivial, then so is the whole expression; and the 1026CoreToSTG pass in fact drops the case expression leaving only the 1027scrutinee. 1028 1029Having more trivial expressions is good. Moreover, if we don't treat 1030it as trivial we may land up with let-bindings like 1031 let v = case x of {} in ... 1032and after CoreToSTG that gives 1033 let v = x in ... 1034and that confuses the code generator (#11155). So best to kill 1035it off at source. 1036-} 1037 1038exprIsTrivial :: CoreExpr -> Bool 1039-- If you modify this function, you may also 1040-- need to modify getIdFromTrivialExpr 1041exprIsTrivial (Var _) = True -- See Note [Variables are trivial] 1042exprIsTrivial (Type _) = True 1043exprIsTrivial (Coercion _) = True 1044exprIsTrivial (Lit lit) = litIsTrivial lit 1045exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e 1046exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e 1047exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e 1048 -- See Note [Tick trivial] 1049exprIsTrivial (Cast e _) = exprIsTrivial e 1050exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial] 1051exprIsTrivial _ = False 1052 1053{- 1054Note [getIdFromTrivialExpr] 1055~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1056When substituting in a breakpoint we need to strip away the type cruft 1057from a trivial expression and get back to the Id. The invariant is 1058that the expression we're substituting was originally trivial 1059according to exprIsTrivial, AND the expression is not a literal. 1060See Note [substTickish] for how breakpoint substitution preserves 1061this extra invariant. 1062 1063We also need this functionality in CorePrep to extract out Id of a 1064function which we are saturating. However, in this case we don't know 1065if the variable actually refers to a literal; thus we use 1066'getIdFromTrivialExpr_maybe' to handle this case. See test 1067T12076lit for an example where this matters. 1068-} 1069 1070getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id 1071getIdFromTrivialExpr e 1072 = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e)) 1073 (getIdFromTrivialExpr_maybe e) 1074 1075getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id 1076-- See Note [getIdFromTrivialExpr] 1077-- Th equations for this should line up with those for exprIsTrivial 1078getIdFromTrivialExpr_maybe e 1079 = go e 1080 where 1081 go (App f t) | not (isRuntimeArg t) = go f 1082 go (Tick t e) | not (tickishIsCode t) = go e 1083 go (Cast e _) = go e 1084 go (Lam b e) | not (isRuntimeVar b) = go e 1085 go (Case e _ _ []) = go e 1086 go (Var v) = Just v 1087 go _ = Nothing 1088 1089{- 1090exprIsDeadEnd is a very cheap and cheerful function; it may return 1091False for bottoming expressions, but it never costs much to ask. See 1092also GHC.Core.Opt.Arity.exprBotStrictness_maybe, but that's a bit more 1093expensive. 1094-} 1095 1096exprIsDeadEnd :: CoreExpr -> Bool 1097-- See Note [Bottoming expressions] 1098exprIsDeadEnd e 1099 | isEmptyTy (exprType e) 1100 = True 1101 | otherwise 1102 = go 0 e 1103 where 1104 go n (Var v) = isDeadEndId v && n >= idArity v 1105 go n (App e a) | isTypeArg a = go n e 1106 | otherwise = go (n+1) e 1107 go n (Tick _ e) = go n e 1108 go n (Cast e _) = go n e 1109 go n (Let _ e) = go n e 1110 go n (Lam v e) | isTyVar v = go n e 1111 go _ (Case _ _ _ alts) = null alts 1112 -- See Note [Empty case alternatives] in GHC.Core 1113 go _ _ = False 1114 1115{- Note [Bottoming expressions] 1116~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1117A bottoming expression is guaranteed to diverge, or raise an 1118exception. We can test for it in two different ways, and exprIsDeadEnd 1119checks for both of these situations: 1120 1121* Visibly-bottom computations. For example 1122 (error Int "Hello") 1123 is visibly bottom. The strictness analyser also finds out if 1124 a function diverges or raises an exception, and puts that info 1125 in its strictness signature. 1126 1127* Empty types. If a type is empty, its only inhabitant is bottom. 1128 For example: 1129 data T 1130 f :: T -> Bool 1131 f = \(x:t). case x of Bool {} 1132 Since T has no data constructors, the case alternatives are of course 1133 empty. However note that 'x' is not bound to a visibly-bottom value; 1134 it's the *type* that tells us it's going to diverge. 1135 1136A GADT may also be empty even though it has constructors: 1137 data T a where 1138 T1 :: a -> T Bool 1139 T2 :: T Int 1140 ...(case (x::T Char) of {})... 1141Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), 1142which is likewise uninhabited. 1143 1144 1145************************************************************************ 1146* * 1147 exprIsDupable 1148* * 1149************************************************************************ 1150 1151Note [exprIsDupable] 1152~~~~~~~~~~~~~~~~~~~~ 1153@exprIsDupable@ is true of expressions that can be duplicated at a modest 1154 cost in code size. This will only happen in different case 1155 branches, so there's no issue about duplicating work. 1156 1157 That is, exprIsDupable returns True of (f x) even if 1158 f is very very expensive to call. 1159 1160 Its only purpose is to avoid fruitless let-binding 1161 and then inlining of case join points 1162-} 1163 1164exprIsDupable :: Platform -> CoreExpr -> Bool 1165exprIsDupable platform e 1166 = isJust (go dupAppSize e) 1167 where 1168 go :: Int -> CoreExpr -> Maybe Int 1169 go n (Type {}) = Just n 1170 go n (Coercion {}) = Just n 1171 go n (Var {}) = decrement n 1172 go n (Tick _ e) = go n e 1173 go n (Cast e _) = go n e 1174 go n (App f a) | Just n' <- go n a = go n' f 1175 go n (Lit lit) | litIsDupable platform lit = decrement n 1176 go _ _ = Nothing 1177 1178 decrement :: Int -> Maybe Int 1179 decrement 0 = Nothing 1180 decrement n = Just (n-1) 1181 1182dupAppSize :: Int 1183dupAppSize = 8 -- Size of term we are prepared to duplicate 1184 -- This is *just* big enough to make test MethSharing 1185 -- inline enough join points. Really it should be 1186 -- smaller, and could be if we fixed #4960. 1187 1188{- 1189************************************************************************ 1190* * 1191 exprIsCheap, exprIsExpandable 1192* * 1193************************************************************************ 1194 1195Note [exprIsWorkFree] 1196~~~~~~~~~~~~~~~~~~~~~ 1197exprIsWorkFree is used when deciding whether to inline something; we 1198don't inline it if doing so might duplicate work, by peeling off a 1199complete copy of the expression. Here we do not want even to 1200duplicate a primop (#5623): 1201 eg let x = a #+ b in x +# x 1202 we do not want to inline/duplicate x 1203 1204Previously we were a bit more liberal, which led to the primop-duplicating 1205problem. However, being more conservative did lead to a big regression in 1206one nofib benchmark, wheel-sieve1. The situation looks like this: 1207 1208 let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool 1209 noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> 1210 case GHC.Prim.<=# x_aRs 2 of _ { 1211 GHC.Types.False -> notDivBy ps_adM qs_adN; 1212 GHC.Types.True -> lvl_r2Eb }} 1213 go = \x. ...(noFactor (I# y))....(go x')... 1214 1215The function 'noFactor' is heap-allocated and then called. Turns out 1216that 'notDivBy' is strict in its THIRD arg, but that is invisible to 1217the caller of noFactor, which therefore cannot do w/w and 1218heap-allocates noFactor's argument. At the moment (May 12) we are just 1219going to put up with this, because the previous more aggressive inlining 1220(which treated 'noFactor' as work-free) was duplicating primops, which 1221in turn was making inner loops of array calculations runs slow (#5623) 1222 1223Note [Case expressions are work-free] 1224~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1225Are case-expressions work-free? Consider 1226 let v = case x of (p,q) -> p 1227 go = \y -> ...case v of ... 1228Should we inline 'v' at its use site inside the loop? At the moment 1229we do. I experimented with saying that case are *not* work-free, but 1230that increased allocation slightly. It's a fairly small effect, and at 1231the moment we go for the slightly more aggressive version which treats 1232(case x of ....) as work-free if the alternatives are. 1233 1234Moreover it improves arities of overloaded functions where 1235there is only dictionary selection (no construction) involved 1236 1237Note [exprIsCheap] 1238~~~~~~~~~~~~~~~~~~ 1239 1240See also Note [Interaction of exprIsCheap and lone variables] in GHC.Core.Unfold 1241 1242@exprIsCheap@ looks at a Core expression and returns \tr{True} if 1243it is obviously in weak head normal form, or is cheap to get to WHNF. 1244[Note that that's not the same as exprIsDupable; an expression might be 1245big, and hence not dupable, but still cheap.] 1246 1247By ``cheap'' we mean a computation we're willing to: 1248 push inside a lambda, or 1249 inline at more than one place 1250That might mean it gets evaluated more than once, instead of being 1251shared. The main examples of things which aren't WHNF but are 1252``cheap'' are: 1253 1254 * case e of 1255 pi -> ei 1256 (where e, and all the ei are cheap) 1257 1258 * let x = e in b 1259 (where e and b are cheap) 1260 1261 * op x1 ... xn 1262 (where op is a cheap primitive operator) 1263 1264 * error "foo" 1265 (because we are happy to substitute it inside a lambda) 1266 1267Notice that a variable is considered 'cheap': we can push it inside a lambda, 1268because sharing will make sure it is only evaluated once. 1269 1270Note [exprIsCheap and exprIsHNF] 1271~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1272Note that exprIsHNF does not imply exprIsCheap. Eg 1273 let x = fac 20 in Just x 1274This responds True to exprIsHNF (you can discard a seq), but 1275False to exprIsCheap. 1276 1277Note [Arguments and let-bindings exprIsCheapX] 1278~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1279What predicate should we apply to the argument of an application, or the 1280RHS of a let-binding? 1281 1282We used to say "exprIsTrivial arg" due to concerns about duplicating 1283nested constructor applications, but see #4978. So now we just recursively 1284use exprIsCheapX. 1285 1286We definitely want to treat let and app the same. The principle here is 1287that 1288 let x = blah in f x 1289should behave equivalently to 1290 f blah 1291 1292This in turn means that the 'letrec g' does not prevent eta expansion 1293in this (which it previously was): 1294 f = \x. let v = case x of 1295 True -> letrec g = \w. blah 1296 in g 1297 False -> \x. x 1298 in \w. v True 1299-} 1300 1301-------------------- 1302exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] 1303exprIsWorkFree = exprIsCheapX isWorkFreeApp 1304 1305exprIsCheap :: CoreExpr -> Bool 1306exprIsCheap = exprIsCheapX isCheapApp 1307 1308exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool 1309exprIsCheapX ok_app e 1310 = ok e 1311 where 1312 ok e = go 0 e 1313 1314 -- n is the number of value arguments 1315 go n (Var v) = ok_app v n 1316 go _ (Lit {}) = True 1317 go _ (Type {}) = True 1318 go _ (Coercion {}) = True 1319 go n (Cast e _) = go n e 1320 go n (Case scrut _ _ alts) = ok scrut && 1321 and [ go n rhs | Alt _ _ rhs <- alts ] 1322 go n (Tick t e) | tickishCounts t = False 1323 | otherwise = go n e 1324 go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e 1325 | otherwise = go n e 1326 go n (App f e) | isRuntimeArg e = go (n+1) f && ok e 1327 | otherwise = go n f 1328 go n (Let (NonRec _ r) e) = go n e && ok r 1329 go n (Let (Rec prs) e) = go n e && all (ok . snd) prs 1330 1331 -- Case: see Note [Case expressions are work-free] 1332 -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] 1333 1334 1335{- Note [exprIsExpandable] 1336~~~~~~~~~~~~~~~~~~~~~~~~~~ 1337An expression is "expandable" if we are willing to duplicate it, if doing 1338so might make a RULE or case-of-constructor fire. Consider 1339 let x = (a,b) 1340 y = build g 1341 in ....(case x of (p,q) -> rhs)....(foldr k z y).... 1342 1343We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), 1344but we do want 1345 1346 * the case-expression to simplify 1347 (via exprIsConApp_maybe, exprIsLiteral_maybe) 1348 1349 * the foldr/build RULE to fire 1350 (by expanding the unfolding during rule matching) 1351 1352So we classify the unfolding of a let-binding as "expandable" (via the 1353uf_expandable field) if we want to do this kind of on-the-fly 1354expansion. Specifically: 1355 1356* True of constructor applications (K a b) 1357 1358* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. 1359 (NB: exprIsCheap might not be true of this) 1360 1361* False of case-expressions. If we have 1362 let x = case ... in ...(case x of ...)... 1363 we won't simplify. We have to inline x. See #14688. 1364 1365* False of let-expressions (same reason); and in any case we 1366 float lets out of an RHS if doing so will reveal an expandable 1367 application (see SimplEnv.doFloatFromRhs). 1368 1369* Take care: exprIsExpandable should /not/ be true of primops. I 1370 found this in test T5623a: 1371 let q = /\a. Ptr a (a +# b) 1372 in case q @ Float of Ptr v -> ...q... 1373 1374 q's inlining should not be expandable, else exprIsConApp_maybe will 1375 say that (q @ Float) expands to (Ptr a (a +# b)), and that will 1376 duplicate the (a +# b) primop, which we should not do lightly. 1377 (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) 1378-} 1379 1380------------------------------------- 1381exprIsExpandable :: CoreExpr -> Bool 1382-- See Note [exprIsExpandable] 1383exprIsExpandable e 1384 = ok e 1385 where 1386 ok e = go 0 e 1387 1388 -- n is the number of value arguments 1389 go n (Var v) = isExpandableApp v n 1390 go _ (Lit {}) = True 1391 go _ (Type {}) = True 1392 go _ (Coercion {}) = True 1393 go n (Cast e _) = go n e 1394 go n (Tick t e) | tickishCounts t = False 1395 | otherwise = go n e 1396 go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e 1397 | otherwise = go n e 1398 go n (App f e) | isRuntimeArg e = go (n+1) f && ok e 1399 | otherwise = go n f 1400 go _ (Case {}) = False 1401 go _ (Let {}) = False 1402 1403 1404------------------------------------- 1405type CheapAppFun = Id -> Arity -> Bool 1406 -- Is an application of this function to n *value* args 1407 -- always cheap, assuming the arguments are cheap? 1408 -- True mainly of data constructors, partial applications; 1409 -- but with minor variations: 1410 -- isWorkFreeApp 1411 -- isCheapApp 1412 1413isWorkFreeApp :: CheapAppFun 1414isWorkFreeApp fn n_val_args 1415 | n_val_args == 0 -- No value args 1416 = True 1417 | n_val_args < idArity fn -- Partial application 1418 = True 1419 | otherwise 1420 = case idDetails fn of 1421 DataConWorkId {} -> True 1422 _ -> False 1423 1424isCheapApp :: CheapAppFun 1425isCheapApp fn n_val_args 1426 | isWorkFreeApp fn n_val_args = True 1427 | isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions] 1428 | otherwise 1429 = case idDetails fn of 1430 DataConWorkId {} -> True -- Actually handled by isWorkFreeApp 1431 RecSelId {} -> n_val_args == 1 -- See Note [Record selection] 1432 ClassOpId {} -> n_val_args == 1 1433 PrimOpId op -> primOpIsCheap op 1434 _ -> False 1435 -- In principle we should worry about primops 1436 -- that return a type variable, since the result 1437 -- might be applied to something, but I'm not going 1438 -- to bother to check the number of args 1439 1440isExpandableApp :: CheapAppFun 1441isExpandableApp fn n_val_args 1442 | isWorkFreeApp fn n_val_args = True 1443 | otherwise 1444 = case idDetails fn of 1445 RecSelId {} -> n_val_args == 1 -- See Note [Record selection] 1446 ClassOpId {} -> n_val_args == 1 1447 PrimOpId {} -> False 1448 _ | isDeadEndId fn -> False 1449 -- See Note [isExpandableApp: bottoming functions] 1450 | isConLikeId fn -> True 1451 | all_args_are_preds -> True 1452 | otherwise -> False 1453 1454 where 1455 -- See if all the arguments are PredTys (implicit params or classes) 1456 -- If so we'll regard it as expandable; see Note [Expandable overloadings] 1457 all_args_are_preds = all_pred_args n_val_args (idType fn) 1458 1459 all_pred_args n_val_args ty 1460 | n_val_args == 0 1461 = True 1462 1463 | Just (bndr, ty) <- splitPiTy_maybe ty 1464 = case bndr of 1465 Named {} -> all_pred_args n_val_args ty 1466 Anon InvisArg _ -> all_pred_args (n_val_args-1) ty 1467 Anon VisArg _ -> False 1468 1469 | otherwise 1470 = False 1471 1472{- Note [isCheapApp: bottoming functions] 1473~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1474I'm not sure why we have a special case for bottoming 1475functions in isCheapApp. Maybe we don't need it. 1476 1477Note [isExpandableApp: bottoming functions] 1478~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1479It's important that isExpandableApp does not respond True to bottoming 1480functions. Recall undefined :: HasCallStack => a 1481Suppose isExpandableApp responded True to (undefined d), and we had: 1482 1483 x = undefined <dict-expr> 1484 1485Then Simplify.prepareRhs would ANF the RHS: 1486 1487 d = <dict-expr> 1488 x = undefined d 1489 1490This is already bad: we gain nothing from having x bound to (undefined 1491var), unlike the case for data constructors. Worse, we get the 1492simplifier loop described in OccurAnal Note [Cascading inlines]. 1493Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will 1494certainly_inline; so we end up inlining d right back into x; but in 1495the end x doesn't inline because it is bottom (preInlineUnconditionally); 1496so the process repeats.. We could elaborate the certainly_inline logic 1497some more, but it's better just to treat bottoming bindings as 1498non-expandable, because ANFing them is a bad idea in the first place. 1499 1500Note [Record selection] 1501~~~~~~~~~~~~~~~~~~~~~~~~~~ 1502I'm experimenting with making record selection 1503look cheap, so we will substitute it inside a 1504lambda. Particularly for dictionary field selection. 1505 1506BUT: Take care with (sel d x)! The (sel d) might be cheap, but 1507there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) 1508 1509Note [Expandable overloadings] 1510~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1511Suppose the user wrote this 1512 {-# RULE forall x. foo (negate x) = h x #-} 1513 f x = ....(foo (negate x)).... 1514They'd expect the rule to fire. But since negate is overloaded, we might 1515get this: 1516 f = \d -> let n = negate d in \x -> ...foo (n x)... 1517So we treat the application of a function (negate in this case) to a 1518*dictionary* as expandable. In effect, every function is CONLIKE when 1519it's applied only to dictionaries. 1520 1521 1522************************************************************************ 1523* * 1524 exprOkForSpeculation 1525* * 1526************************************************************************ 1527-} 1528 1529----------------------------- 1530-- | 'exprOkForSpeculation' returns True of an expression that is: 1531-- 1532-- * Safe to evaluate even if normal order eval might not 1533-- evaluate the expression at all, or 1534-- 1535-- * Safe /not/ to evaluate even if normal order would do so 1536-- 1537-- It is usually called on arguments of unlifted type, but not always 1538-- In particular, Simplify.rebuildCase calls it on lifted types 1539-- when a 'case' is a plain 'seq'. See the example in 1540-- Note [exprOkForSpeculation: case expressions] below 1541-- 1542-- Precisely, it returns @True@ iff: 1543-- a) The expression guarantees to terminate, 1544-- b) soon, 1545-- c) without causing a write side effect (e.g. writing a mutable variable) 1546-- d) without throwing a Haskell exception 1547-- e) without risking an unchecked runtime exception (array out of bounds, 1548-- divide by zero) 1549-- 1550-- For @exprOkForSideEffects@ the list is the same, but omitting (e). 1551-- 1552-- Note that 1553-- exprIsHNF implies exprOkForSpeculation 1554-- exprOkForSpeculation implies exprOkForSideEffects 1555-- 1556-- See Note [PrimOp can_fail and has_side_effects] in "GHC.Builtin.PrimOps" 1557-- and Note [Transformations affected by can_fail and has_side_effects] 1558-- 1559-- As an example of the considerations in this test, consider: 1560-- 1561-- > let x = case y# +# 1# of { r# -> I# r# } 1562-- > in E 1563-- 1564-- being translated to: 1565-- 1566-- > case y# +# 1# of { r# -> 1567-- > let x = I# r# 1568-- > in E 1569-- > } 1570-- 1571-- We can only do this if the @y + 1@ is ok for speculation: it has no 1572-- side effects, and can't diverge or raise an exception. 1573 1574exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool 1575exprOkForSpeculation = expr_ok primOpOkForSpeculation 1576exprOkForSideEffects = expr_ok primOpOkForSideEffects 1577 1578expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool 1579expr_ok _ (Lit _) = True 1580expr_ok _ (Type _) = True 1581expr_ok _ (Coercion _) = True 1582 1583expr_ok primop_ok (Var v) = app_ok primop_ok v [] 1584expr_ok primop_ok (Cast e _) = expr_ok primop_ok e 1585expr_ok primop_ok (Lam b e) 1586 | isTyVar b = expr_ok primop_ok e 1587 | otherwise = True 1588 1589-- Tick annotations that *tick* cannot be speculated, because these 1590-- are meant to identify whether or not (and how often) the particular 1591-- source expression was evaluated at runtime. 1592expr_ok primop_ok (Tick tickish e) 1593 | tickishCounts tickish = False 1594 | otherwise = expr_ok primop_ok e 1595 1596expr_ok _ (Let {}) = False 1597 -- Lets can be stacked deeply, so just give up. 1598 -- In any case, the argument of exprOkForSpeculation is 1599 -- usually in a strict context, so any lets will have been 1600 -- floated away. 1601 1602expr_ok primop_ok (Case scrut bndr _ alts) 1603 = -- See Note [exprOkForSpeculation: case expressions] 1604 expr_ok primop_ok scrut 1605 && isUnliftedType (idType bndr) 1606 && all (\(Alt _ _ rhs) -> expr_ok primop_ok rhs) alts 1607 && altsAreExhaustive alts 1608 1609expr_ok primop_ok other_expr 1610 | (expr, args) <- collectArgs other_expr 1611 = case stripTicksTopE (not . tickishCounts) expr of 1612 Var f -> app_ok primop_ok f args 1613 -- 'LitRubbish' is the only literal that can occur in the head of an 1614 -- application and will not be matched by the above case (Var /= Lit). 1615 Lit lit -> ASSERT( isRubbishLit lit ) True 1616 _ -> False 1617 1618----------------------------- 1619app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool 1620app_ok primop_ok fun args 1621 = case idDetails fun of 1622 DFunId new_type -> not new_type 1623 -- DFuns terminate, unless the dict is implemented 1624 -- with a newtype in which case they may not 1625 1626 DataConWorkId {} -> True 1627 -- The strictness of the constructor has already 1628 -- been expressed by its "wrapper", so we don't need 1629 -- to take the arguments into account 1630 1631 PrimOpId op 1632 | primOpIsDiv op 1633 , [arg1, Lit lit] <- args 1634 -> not (isZeroLit lit) && expr_ok primop_ok arg1 1635 -- Special case for dividing operations that fail 1636 -- In general they are NOT ok-for-speculation 1637 -- (which primop_ok will catch), but they ARE OK 1638 -- if the divisor is definitely non-zero. 1639 -- Often there is a literal divisor, and this 1640 -- can get rid of a thunk in an inner loop 1641 1642 | SeqOp <- op -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp] 1643 -> False -- for the special cases for SeqOp and DataToTagOp 1644 | DataToTagOp <- op 1645 -> False 1646 | KeepAliveOp <- op 1647 -> False 1648 1649 | otherwise 1650 -> primop_ok op -- Check the primop itself 1651 && and (zipWith primop_arg_ok arg_tys args) -- Check the arguments 1652 1653 _other -> isUnliftedType (idType fun) -- c.f. the Var case of exprIsHNF 1654 || idArity fun > n_val_args -- Partial apps 1655 -- NB: even in the nullary case, do /not/ check 1656 -- for evaluated-ness of the fun; 1657 -- see Note [exprOkForSpeculation and evaluated variables] 1658 where 1659 n_val_args = valArgCount args 1660 where 1661 (arg_tys, _) = splitPiTys (idType fun) 1662 1663 primop_arg_ok :: TyBinder -> CoreExpr -> Bool 1664 primop_arg_ok (Named _) _ = True -- A type argument 1665 primop_arg_ok (Anon _ ty) arg -- A term argument 1666 | isUnliftedType (scaledThing ty) = expr_ok primop_ok arg 1667 | otherwise = True -- See Note [Primops with lifted arguments] 1668 1669----------------------------- 1670altsAreExhaustive :: [Alt b] -> Bool 1671-- True <=> the case alternatives are definitely exhaustive 1672-- False <=> they may or may not be 1673altsAreExhaustive [] 1674 = False -- Should not happen 1675altsAreExhaustive (Alt con1 _ _ : alts) 1676 = case con1 of 1677 DEFAULT -> True 1678 LitAlt {} -> False 1679 DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1) 1680 -- It is possible to have an exhaustive case that does not 1681 -- enumerate all constructors, notably in a GADT match, but 1682 -- we behave conservatively here -- I don't think it's important 1683 -- enough to deserve special treatment 1684 1685{- Note [exprOkForSpeculation: case expressions] 1686~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1687exprOkForSpeculation accepts very special case expressions. 1688Reason: (a ==# b) is ok-for-speculation, but the litEq rules 1689in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to 1690 case a of { DEFAULT -> 0#; 3# -> 1# } 1691for excellent reasons described in 1692 GHC.Core.Opt.ConstantFold Note [The litEq rule: converting equality to case]. 1693So, annoyingly, we want that case expression to be 1694ok-for-speculation too. Bother. 1695 1696But we restrict it sharply: 1697 1698* We restrict it to unlifted scrutinees. Consider this: 1699 case x of y { 1700 DEFAULT -> ... (let v::Int# = case y of { True -> e1 1701 ; False -> e2 } 1702 in ...) ... 1703 1704 Does the RHS of v satisfy the let/app invariant? Previously we said 1705 yes, on the grounds that y is evaluated. But the binder-swap done 1706 by GHC.Core.Opt.SetLevels would transform the inner alternative to 1707 DEFAULT -> ... (let v::Int# = case x of { ... } 1708 in ...) .... 1709 which does /not/ satisfy the let/app invariant, because x is 1710 not evaluated. See Note [Binder-swap during float-out] 1711 in GHC.Core.Opt.SetLevels. To avoid this awkwardness it seems simpler 1712 to stick to unlifted scrutinees where the issue does not 1713 arise. 1714 1715* We restrict it to exhaustive alternatives. A non-exhaustive 1716 case manifestly isn't ok-for-speculation. for example, 1717 this is a valid program (albeit a slightly dodgy one) 1718 let v = case x of { B -> ...; C -> ... } 1719 in case x of 1720 A -> ... 1721 _ -> ...v...v.... 1722 Should v be considered ok-for-speculation? Its scrutinee may be 1723 evaluated, but the alternatives are incomplete so we should not 1724 evaluate it strictly. 1725 1726 Now, all this is for lifted types, but it'd be the same for any 1727 finite unlifted type. We don't have many of them, but we might 1728 add unlifted algebraic types in due course. 1729 1730 1731----- Historical note: #15696: -------- 1732 Previously GHC.Core.Opt.SetLevels used exprOkForSpeculation to guide 1733 floating of single-alternative cases; it now uses exprIsHNF 1734 Note [Floating single-alternative cases]. 1735 1736 But in those days, consider 1737 case e of x { DEAFULT -> 1738 ...(case x of y 1739 A -> ... 1740 _ -> ...(case (case x of { B -> p; C -> p }) of 1741 I# r -> blah)... 1742 If GHC.Core.Opt.SetLevels considers the inner nested case as 1743 ok-for-speculation it can do case-floating (in GHC.Core.Opt.SetLevels). 1744 So we'd float to: 1745 case e of x { DEAFULT -> 1746 case (case x of { B -> p; C -> p }) of I# r -> 1747 ...(case x of y 1748 A -> ... 1749 _ -> ...blah...)... 1750 which is utterly bogus (seg fault); see #5453. 1751 1752----- Historical note: #3717: -------- 1753 foo :: Int -> Int 1754 foo 0 = 0 1755 foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) 1756 1757In earlier GHCs, we got this: 1758 T.$wfoo = 1759 \ (ww :: GHC.Prim.Int#) -> 1760 case ww of ds { 1761 __DEFAULT -> case (case <# ds 5 of _ { 1762 GHC.Types.False -> lvl1; 1763 GHC.Types.True -> lvl}) 1764 of _ { __DEFAULT -> 1765 T.$wfoo (GHC.Prim.-# ds_XkE 1) }; 1766 0 -> 0 } 1767 1768Before join-points etc we could only get rid of two cases (which are 1769redundant) by recognising that the (case <# ds 5 of { ... }) is 1770ok-for-speculation, even though it has /lifted/ type. But now join 1771points do the job nicely. 1772------- End of historical note ------------ 1773 1774 1775Note [Primops with lifted arguments] 1776~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1777Is this ok-for-speculation (see #13027)? 1778 reallyUnsafePtrEq# a b 1779Well, yes. The primop accepts lifted arguments and does not 1780evaluate them. Indeed, in general primops are, well, primitive 1781and do not perform evaluation. 1782 1783Bottom line: 1784 * In exprOkForSpeculation we simply ignore all lifted arguments. 1785 * In the rare case of primops that /do/ evaluate their arguments, 1786 (namely DataToTagOp and SeqOp) return False; see 1787 Note [exprOkForSpeculation and evaluated variables] 1788 1789Note [exprOkForSpeculation and SeqOp/DataToTagOp] 1790~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1791Most primops with lifted arguments don't evaluate them 1792(see Note [Primops with lifted arguments]), so we can ignore 1793that argument entirely when doing exprOkForSpeculation. 1794 1795But DataToTagOp and SeqOp are exceptions to that rule. 1796For reasons described in Note [exprOkForSpeculation and 1797evaluated variables], we simply return False for them. 1798 1799Not doing this made #5129 go bad. 1800Lots of discussion in #15696. 1801 1802Note [exprOkForSpeculation and evaluated variables] 1803~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1804Recall that 1805 seq# :: forall a s. a -> State# s -> (# State# s, a #) 1806 dataToTag# :: forall a. a -> Int# 1807must always evaluate their first argument. 1808 1809Now consider these examples: 1810 * case x of y { DEFAULT -> ....y.... } 1811 Should 'y' (alone) be considered ok-for-speculation? 1812 1813 * case x of y { DEFAULT -> ....f (dataToTag# y)... } 1814 Should (dataToTag# y) be considered ok-for-spec? 1815 1816You could argue 'yes', because in the case alternative we know that 1817'y' is evaluated. But the binder-swap transformation, which is 1818extremely useful for float-out, changes these expressions to 1819 case x of y { DEFAULT -> ....x.... } 1820 case x of y { DEFAULT -> ....f (dataToTag# x)... } 1821 1822And now the expression does not obey the let/app invariant! Yikes! 1823Moreover we really might float (f (dataToTag# x)) outside the case, 1824and then it really, really doesn't obey the let/app invariant. 1825 1826The solution is simple: exprOkForSpeculation does not try to take 1827advantage of the evaluated-ness of (lifted) variables. And it returns 1828False (always) for DataToTagOp and SeqOp. 1829 1830Note that exprIsHNF /can/ and does take advantage of evaluated-ness; 1831it doesn't have the trickiness of the let/app invariant to worry about. 1832 1833************************************************************************ 1834* * 1835 exprIsHNF, exprIsConLike 1836* * 1837************************************************************************ 1838-} 1839 1840-- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] 1841-- ~~~~~~~~~~~~~~~~ 1842-- | exprIsHNF returns true for expressions that are certainly /already/ 1843-- evaluated to /head/ normal form. This is used to decide whether it's ok 1844-- to change: 1845-- 1846-- > case x of _ -> e 1847-- 1848-- into: 1849-- 1850-- > e 1851-- 1852-- and to decide whether it's safe to discard a 'seq'. 1853-- 1854-- So, it does /not/ treat variables as evaluated, unless they say they are. 1855-- However, it /does/ treat partial applications and constructor applications 1856-- as values, even if their arguments are non-trivial, provided the argument 1857-- type is lifted. For example, both of these are values: 1858-- 1859-- > (:) (f x) (map f xs) 1860-- > map (...redex...) 1861-- 1862-- because 'seq' on such things completes immediately. 1863-- 1864-- For unlifted argument types, we have to be careful: 1865-- 1866-- > C (f x :: Int#) 1867-- 1868-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't 1869-- happen: see "GHC.Core#let_app_invariant". This invariant states that arguments of 1870-- unboxed type must be ok-for-speculation (or trivial). 1871exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP 1872exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding 1873 1874-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as 1875-- data constructors. Conlike arguments are considered interesting by the 1876-- inliner. 1877exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP 1878exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding 1879 1880-- | Returns true for values or value-like expressions. These are lambdas, 1881-- constructors / CONLIKE functions (as determined by the function argument) 1882-- or PAPs. 1883-- 1884exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool 1885exprIsHNFlike is_con is_con_unf = is_hnf_like 1886 where 1887 is_hnf_like (Var v) -- NB: There are no value args at this point 1888 = id_app_is_value v 0 -- Catches nullary constructors, 1889 -- so that [] and () are values, for example 1890 -- and (e.g.) primops that don't have unfoldings 1891 || is_con_unf (idUnfolding v) 1892 -- Check the thing's unfolding; it might be bound to a value 1893 -- or to a guaranteed-evaluated variable (isEvaldUnfolding) 1894 -- Contrast with Note [exprOkForSpeculation and evaluated variables] 1895 -- We don't look through loop breakers here, which is a bit conservative 1896 -- but otherwise I worry that if an Id's unfolding is just itself, 1897 -- we could get an infinite loop 1898 1899 is_hnf_like (Lit _) = True 1900 is_hnf_like (Type _) = True -- Types are honorary Values; 1901 -- we don't mind copying them 1902 is_hnf_like (Coercion _) = True -- Same for coercions 1903 is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e 1904 is_hnf_like (Tick tickish e) = not (tickishCounts tickish) 1905 && is_hnf_like e 1906 -- See Note [exprIsHNF Tick] 1907 is_hnf_like (Cast e _) = is_hnf_like e 1908 is_hnf_like (App e a) 1909 | isValArg a = app_is_value e 1 1910 | otherwise = is_hnf_like e 1911 is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us 1912 is_hnf_like _ = False 1913 1914 -- 'n' is the number of value args to which the expression is applied 1915 -- And n>0: there is at least one value argument 1916 app_is_value :: CoreExpr -> Int -> Bool 1917 app_is_value (Var f) nva = id_app_is_value f nva 1918 app_is_value (Tick _ f) nva = app_is_value f nva 1919 app_is_value (Cast f _) nva = app_is_value f nva 1920 app_is_value (App f a) nva 1921 | isValArg a = app_is_value f (nva + 1) 1922 | otherwise = app_is_value f nva 1923 app_is_value _ _ = False 1924 1925 id_app_is_value id n_val_args 1926 = is_con id 1927 || idArity id > n_val_args 1928 || id `hasKey` absentErrorIdKey -- See Note [aBSENT_ERROR_ID] in GHC.Core.Make 1929 -- absentError behaves like an honorary data constructor 1930 1931 1932{- 1933Note [exprIsHNF Tick] 1934 1935We can discard source annotations on HNFs as long as they aren't 1936tick-like: 1937 1938 scc c (\x . e) => \x . e 1939 scc c (C x1..xn) => C x1..xn 1940 1941So we regard these as HNFs. Tick annotations that tick are not 1942regarded as HNF if the expression they surround is HNF, because the 1943tick is there to tell us that the expression was evaluated, so we 1944don't want to discard a seq on it. 1945-} 1946 1947-- | Can we bind this 'CoreExpr' at the top level? 1948exprIsTopLevelBindable :: CoreExpr -> Type -> Bool 1949-- See Note [Core top-level string literals] 1950-- Precondition: exprType expr = ty 1951-- Top-level literal strings can't even be wrapped in ticks 1952-- see Note [Core top-level string literals] in "GHC.Core" 1953exprIsTopLevelBindable expr ty 1954 = not (mightBeUnliftedType ty) 1955 -- Note that 'expr' may be levity polymorphic here consequently we must use 1956 -- 'mightBeUnliftedType' rather than 'isUnliftedType' as the latter would panic. 1957 || exprIsTickedString expr 1958 1959-- | Check if the expression is zero or more Ticks wrapped around a literal 1960-- string. 1961exprIsTickedString :: CoreExpr -> Bool 1962exprIsTickedString = isJust . exprIsTickedString_maybe 1963 1964-- | Extract a literal string from an expression that is zero or more Ticks 1965-- wrapped around a literal string. Returns Nothing if the expression has a 1966-- different shape. 1967-- Used to "look through" Ticks in places that need to handle literal strings. 1968exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString 1969exprIsTickedString_maybe (Lit (LitString bs)) = Just bs 1970exprIsTickedString_maybe (Tick t e) 1971 -- we don't tick literals with CostCentre ticks, compare to mkTick 1972 | tickishPlace t == PlaceCostCentre = Nothing 1973 | otherwise = exprIsTickedString_maybe e 1974exprIsTickedString_maybe _ = Nothing 1975 1976{- 1977************************************************************************ 1978* * 1979 Instantiating data constructors 1980* * 1981************************************************************************ 1982 1983These InstPat functions go here to avoid circularity between DataCon and Id 1984-} 1985 1986dataConRepInstPat :: [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) 1987dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) 1988 1989dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) 1990dataConRepFSInstPat = dataConInstPat 1991 1992dataConInstPat :: [FastString] -- A long enough list of FSs to use for names 1993 -> [Unique] -- An equally long list of uniques, at least one for each binder 1994 -> Mult -- The multiplicity annotation of the case expression: scales the multiplicity of variables 1995 -> DataCon 1996 -> [Type] -- Types to instantiate the universally quantified tyvars 1997 -> ([TyCoVar], [Id]) -- Return instantiated variables 1998-- dataConInstPat arg_fun fss us mult con inst_tys returns a tuple 1999-- (ex_tvs, arg_ids), 2000-- 2001-- ex_tvs are intended to be used as binders for existential type args 2002-- 2003-- arg_ids are indended to be used as binders for value arguments, 2004-- and their types have been instantiated with inst_tys and ex_tys 2005-- The arg_ids include both evidence and 2006-- programmer-specified arguments (both after rep-ing) 2007-- 2008-- Example. 2009-- The following constructor T1 2010-- 2011-- data T a where 2012-- T1 :: forall b. Int -> b -> T(a,b) 2013-- ... 2014-- 2015-- has representation type 2016-- forall a. forall a1. forall b. (a ~ (a1,b)) => 2017-- Int -> b -> T a 2018-- 2019-- dataConInstPat fss us T1 (a1',b') will return 2020-- 2021-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) 2022-- 2023-- where the double-primed variables are created with the FastStrings and 2024-- Uniques given as fss and us 2025dataConInstPat fss uniqs mult con inst_tys 2026 = ASSERT( univ_tvs `equalLength` inst_tys ) 2027 (ex_bndrs, arg_ids) 2028 where 2029 univ_tvs = dataConUnivTyVars con 2030 ex_tvs = dataConExTyCoVars con 2031 arg_tys = dataConRepArgTys con 2032 arg_strs = dataConRepStrictness con -- 1-1 with arg_tys 2033 n_ex = length ex_tvs 2034 2035 -- split the Uniques and FastStrings 2036 (ex_uniqs, id_uniqs) = splitAt n_ex uniqs 2037 (ex_fss, id_fss) = splitAt n_ex fss 2038 2039 -- Make the instantiating substitution for universals 2040 univ_subst = zipTvSubst univ_tvs inst_tys 2041 2042 -- Make existential type variables, applying and extending the substitution 2043 (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst 2044 (zip3 ex_tvs ex_fss ex_uniqs) 2045 2046 mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar) 2047 mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv 2048 new_tv 2049 , new_tv) 2050 where 2051 new_tv | isTyVar tv 2052 = mkTyVar (mkSysTvName uniq fs) kind 2053 | otherwise 2054 = mkCoVar (mkSystemVarName uniq fs) kind 2055 kind = Type.substTyUnchecked subst (varType tv) 2056 2057 -- Make value vars, instantiating types 2058 arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs 2059 mk_id_var uniq fs (Scaled m ty) str 2060 = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] 2061 mkLocalIdOrCoVar name (mult `mkMultMul` m) (Type.substTy full_subst ty) 2062 where 2063 name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan 2064 2065{- 2066Note [Mark evaluated arguments] 2067~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2068When pattern matching on a constructor with strict fields, the binder 2069can have an 'evaldUnfolding'. Moreover, it *should* have one, so that 2070when loading an interface file unfolding like: 2071 data T = MkT !Int 2072 f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 2073 in ... } 2074we don't want Lint to complain. The 'y' is evaluated, so the 2075case in the RHS of the binding for 'v' is fine. But only if we 2076*know* that 'y' is evaluated. 2077 2078c.f. add_evals in GHC.Core.Opt.Simplify.simplAlt 2079 2080************************************************************************ 2081* * 2082 Equality 2083* * 2084************************************************************************ 2085-} 2086 2087-- | A cheap equality test which bales out fast! 2088-- If it returns @True@ the arguments are definitely equal, 2089-- otherwise, they may or may not be equal. 2090cheapEqExpr :: Expr b -> Expr b -> Bool 2091cheapEqExpr = cheapEqExpr' (const False) 2092 2093-- | Cheap expression equality test, can ignore ticks by type. 2094cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool 2095{-# INLINE cheapEqExpr' #-} 2096cheapEqExpr' ignoreTick e1 e2 2097 = go e1 e2 2098 where 2099 go (Var v1) (Var v2) = v1 == v2 2100 go (Lit lit1) (Lit lit2) = lit1 == lit2 2101 go (Type t1) (Type t2) = t1 `eqType` t2 2102 go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 2103 go (App f1 a1) (App f2 a2) = f1 `go` f2 && a1 `go` a2 2104 go (Cast e1 t1) (Cast e2 t2) = e1 `go` e2 && t1 `eqCoercion` t2 2105 2106 go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2 2107 go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2 2108 go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2 2109 2110 go _ _ = False 2111 2112 2113 2114eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool 2115-- Compares for equality, modulo alpha 2116eqExpr in_scope e1 e2 2117 = go (mkRnEnv2 in_scope) e1 e2 2118 where 2119 go env (Var v1) (Var v2) 2120 | rnOccL env v1 == rnOccR env v2 2121 = True 2122 2123 go _ (Lit lit1) (Lit lit2) = lit1 == lit2 2124 go env (Type t1) (Type t2) = eqTypeX env t1 t2 2125 go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2 2126 go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2 2127 go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 2128 go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2 2129 2130 go env (Lam b1 e1) (Lam b2 e2) 2131 = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination 2132 && go (rnBndr2 env b1 b2) e1 e2 2133 2134 go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) 2135 = go env r1 r2 -- No need to check binder types, since RHSs match 2136 && go (rnBndr2 env v1 v2) e1 e2 2137 2138 go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) 2139 = equalLength ps1 ps2 2140 && all2 (go env') rs1 rs2 && go env' e1 e2 2141 where 2142 (bs1,rs1) = unzip ps1 2143 (bs2,rs2) = unzip ps2 2144 env' = rnBndrs2 env bs1 bs2 2145 2146 go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) 2147 | null a1 -- See Note [Empty case alternatives] in GHC.Data.TrieMap 2148 = null a2 && go env e1 e2 && eqTypeX env t1 t2 2149 | otherwise 2150 = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 2151 2152 go _ _ _ = False 2153 2154 ----------- 2155 go_alt env (Alt c1 bs1 e1) (Alt c2 bs2 e2) 2156 = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 2157 2158eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool 2159eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) 2160 = lid == rid && 2161 map (rnOccL env) lids == map (rnOccR env) rids && 2162 lext == rext 2163eqTickish _ l r = l == r 2164 2165-- | Finds differences between core expressions, modulo alpha and 2166-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be 2167-- checked for differences as well. 2168diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] 2169diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] 2170diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] 2171diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] 2172diffExpr _ env (Coercion co1) (Coercion co2) 2173 | eqCoercionX env co1 co2 = [] 2174diffExpr top env (Cast e1 co1) (Cast e2 co2) 2175 | eqCoercionX env co1 co2 = diffExpr top env e1 e2 2176diffExpr top env (Tick n1 e1) e2 2177 | not (tickishIsCode n1) = diffExpr top env e1 e2 2178diffExpr top env e1 (Tick n2 e2) 2179 | not (tickishIsCode n2) = diffExpr top env e1 e2 2180diffExpr top env (Tick n1 e1) (Tick n2 e2) 2181 | eqTickish env n1 n2 = diffExpr top env e1 e2 2182 -- The error message of failed pattern matches will contain 2183 -- generated names, which are allowed to differ. 2184diffExpr _ _ (App (App (Var absent) _) _) 2185 (App (App (Var absent2) _) _) 2186 | isDeadEndId absent && isDeadEndId absent2 = [] 2187diffExpr top env (App f1 a1) (App f2 a2) 2188 = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 2189diffExpr top env (Lam b1 e1) (Lam b2 e2) 2190 | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination 2191 = diffExpr top (rnBndr2 env b1 b2) e1 e2 2192diffExpr top env (Let bs1 e1) (Let bs2 e2) 2193 = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) 2194 in ds ++ diffExpr top env' e1 e2 2195diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) 2196 | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 2197 -- See Note [Empty case alternatives] in GHC.Data.TrieMap 2198 = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) 2199 where env' = rnBndr2 env b1 b2 2200 diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2) 2201 | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] 2202 | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 2203diffExpr _ _ e1 e2 2204 = [fsep [ppr e1, text "/=", ppr e2]] 2205 2206-- | Finds differences between core bindings, see @diffExpr@. 2207-- 2208-- The main problem here is that while we expect the binds to have the 2209-- same order in both lists, this is not guaranteed. To do this 2210-- properly we'd either have to do some sort of unification or check 2211-- all possible mappings, which would be seriously expensive. So 2212-- instead we simply match single bindings as far as we can. This 2213-- leaves us just with mutually recursive and/or mismatching bindings, 2214-- which we then speculatively match by ordering them. It's by no means 2215-- perfect, but gets the job done well enough. 2216diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] 2217 -> ([SDoc], RnEnv2) 2218diffBinds top env binds1 = go (length binds1) env binds1 2219 where go _ env [] [] 2220 = ([], env) 2221 go fuel env binds1 binds2 2222 -- No binds left to compare? Bail out early. 2223 | null binds1 || null binds2 2224 = (warn env binds1 binds2, env) 2225 -- Iterated over all binds without finding a match? Then 2226 -- try speculatively matching binders by order. 2227 | fuel == 0 2228 = if not $ env `inRnEnvL` fst (head binds1) 2229 then let env' = uncurry (rnBndrs2 env) $ unzip $ 2230 zip (sort $ map fst binds1) (sort $ map fst binds2) 2231 in go (length binds1) env' binds1 binds2 2232 -- If we have already tried that, give up 2233 else (warn env binds1 binds2, env) 2234 go fuel env ((bndr1,expr1):binds1) binds2 2235 | let matchExpr (bndr,expr) = 2236 (not top || null (diffIdInfo env bndr bndr1)) && 2237 null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) 2238 , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 2239 = go (length binds1) (rnBndr2 env bndr1 bndr2) 2240 binds1 (binds2l ++ binds2r) 2241 | otherwise -- No match, so push back (FIXME O(n^2)) 2242 = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 2243 go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough 2244 2245 -- We have tried everything, but couldn't find a good match. So 2246 -- now we just return the comparison results when we pair up 2247 -- the binds in a pseudo-random order. 2248 warn env binds1 binds2 = 2249 concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ 2250 unmatched "unmatched left-hand:" (drop l binds1') ++ 2251 unmatched "unmatched right-hand:" (drop l binds2') 2252 where binds1' = sortBy (comparing fst) binds1 2253 binds2' = sortBy (comparing fst) binds2 2254 l = min (length binds1') (length binds2') 2255 unmatched _ [] = [] 2256 unmatched txt bs = [text txt $$ ppr (Rec bs)] 2257 diffBind env (bndr1,expr1) (bndr2,expr2) 2258 | ds@(_:_) <- diffExpr top env expr1 expr2 2259 = locBind "in binding" bndr1 bndr2 ds 2260 | otherwise 2261 = diffIdInfo env bndr1 bndr2 2262 2263-- | Find differences in @IdInfo@. We will especially check whether 2264-- the unfoldings match, if present (see @diffUnfold@). 2265diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] 2266diffIdInfo env bndr1 bndr2 2267 | arityInfo info1 == arityInfo info2 2268 && cafInfo info1 == cafInfo info2 2269 && oneShotInfo info1 == oneShotInfo info2 2270 && inlinePragInfo info1 == inlinePragInfo info2 2271 && occInfo info1 == occInfo info2 2272 && demandInfo info1 == demandInfo info2 2273 && callArityInfo info1 == callArityInfo info2 2274 && levityInfo info1 == levityInfo info2 2275 = locBind "in unfolding of" bndr1 bndr2 $ 2276 diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2) 2277 | otherwise 2278 = locBind "in Id info of" bndr1 bndr2 2279 [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] 2280 where info1 = idInfo bndr1; info2 = idInfo bndr2 2281 2282-- | Find differences in unfoldings. Note that we will not check for 2283-- differences of @IdInfo@ in unfoldings, as this is generally 2284-- redundant, and can lead to an exponential blow-up in complexity. 2285diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] 2286diffUnfold _ NoUnfolding NoUnfolding = [] 2287diffUnfold _ BootUnfolding BootUnfolding = [] 2288diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] 2289diffUnfold env (DFunUnfolding bs1 c1 a1) 2290 (DFunUnfolding bs2 c2 a2) 2291 | c1 == c2 && equalLength bs1 bs2 2292 = concatMap (uncurry (diffExpr False env')) (zip a1 a2) 2293 where env' = rnBndrs2 env bs1 bs2 2294diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1) 2295 (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2) 2296 | v1 == v2 && cl1 == cl2 2297 && wf1 == wf2 && x1 == x2 && g1 == g2 2298 = diffExpr False env t1 t2 2299diffUnfold _ uf1 uf2 2300 = [fsep [ppr uf1, text "/=", ppr uf2]] 2301 2302-- | Add location information to diff messages 2303locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] 2304locBind loc b1 b2 diffs = map addLoc diffs 2305 where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) 2306 bindLoc | b1 == b2 = ppr b1 2307 | otherwise = ppr b1 <> char '/' <> ppr b2 2308 2309{- 2310************************************************************************ 2311* * 2312 Eta reduction 2313* * 2314************************************************************************ 2315 2316Note [Eta reduction conditions] 2317~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2318We try for eta reduction here, but *only* if we get all the way to an 2319trivial expression. We don't want to remove extra lambdas unless we 2320are going to avoid allocating this thing altogether. 2321 2322There are some particularly delicate points here: 2323 2324* We want to eta-reduce if doing so leaves a trivial expression, 2325 *including* a cast. For example 2326 \x. f |> co --> f |> co 2327 (provided co doesn't mention x) 2328 2329* Eta reduction is not valid in general: 2330 \x. bot /= bot 2331 This matters, partly for old-fashioned correctness reasons but, 2332 worse, getting it wrong can yield a seg fault. Consider 2333 f = \x.f x 2334 h y = case (case y of { True -> f `seq` True; False -> False }) of 2335 True -> ...; False -> ... 2336 2337 If we (unsoundly) eta-reduce f to get f=f, the strictness analyser 2338 says f=bottom, and replaces the (f `seq` True) with just 2339 (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it 2340 *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands 2341 the definition again, so that it does not terminate after all. 2342 Result: seg-fault because the boolean case actually gets a function value. 2343 See #1947. 2344 2345 So it's important to do the right thing. 2346 2347* With linear types, eta-reduction can break type-checking: 2348 f :: A ⊸ B 2349 g :: A -> B 2350 g = \x. f x 2351 2352 The above is correct, but eta-reducing g would yield g=f, the linter will 2353 complain that g and f don't have the same type. 2354 2355* Note [Arity care]: we need to be careful if we just look at f's 2356 arity. Currently (Dec07), f's arity is visible in its own RHS (see 2357 Note [Arity robustness] in GHC.Core.Opt.Simplify.Env) so we must *not* trust the 2358 arity when checking that 'f' is a value. Otherwise we will 2359 eta-reduce 2360 f = \x. f x 2361 to 2362 f = f 2363 Which might change a terminating program (think (f `seq` e)) to a 2364 non-terminating one. So we check for being a loop breaker first. 2365 2366 However for GlobalIds we can look at the arity; and for primops we 2367 must, since they have no unfolding. 2368 2369* Regardless of whether 'f' is a value, we always want to 2370 reduce (/\a -> f a) to f 2371 This came up in a RULE: foldr (build (/\a -> g a)) 2372 did not match foldr (build (/\b -> ...something complex...)) 2373 The type checker can insert these eta-expanded versions, 2374 with both type and dictionary lambdas; hence the slightly 2375 ad-hoc isDictId 2376 2377* Never *reduce* arity. For example 2378 f = \xy. g x y 2379 Then if h has arity 1 we don't want to eta-reduce because then 2380 f's arity would decrease, and that is bad 2381 2382These delicacies are why we don't use exprIsTrivial and exprIsHNF here. 2383Alas. 2384 2385Note [Eta reduction with casted arguments] 2386~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2387Consider 2388 (\(x:t3). f (x |> g)) :: t3 -> t2 2389 where 2390 f :: t1 -> t2 2391 g :: t3 ~ t1 2392This should be eta-reduced to 2393 2394 f |> (sym g -> t2) 2395 2396So we need to accumulate a coercion, pushing it inward (past 2397variable arguments only) thus: 2398 f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x 2399 f (x:t) |> co --> (f |> (t -> co)) x 2400 f @ a |> co --> (f |> (forall a.co)) @ a 2401 f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) 2402These are the equations for ok_arg. 2403 2404It's true that we could also hope to eta reduce these: 2405 (\xy. (f x |> g) y) 2406 (\xy. (f x y) |> g) 2407But the simplifier pushes those casts outwards, so we don't 2408need to address that here. 2409-} 2410 2411-- When updating this function, make sure to update 2412-- CorePrep.tryEtaReducePrep as well! 2413tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr 2414tryEtaReduce bndrs body 2415 = go (reverse bndrs) body (mkRepReflCo (exprType body)) 2416 where 2417 incoming_arity = count isId bndrs 2418 2419 go :: [Var] -- Binders, innermost first, types [a3,a2,a1] 2420 -> CoreExpr -- Of type tr 2421 -> Coercion -- Of type tr ~ ts 2422 -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts 2423 -- See Note [Eta reduction with casted arguments] 2424 -- for why we have an accumulating coercion 2425 go [] fun co 2426 | ok_fun fun 2427 , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co 2428 , not (any (`elemVarSet` used_vars) bndrs) 2429 = Just (mkCast fun co) -- Check for any of the binders free in the result 2430 -- including the accumulated coercion 2431 2432 go bs (Tick t e) co 2433 | tickishFloatable t 2434 = fmap (Tick t) $ go bs e co 2435 -- Float app ticks: \x -> Tick t (e x) ==> Tick t e 2436 2437 go (b : bs) (App fun arg) co 2438 | Just (co', ticks) <- ok_arg b arg co (exprType fun) 2439 = fmap (flip (foldr mkTick) ticks) $ go bs fun co' 2440 -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e 2441 2442 go _ _ _ = Nothing -- Failure! 2443 2444 --------------- 2445 -- Note [Eta reduction conditions] 2446 ok_fun (App fun (Type {})) = ok_fun fun 2447 ok_fun (Cast fun _) = ok_fun fun 2448 ok_fun (Tick _ expr) = ok_fun expr 2449 ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs 2450 ok_fun _fun = False 2451 2452 --------------- 2453 ok_fun_id fun = fun_arity fun >= incoming_arity 2454 2455 --------------- 2456 fun_arity fun -- See Note [Arity care] 2457 | isLocalId fun 2458 , isStrongLoopBreaker (idOccInfo fun) = 0 2459 | arity > 0 = arity 2460 | isEvaldUnfolding (idUnfolding fun) = 1 2461 -- See Note [Eta reduction of an eval'd function] 2462 | otherwise = 0 2463 where 2464 arity = idArity fun 2465 2466 --------------- 2467 ok_lam v = isTyVar v || isEvVar v 2468 2469 --------------- 2470 ok_arg :: Var -- Of type bndr_t 2471 -> CoreExpr -- Of type arg_t 2472 -> Coercion -- Of kind (t1~t2) 2473 -> Type -- Type of the function to which the argument is applied 2474 -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) 2475 -- (and similarly for tyvars, coercion args) 2476 , [CoreTickish]) 2477 -- See Note [Eta reduction with casted arguments] 2478 ok_arg bndr (Type ty) co _ 2479 | Just tv <- getTyVar_maybe ty 2480 , bndr == tv = Just (mkHomoForAllCos [tv] co, []) 2481 ok_arg bndr (Var v) co fun_ty 2482 | bndr == v 2483 , let mult = idMult bndr 2484 , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty 2485 , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort 2486 = let reflCo = mkRepReflCo (idType bndr) 2487 in Just (mkFunCo Representational (multToCo mult) reflCo co, []) 2488 ok_arg bndr (Cast e co_arg) co fun_ty 2489 | (ticks, Var v) <- stripTicksTop tickishFloatable e 2490 , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty 2491 , bndr == v 2492 , fun_mult `eqType` idMult bndr 2493 = Just (mkFunCo Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) 2494 -- The simplifier combines multiple casts into one, 2495 -- so we can have a simple-minded pattern match here 2496 ok_arg bndr (Tick t arg) co fun_ty 2497 | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty 2498 = Just (co', t:ticks) 2499 2500 ok_arg _ _ _ _ = Nothing 2501 2502{- 2503Note [Eta reduction of an eval'd function] 2504~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2505In Haskell it is not true that f = \x. f x 2506because f might be bottom, and 'seq' can distinguish them. 2507 2508But it *is* true that f = f `seq` \x. f x 2509and we'd like to simplify the latter to the former. This amounts 2510to the rule that 2511 * when there is just *one* value argument, 2512 * f is not bottom 2513we can eta-reduce \x. f x ===> f 2514 2515This turned up in #7542. 2516-} 2517 2518{- ********************************************************************* 2519* * 2520 Zapping lambda binders 2521* * 2522********************************************************************* -} 2523 2524zapLamBndrs :: FullArgCount -> [Var] -> [Var] 2525-- If (\xyz. t) appears under-applied to only two arguments, 2526-- we must zap the occ-info on x,y, because they appear under the \x 2527-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal 2528-- 2529-- NB: both `arg_count` and `bndrs` include both type and value args/bndrs 2530zapLamBndrs arg_count bndrs 2531 | no_need_to_zap = bndrs 2532 | otherwise = zap_em arg_count bndrs 2533 where 2534 no_need_to_zap = all isOneShotBndr (drop arg_count bndrs) 2535 2536 zap_em :: FullArgCount -> [Var] -> [Var] 2537 zap_em 0 bs = bs 2538 zap_em _ [] = [] 2539 zap_em n (b:bs) | isTyVar b = b : zap_em (n-1) bs 2540 | otherwise = zapLamIdInfo b : zap_em (n-1) bs 2541 2542 2543{- ********************************************************************* 2544* * 2545\subsection{Determining non-updatable right-hand-sides} 2546* * 2547************************************************************************ 2548 2549Top-level constructor applications can usually be allocated 2550statically, but they can't if the constructor, or any of the 2551arguments, come from another DLL (because we can't refer to static 2552labels in other DLLs). 2553 2554If this happens we simply make the RHS into an updatable thunk, 2555and 'execute' it rather than allocating it statically. 2556-} 2557 2558{- 2559************************************************************************ 2560* * 2561\subsection{Type utilities} 2562* * 2563************************************************************************ 2564-} 2565 2566-- | True if the type has no non-bottom elements, e.g. when it is an empty 2567-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool. 2568-- See Note [Bottoming expressions] 2569-- 2570-- See Note [No alternatives lint check] for another use of this function. 2571isEmptyTy :: Type -> Bool 2572isEmptyTy ty 2573 -- Data types where, given the particular type parameters, no data 2574 -- constructor matches, are empty. 2575 -- This includes data types with no constructors, e.g. Data.Void.Void. 2576 | Just (tc, inst_tys) <- splitTyConApp_maybe ty 2577 , Just dcs <- tyConDataCons_maybe tc 2578 , all (dataConCannotMatch inst_tys) dcs 2579 = True 2580 | otherwise 2581 = False 2582 2583{- 2584***************************************************** 2585* 2586* StaticPtr 2587* 2588***************************************************** 2589-} 2590 2591-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields 2592-- @Just (makeStatic, t, srcLoc, e)@. 2593-- 2594-- Returns @Nothing@ for every other expression. 2595collectMakeStaticArgs 2596 :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr) 2597collectMakeStaticArgs e 2598 | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e 2599 , idName b == makeStaticName = Just (fun, t, loc, arg) 2600collectMakeStaticArgs _ = Nothing 2601 2602{- 2603************************************************************************ 2604* * 2605\subsection{Join points} 2606* * 2607************************************************************************ 2608-} 2609 2610-- | Does this binding bind a join point (or a recursive group of join points)? 2611isJoinBind :: CoreBind -> Bool 2612isJoinBind (NonRec b _) = isJoinId b 2613isJoinBind (Rec ((b, _) : _)) = isJoinId b 2614isJoinBind _ = False 2615 2616dumpIdInfoOfProgram :: (IdInfo -> SDoc) -> CoreProgram -> SDoc 2617dumpIdInfoOfProgram ppr_id_info binds = vcat (map printId ids) 2618 where 2619 ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) 2620 getIds (NonRec i _) = [ i ] 2621 getIds (Rec bs) = map fst bs 2622 printId id | isExportedId id = ppr id <> colon <+> (ppr_id_info (idInfo id)) 2623 | otherwise = empty 2624 2625 2626{- ********************************************************************* 2627* * 2628 unsafeEqualityProof 2629* * 2630********************************************************************* -} 2631 2632isUnsafeEqualityProof :: CoreExpr -> Bool 2633-- See (U3) and (U4) in 2634-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce 2635isUnsafeEqualityProof e 2636 | Var v `App` Type _ `App` Type _ `App` Type _ <- e 2637 = idName v == unsafeEqualityProofName 2638 | otherwise 2639 = False 2640