diff options
author | Christiaan Baaij <christiaan.baaij@gmail.com> | 2021-11-21 15:09:31 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-11-25 01:04:32 -0500 |
commit | 3639ad8ffbf0bfc2cb600ba138d6bfda2ccd29fe (patch) | |
tree | e2ee24df7940ebda946ce4a2977febf823ac44d4 | |
parent | e3c59191fbd526a244b5ac71de5d6b6803374aea (diff) | |
download | haskell-3639ad8ffbf0bfc2cb600ba138d6bfda2ccd29fe.tar.gz |
Compare types of recursive let-bindings in alpha-equivalence
This commit fixes #20641 by checking the types of recursive
let-bindings when performing alpha-equality.
The `Eq (DeBruijn CoreExpr)` instance now also compares
`BreakPoint`s similarly to `GHC.Core.Utils.eqTickish`, taking
bound variables into account.
In addition, the `Eq (DeBruijn Type)` instance now correctly
compares the kinds of the types when one of them contains a
Cast: the instance is modeled after `nonDetCmpTypeX`.
-rw-r--r-- | compiler/GHC/Core/Map/Expr.hs | 93 | ||||
-rw-r--r-- | compiler/GHC/Core/Map/Type.hs | 150 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/CSE.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Core/Rules.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Core/Utils.hs | 132 |
6 files changed, 254 insertions, 146 deletions
diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs index 9cff1d33a1..4c79cd880a 100644 --- a/compiler/GHC/Core/Map/Expr.hs +++ b/compiler/GHC/Core/Map/Expr.hs @@ -16,6 +16,8 @@ module GHC.Core.Map.Expr ( -- * Maps over Core expressions CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, + -- * Alpha equality + eqDeBruijnExpr, eqCoreExpr, -- * 'TrieMap' class reexports TrieMap(..), insertTM, deleteTM, lkDFreeVar, xtDFreeVar, @@ -140,33 +142,42 @@ data CoreMapX a } instance Eq (DeBruijn CoreExpr) where - D env1 e1 == D env2 e2 = go e1 e2 where - go (Var v1) (Var v2) - = case (lookupCME env1 v1, lookupCME env2 v2) of - (Just b1, Just b2) -> b1 == b2 - (Nothing, Nothing) -> v1 == v2 - _ -> False + (==) = eqDeBruijnExpr + +eqDeBruijnExpr :: DeBruijn CoreExpr -> DeBruijn CoreExpr -> Bool +eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where + go (Var v1) (Var v2) = eqDeBruijnVar (D env1 v1) (D env2 v2) go (Lit lit1) (Lit lit2) = lit1 == lit2 - go (Type t1) (Type t2) = D env1 t1 == D env2 t2 - go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2 + -- See Note [Using tcView inside eqDeBruijnType] in GHC.Core.Map.Type + go (Type t1) (Type t2) = eqDeBruijnType (D env1 t1) (D env2 t2) + -- See Note [Alpha-equality for Coercion arguments] + go (Coercion {}) (Coercion {}) = True go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 - -- This seems a bit dodgy, see 'eqTickish' - go (Tick n1 e1) (Tick n2 e2) = n1 == n2 && go e1 e2 + go (Tick n1 e1) (Tick n2 e2) + = eqDeBruijnTickish (D env1 n1) (D env2 n2) + && go e1 e2 go (Lam b1 e1) (Lam b2 e2) - = D env1 (varType b1) == D env2 (varType b2) + -- See Note [Using tcView inside eqDeBruijnType] in GHC.Core.Map.Type + = eqDeBruijnType (D env1 (varType b1)) (D env2 (varType b2)) && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2) - && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2 + && eqDeBruijnExpr (D (extendCME env1 b1) e1) (D (extendCME env2 b2) e2) go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) - = go r1 r2 - && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2 + = go r1 r2 -- See Note [Alpha-equality for let-bindings] + && eqDeBruijnExpr (D (extendCME env1 v1) e1) (D (extendCME env2 v2) e2) go (Let (Rec ps1) e1) (Let (Rec ps2) e2) = equalLength ps1 ps2 + -- See Note [Alpha-equality for let-bindings] + && all2 (\b1 b2 -> -- See Note [Using tcView inside eqDeBruijnType] in + -- GHC.Core.Map.Type + eqDeBruijnType (D env1 (varType b1)) + (D env2 (varType b2))) + bs1 bs2 && D env1' rs1 == D env2' rs2 - && D env1' e1 == D env2' e2 + && eqDeBruijnExpr (D env1' e1) (D env2' e2) where (bs1,rs1) = unzip ps1 (bs2,rs2) = unzip ps2 @@ -177,10 +188,60 @@ instance Eq (DeBruijn CoreExpr) where | null a1 -- See Note [Empty case alternatives] = null a2 && go e1 e2 && D env1 t1 == D env2 t2 | otherwise - = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2 + = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2 go _ _ = False +eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool +eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where + go (Breakpoint lext lid lids) (Breakpoint rext rid rids) + = lid == rid + && D env1 lids == D env2 rids + && lext == rext + go l r = l == r + +-- Compares for equality, modulo alpha +eqCoreExpr :: CoreExpr -> CoreExpr -> Bool +eqCoreExpr e1 e2 = eqDeBruijnExpr (deBruijnize e1) (deBruijnize e2) + +{- Note [Alpha-equality for Coercion arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The 'Coercion' constructor only appears in argument positions, and so, if the +functions are equal, then the arguments must have equal types. Because the +comparison for coercions (correctly) checks only their types, checking for +alpha-equality of the coercions is redundant. +-} + +{- Note [Alpha-equality for let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For /recursive/ let-bindings we need to check that the types of the binders +are alpha-equivalent. Otherwise + + letrec (x : Bool) = x in x + +and + + letrec (y : Char) = y in y + +would be considered alpha-equivalent, which they are obviously not. + +For /non-recursive/ let-bindings, we do not have to check that the types of +the binders are alpha-equivalent. When the RHSs (the expressions) of the +non-recursive let-binders are well-formed and well-typed (which we assume they +are at this point in the compiler), and the RHSs are alpha-equivalent, then the +bindings must have the same type. + +In addition, it is also worth pointing out that + + letrec { x = e1; y = e2 } in b + +is NOT considered equal to + + letrec { y = e2; x = e1 } in b +-} + emptyE :: CoreMapX a emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM , cm_co = emptyTM, cm_type = emptyTM diff --git a/compiler/GHC/Core/Map/Type.hs b/compiler/GHC/Core/Map/Type.hs index 15c624d8b3..1617d93991 100644 --- a/compiler/GHC/Core/Map/Type.hs +++ b/compiler/GHC/Core/Map/Type.hs @@ -21,7 +21,7 @@ module GHC.Core.Map.Type ( -- * Utilities for use by friends only TypeMapG, CoercionMapG, - DeBruijn(..), deBruijnize, + DeBruijn(..), deBruijnize, eqDeBruijnType, eqDeBruijnVar, BndrMap, xtBndr, lkBndr, VarMap, xtVar, lkVar, lkDFreeVar, xtDFreeVar, @@ -182,38 +182,122 @@ instance TrieMap TypeMapX where filterTM = filterT instance Eq (DeBruijn Type) where - env_t@(D env t) == env_t'@(D env' t') - | Just new_t <- tcView t = D env new_t == env_t' - | Just new_t' <- tcView t' = env_t == D env' new_t' - | otherwise - = case (t, t') of - (CastTy t1 _, _) -> D env t1 == D env t' - (_, CastTy t1' _) -> D env t == D env t1' - - (TyVarTy v, TyVarTy v') - -> case (lookupCME env v, lookupCME env' v') of - (Just bv, Just bv') -> bv == bv' - (Nothing, Nothing) -> v == v' - _ -> False - -- See Note [Equality on AppTys] in GHC.Core.Type - (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s - -> D env t1 == D env' t1' && D env t2 == D env' t2' - (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s - -> D env t1 == D env' t1' && D env t2 == D env' t2' - (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2') - -> v1 == v1' && - D env w1 == D env w1' && - D env t1 == D env' t1' && - D env t2 == D env' t2' - (TyConApp tc tys, TyConApp tc' tys') - -> tc == tc' && D env tys == D env' tys' - (LitTy l, LitTy l') - -> l == l' - (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty') - -> D env (varType tv) == D env' (varType tv') && - D (extendCME env tv) ty == D (extendCME env' tv') ty' - (CoercionTy {}, CoercionTy {}) - -> True + (==) = eqDeBruijnType + +{- Note [Using tcView inside eqDeBruijnType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`eqDeBruijnType` uses `tcView` and thus treats Type and Constraint as +distinct -- see Note [coreView vs tcView] in GHC.Core.Type. We do that because +`eqDeBruijnType` is used in TrieMaps, which are used for instance for instance +selection in the type checker. [Or at least will be soon.] + +However, the odds that we have two expressions that are identical save for the +'Type'/'Constraint' distinction are low. (Not impossible to do. But doubtful +anyone has ever done so in the history of Haskell.) + +And it's actually all OK: 'eqExpr' is conservative: if `eqExpr e1 e2` returns +'True', thne it must be that `e1` behaves identically to `e2` in all contexts. +But if `eqExpr e1 e2` returns 'False', then we learn nothing. The use of +'tcView' where we expect 'coreView' means 'eqExpr' returns 'False' bit more +often that it should. This might, say, stop a `RULE` from firing or CSE from +optimizing an expression. Stopping `RULE` firing is good actually: `RULES` are +written in Haskell, where `Type /= Constraint`. Stopping CSE is unfortunate, +but tolerable. +-} + +-- | An equality relation between two 'Type's (known below as @t1 :: k2@ +-- and @t2 :: k2@) +data TypeEquality = TNEQ -- ^ @t1 /= t2@ + | TEQ -- ^ @t1 ~ t2@ and there are not casts in either, + -- therefore we can conclude @k1 ~ k2@ + | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so + -- they may differ in kind + +eqDeBruijnType :: DeBruijn Type -> DeBruijn Type -> Bool +eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) = + -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + -- See Note [Computing equality on types] + case go env_t1 env_t2 of + TEQX -> toBool (go (D env1 k1) (D env2 k2)) + ty_eq -> toBool ty_eq + where + k1 = typeKind t1 + k2 = typeKind t2 + + toBool :: TypeEquality -> Bool + toBool TNEQ = False + toBool _ = True + + liftEquality :: Bool -> TypeEquality + liftEquality False = TNEQ + liftEquality _ = TEQ + + hasCast :: TypeEquality -> TypeEquality + hasCast TEQ = TEQX + hasCast eq = eq + + andEq :: TypeEquality -> TypeEquality -> TypeEquality + andEq TNEQ _ = TNEQ + andEq TEQX e = hasCast e + andEq TEQ e = e + + -- See Note [Comparing nullary type synonyms] in GHC.Core.Type + go (D _ (TyConApp tc1 [])) (D _ (TyConApp tc2 [])) + | tc1 == tc2 + = TEQ + go env_t@(D env t) env_t'@(D env' t') + -- See Note [Using tcView inside eqDeBruijnType] + | Just new_t <- tcView t = go (D env new_t) env_t' + | Just new_t' <- tcView t' = go env_t (D env' new_t') + | otherwise + = case (t, t') of + -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + (CastTy t1 _, _) -> hasCast (go (D env t1) (D env t')) + (_, CastTy t1' _) -> hasCast (go (D env t) (D env t1')) + + (TyVarTy v, TyVarTy v') + -> liftEquality $ eqDeBruijnVar (D env v) (D env' v') + -- See Note [Equality on AppTys] in GHC.Core.Type + (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s + -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2') + (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s + -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2') + (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2') + + -> liftEquality (v1 == v1') `andEq` + -- NB: eqDeBruijnType does the kind check requested by + -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep + liftEquality (eqDeBruijnType (D env t1) (D env' t1')) `andEq` + liftEquality (eqDeBruijnType (D env t2) (D env' t2')) `andEq` + -- Comparing multiplicities last because the test is usually true + go (D env w1) (D env w1') + (TyConApp tc tys, TyConApp tc' tys') + -> liftEquality (tc == tc') `andEq` gos env env' tys tys' + (LitTy l, LitTy l') + -> liftEquality (l == l') + (ForAllTy (Bndr tv vis) ty, ForAllTy (Bndr tv' vis') ty') + -> -- See Note [ForAllTy and typechecker equality] in + -- GHC.Tc.Solver.Canonical for why we use `sameVis` here + liftEquality (vis `sameVis` vis') `andEq` + go (D env (varType tv)) (D env' (varType tv')) `andEq` + go (D (extendCME env tv) ty) (D (extendCME env' tv') ty') + (CoercionTy {}, CoercionTy {}) + -> TEQ + _ -> TNEQ + + gos _ _ [] [] = TEQ + gos e1 e2 (ty1:tys1) (ty2:tys2) = go (D e1 ty1) (D e2 ty2) `andEq` + gos e1 e2 tys1 tys2 + gos _ _ _ _ = TNEQ + +instance Eq (DeBruijn Var) where + (==) = eqDeBruijnVar + +eqDeBruijnVar :: DeBruijn Var -> DeBruijn Var -> Bool +eqDeBruijnVar (D env1 v1) (D env2 v2) = + case (lookupCME env1 v1, lookupCME env2 v2) of + (Just b1, Just b2) -> b1 == b2 + (Nothing, Nothing) -> v1 == v2 _ -> False instance {-# OVERLAPPING #-} diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index 6b5a12e9f1..08d4ce193b 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -20,7 +20,7 @@ import GHC.Types.Id ( Id, idType, idHasRules, zapStableUnfolding , idInlineActivation, setInlineActivation , zapIdOccInfo, zapIdUsageInfo, idInlinePragma , isJoinId, isJoinId_maybe ) -import GHC.Core.Utils ( mkAltExpr, eqExpr +import GHC.Core.Utils ( mkAltExpr , exprIsTickedString , stripTicksE, stripTicksT, mkTicks ) import GHC.Core.FVs ( exprFreeVars ) @@ -652,7 +652,7 @@ cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr cseCase env scrut bndr ty alts = Case scrut1 bndr3 ty' $ - combineAlts alt_env (map cse_alt alts) + combineAlts (map cse_alt alts) where ty' = substTy (csEnvSubst env) ty (cse_done, scrut1) = try_for_cse env scrut @@ -684,9 +684,9 @@ cseCase env scrut bndr ty alts where (env', args') = addBinders alt_env args -combineAlts :: CSEnv -> [OutAlt] -> [OutAlt] +combineAlts :: [OutAlt] -> [OutAlt] -- See Note [Combine case alternatives] -combineAlts env alts +combineAlts alts | (Just alt1, rest_alts) <- find_bndr_free_alt alts , Alt _ bndrs1 rhs1 <- alt1 , let filtered_alts = filterOut (identical_alt rhs1) rest_alts @@ -697,7 +697,6 @@ combineAlts env alts | otherwise = alts where - in_scope = substInScope (csEnvSubst env) find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt]) -- The (Just alt) is a binder-free alt @@ -709,7 +708,7 @@ combineAlts env alts | otherwise = case find_bndr_free_alt alts of (mb_bf, alts) -> (mb_bf, alt:alts) - identical_alt rhs1 (Alt _ _ rhs) = eqExpr in_scope rhs1 rhs + identical_alt rhs1 (Alt _ _ rhs) = eqCoreExpr rhs1 rhs -- Even if this alt has binders, they will have been cloned -- If any of these binders are mentioned in 'rhs', then -- 'rhs' won't compare equal to 'rhs1' (which is from an diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index b9b436ffe5..cce8830a97 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -37,8 +37,6 @@ import GHC.Platform import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, voidPrimId ) import GHC.Types.Id import GHC.Types.Literal -import GHC.Types.Var.Set -import GHC.Types.Var.Env import GHC.Types.Name.Occurrence ( occNameFS ) import GHC.Types.Tickish import GHC.Types.Name ( Name, nameOccName ) @@ -48,15 +46,15 @@ import GHC.Core import GHC.Core.Make import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe ) import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) -import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType +import GHC.Core.Utils ( cheapEqExpr, exprIsHNF, exprType , stripTicksTop, stripTicksTopT, mkTicks ) import GHC.Core.Multiplicity -import GHC.Core.FVs import GHC.Core.Type import GHC.Core.TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon , isNewTyCon, tyConDataCons , tyConFamilySize ) +import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey ) import GHC.Builtin.Types @@ -2390,8 +2388,7 @@ match_cstring_foldr_lit foldVariant _ env _ , unpk `hasKey` foldVariant , Just (LitString s1) <- exprIsLiteral_maybe env lit1 , Just (LitString s2) <- exprIsLiteral_maybe env lit2 - , let freeVars = (mkInScopeSet (exprFreeVars c1 `unionVarSet` exprFreeVars c2)) - in eqExpr freeVars c1 c2 + , eqCoreExpr c1 c2 , (c1Ticks, c1') <- stripStrTopTicks env c1 , c2Ticks <- stripStrTopTicksT c2 = assert (ty1 `eqType` ty2) $ diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index ff57df697f..b639629474 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -39,7 +39,7 @@ import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) -import GHC.Core.Utils ( exprType, eqExpr, mkTick, mkTicks +import GHC.Core.Utils ( exprType, mkTick, mkTicks , stripTicksTopT, stripTicksTopE , isJoinBind ) import GHC.Core.Ppr ( pprRules ) @@ -49,6 +49,7 @@ import GHC.Core.Type as Type , mkEmptyTCvSubst, substTy ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) +import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types ( anyTypeOfKind ) @@ -968,7 +969,7 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) -- e.g. match forall a. (\x-> a x) against (\y. y y) | Just e1' <- lookupVarEnv id_subst v1' - = if eqExpr (rnInScopeSet rn_env) e1' e2' + = if eqCoreExpr e1' e2' then Just subst else Nothing diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 271380557d..fe831590ef 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -35,7 +35,7 @@ module GHC.Core.Utils ( -- * Equality cheapEqExpr, cheapEqExpr', eqExpr, - diffExpr, diffBinds, + diffBinds, -- * Lambdas and eta reduction tryEtaReduce, zapLamBndrs, @@ -78,6 +78,7 @@ import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.TyCon import GHC.Core.Multiplicity +import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey ) import GHC.Builtin.PrimOps @@ -2123,48 +2124,11 @@ cheapEqExpr' ignoreTick e1 e2 eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool -- Compares for equality, modulo alpha -eqExpr in_scope e1 e2 - = go (mkRnEnv2 in_scope) e1 e2 - where - go env (Var v1) (Var v2) - | rnOccL env v1 == rnOccR env v2 - = True - - go _ (Lit lit1) (Lit lit2) = lit1 == lit2 - go env (Type t1) (Type t2) = eqTypeX env t1 t2 - go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2 - go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2 - go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 - go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2 - - go env (Lam b1 e1) (Lam b2 e2) - = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination - && go (rnBndr2 env b1 b2) e1 e2 - - go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) - = go env r1 r2 -- No need to check binder types, since RHSs match - && go (rnBndr2 env v1 v2) e1 e2 - - go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) - = equalLength ps1 ps2 - && all2 (go env') rs1 rs2 && go env' e1 e2 - where - (bs1,rs1) = unzip ps1 - (bs2,rs2) = unzip ps2 - env' = rnBndrs2 env bs1 bs2 - - go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) - | null a1 -- See Note [Empty case alternatives] in GHC.Data.TrieMap - = null a2 && go env e1 e2 && eqTypeX env t1 t2 - | otherwise - = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 - - go _ _ _ = False - - ----------- - go_alt env (Alt c1 bs1 e1) (Alt c2 bs2 e2) - = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 +-- TODO: remove eqExpr once GHC 9.4 is released +eqExpr _ = eqCoreExpr +{-# DEPRECATED eqExpr "Use 'GHC.Core.Map.Expr.eqCoreExpr', 'eqExpr' will be removed in GHC 9.6" #-} +-- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) = lid == rid && @@ -2172,47 +2136,6 @@ eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) lext == rext eqTickish _ l r = l == r --- | Finds differences between core expressions, modulo alpha and --- renaming. Setting @top@ means that the @IdInfo@ of bindings will be --- checked for differences as well. -diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] -diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] -diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] -diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] -diffExpr _ env (Coercion co1) (Coercion co2) - | eqCoercionX env co1 co2 = [] -diffExpr top env (Cast e1 co1) (Cast e2 co2) - | eqCoercionX env co1 co2 = diffExpr top env e1 e2 -diffExpr top env (Tick n1 e1) e2 - | not (tickishIsCode n1) = diffExpr top env e1 e2 -diffExpr top env e1 (Tick n2 e2) - | not (tickishIsCode n2) = diffExpr top env e1 e2 -diffExpr top env (Tick n1 e1) (Tick n2 e2) - | eqTickish env n1 n2 = diffExpr top env e1 e2 - -- The error message of failed pattern matches will contain - -- generated names, which are allowed to differ. -diffExpr _ _ (App (App (Var absent) _) _) - (App (App (Var absent2) _) _) - | isDeadEndId absent && isDeadEndId absent2 = [] -diffExpr top env (App f1 a1) (App f2 a2) - = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 -diffExpr top env (Lam b1 e1) (Lam b2 e2) - | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination - = diffExpr top (rnBndr2 env b1 b2) e1 e2 -diffExpr top env (Let bs1 e1) (Let bs2 e2) - = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) - in ds ++ diffExpr top env' e1 e2 -diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) - | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 - -- See Note [Empty case alternatives] in GHC.Data.TrieMap - = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) - where env' = rnBndr2 env b1 b2 - diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2) - | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] - | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 -diffExpr _ _ e1 e2 - = [fsep [ppr e1, text "/=", ppr e2]] - -- | Finds differences between core bindings, see @diffExpr@. -- -- The main problem here is that while we expect the binds to have the @@ -2223,6 +2146,8 @@ diffExpr _ _ e1 e2 -- leaves us just with mutually recursive and/or mismatching bindings, -- which we then speculatively match by ordering them. It's by no means -- perfect, but gets the job done well enough. +-- +-- Only used in GHC.Core.Lint.lintAnnots diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> ([SDoc], RnEnv2) diffBinds top env binds1 = go (length binds1) env binds1 @@ -2270,6 +2195,47 @@ diffBinds top env binds1 = go (length binds1) env binds1 | otherwise = diffIdInfo env bndr1 bndr2 +-- | Finds differences between core expressions, modulo alpha and +-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be +-- checked for differences as well. +diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] +diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] +diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] +diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] +diffExpr _ env (Coercion co1) (Coercion co2) + | eqCoercionX env co1 co2 = [] +diffExpr top env (Cast e1 co1) (Cast e2 co2) + | eqCoercionX env co1 co2 = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) e2 + | not (tickishIsCode n1) = diffExpr top env e1 e2 +diffExpr top env e1 (Tick n2 e2) + | not (tickishIsCode n2) = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) (Tick n2 e2) + | eqTickish env n1 n2 = diffExpr top env e1 e2 + -- The error message of failed pattern matches will contain + -- generated names, which are allowed to differ. +diffExpr _ _ (App (App (Var absent) _) _) + (App (App (Var absent2) _) _) + | isDeadEndId absent && isDeadEndId absent2 = [] +diffExpr top env (App f1 a1) (App f2 a2) + = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 +diffExpr top env (Lam b1 e1) (Lam b2 e2) + | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + = diffExpr top (rnBndr2 env b1 b2) e1 e2 +diffExpr top env (Let bs1 e1) (Let bs2 e2) + = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) + in ds ++ diffExpr top env' e1 e2 +diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 + -- See Note [Empty case alternatives] in GHC.Data.TrieMap + = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) + where env' = rnBndr2 env b1 b2 + diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2) + | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] + | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 +diffExpr _ _ e1 e2 + = [fsep [ppr e1, text "/=", ppr e2]] + -- | Find differences in @IdInfo@. We will especially check whether -- the unfoldings match, if present (see @diffUnfold@). diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] |