[Git][ghc/ghc][wip/T24725] Further improvements to eqType
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sun Jun 16 22:14:50 UTC 2024
Simon Peyton Jones pushed to branch wip/T24725 at Glasgow Haskell Compiler / GHC
Commits:
8484934d by Simon Peyton Jones at 2024-06-16T23:14:26+01:00
Further improvements to eqType
- - - - -
1 changed file:
- compiler/GHC/Core/TyCo/Compare.hs
Changes:
=====================================
compiler/GHC/Core/TyCo/Compare.hs
=====================================
@@ -7,16 +7,17 @@
-- | Type equality and comparison
module GHC.Core.TyCo.Compare (
- -- * Type comparison
+ -- * Type equality
eqType, eqTypeIgnoringMultiplicity, eqTypeX, eqTypes,
- nonDetCmpType, nonDetCmpTypeX,
- nonDetCmpTc,
eqVarBndrs,
pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck,
tcEqTyConApps,
mayLookIdentical,
+ -- * Type comparison
+ nonDetCmpType,
+
-- * Visiblity comparision
eqForAllVis, cmpForAllVis
@@ -143,50 +144,74 @@ initRnEnv :: Type -> Type -> RnEnv2
initRnEnv ta tb = mkRnEnv2 $ mkInScopeSet $
tyCoVarsOfType ta `unionVarSet` tyCoVarsOfType tb
+eqTypeNoKindCheck :: Type -> Type -> Bool
+eqTypeNoKindCheck ty1 ty2 = eqTyResBool (eq_type_expand_respect ty1 ty2)
+
-- | Type equality comparing both visible and invisible arguments,
-- expanding synonyms and respecting multiplicities.
eqType :: HasCallStack => Type -> Type -> Bool
-eqType ta tb = eqTypeX (initRnEnv ta tb) ta tb
-
-eqTypeNoKindCheck :: Type -> Type -> Bool
-eqTypeNoKindCheck ta tb = eq_type_x (initRnEnv ta tb) ta tb
+eqType ta tb
+ = case eq ta tb of
+ NotEq -> False
+ IsEq -> True
+ IsEqCast -> eqTyResBool (eq (typeKind ta) (typeKind tb))
+ where
+ eq = eq_type_expand_respect
-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.
eqTypeX :: HasCallStack => RnEnv2 -> Type -> Type -> Bool
-eqTypeX env ta tb = eq_type_x env ta tb
- && eq_type_x env (typeKind ta) (typeKind tb)
-
-eq_type_x :: RnEnv2 -> Type -> Type -> Bool
-eq_type_x = generic_eq_type ExpandSynonyms RespectMultiplicities
+eqTypeX env ta tb
+ = case eq ta tb of
+ NotEq -> False
+ IsEq -> True
+ IsEqCast -> eqTyResBool (eq (typeKind ta) (typeKind tb))
+ where
+ eq = eq_type_expand_respect_x env
eqTypeIgnoringMultiplicity :: Type -> Type -> Bool
eqTypeIgnoringMultiplicity ta tb
- = eq init_env ta tb
- && eq init_env (typeKind ta) (typeKind tb)
+ = case eq ta tb of
+ NotEq -> False
+ IsEq -> True
+ IsEqCast -> eqTyResBool (eq (typeKind ta) (typeKind tb))
where
- eq = generic_eq_type ExpandSynonyms IgnoreMultiplicities
- init_env = initRnEnv ta tb
+ eq = eq_type_expand_ignore
-- | Like 'pickyEqTypeVis', but returns a Bool for convenience
pickyEqType :: Type -> Type -> Bool
-- Check when two types _look_ the same, _including_ synonyms.
-- So (pickyEqType String [Char]) returns False
-- This ignores kinds and coercions, because this is used only for printing.
-pickyEqType ta tb
- = generic_eq_type KeepSynonyms RespectMultiplicities (initRnEnv ta tb) ta tb
+pickyEqType ta tb = eqTyResBool (eq_type_keep_respect ta tb)
-{- Note [Specialising generic_eq_type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The type equality predicates in Type are hit pretty hard during typechecking.
-Consequently we take pains to ensure that these paths are compiled to
-efficient, minimally-allocating code.
+{- Note [Specialising type equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The type equality predicates in Type are hit pretty hard by GHC. Consequently
+we take pains to ensure that these paths are compiled to efficient,
+minimally-allocating code. Plan:
+
+* The main workhorse is `inline_generic_eq_type_x`. It is /non-recursive/
+ and is marked INLINE.
+
+* `inline_generic_eq_type_x` has various parameters that control what it does:
+ * syn_flag::SynFlag whether type synonyms are expanded or kept.
+ * mult_flag::MultiplicityFlag whether multiplicities are ignored or respected
+ * mb_env::Maybe RnEnv2 an optional RnEnv2.
+
+* `inline_generic_eq_type_x` has a handful of call sites, namely the ones
+ in `eq_type_expand_respect`, `eq_type_expand_repect_x` etc. It inlines
+ at all these sites, specialising to the data values passed for the
+ control parameters.
-To this end we place an INLINE on tc_eq_type, ensuring that it is inlined into
-its publicly-visible interfaces (e.g. tcEqType). In addition to eliminating
-some dynamic branches, this allows the simplifier to eliminate the closure
-allocations that would otherwise be necessary to capture the two boolean "mode"
-flags. This reduces allocations by a good fraction of a percent when compiling
-Cabal.
+* All /other/ calls to `inline_generic_eq_type_x` go via
+ generic_eq_type_x = inline_generic_eq_type_x
+ {-# NOINLNE generic_eq_type_x #-}
+ The idea is that all calls to `generic_eq_type_x` are specialised by the
+ RULES, so this NOINLINE version is seldom, if ever, actually called.
+
+* For each of specialised copy of `inline_generic_eq_type_x, there is a
+ corresponding rewrite RULE that rewrites a call to (generic_eq_type_x args)
+ into the appropriate specialied version.
See #19226.
-}
@@ -194,72 +219,142 @@ See #19226.
-- | This flag controls whether we expand synonyms during comparison
data SynFlag = ExpandSynonyms | KeepSynonyms
+eq_type_expand_respect, eq_type_expand_ignore, eq_type_keep_respect
+ :: Type -> Type -> EqTyRes
+eq_type_expand_respect_x, eq_type_expand_ignore_x, eq_type_keep_respect_x
+ :: RnEnv2 -> Type -> Type -> EqTyRes
+
+eq_type_expand_respect = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing
+eq_type_expand_respect_x env = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env)
+eq_type_expand_ignore = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing
+eq_type_expand_ignore_x env = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env)
+eq_type_keep_respect = inline_generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing
+eq_type_keep_respect_x env = inline_generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env)
+
+{-# RULES
+"eqType1" generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing
+ = eq_type_expand_respect
+"eqType2" forall env. generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env)
+ = eq_type_expand_respect_x env
+"eqType3" generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing
+ = eq_type_expand_ignore
+"eqType4" forall env. generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env)
+ = eq_type_expand_ignore_x env
+"eqType5" generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing
+ = eq_type_keep_respect
+"eqType6" forall env. generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env)
+ = eq_type_keep_respect_x env
+ #-}
+
-- ---------------------------------------------------------------
-- | Real worker for 'eqType'. No kind check!
-- Inline it at the (handful of local) call sites
-- The "generic" bit refers to the flag paramerisation
-generic_eq_type :: SynFlag -> MultiplicityFlag
- -> RnEnv2 -> Type -> Type
- -> Bool
+-- See Note [Specialising type equality].
+generic_eq_type_x, inline_generic_eq_type_x
+ :: SynFlag -> MultiplicityFlag -> Maybe RnEnv2 -> Type -> Type -> EqTyRes
+{-# NOINLINE generic_eq_type_x #-}
+{-# INLINE inline_generic_eq_type_x #-}
+
+generic_eq_type_x = inline_generic_eq_type_x
-- See Note [Computing equality on types] in Type
-{-# INLINE generic_eq_type #-} -- See Note [Specialising generic_eq_type].
-generic_eq_type syn_flag mult_flag
- = go
+inline_generic_eq_type_x syn_flag mult_flag mb_env
+ = inline_go
where
- go_with_kc :: RnEnv2 -> Type -> Type -> Bool
- go_with_kc env ty1 ty2
- = go env ty1 ty2 && go env (typeKind ty1) (typeKind ty2)
+ -------------------
+ go = generic_eq_type_x syn_flag mult_flag mb_env
- go :: RnEnv2 -> Type -> Type -> Bool
- -- See Note [Comparing nullary type synonyms]
- go _ t1 t2 | 1# <- reallyUnsafePtrEquality# t1 t2 = True
+ -------------------
+ go_with_kc :: Type -> Type -> EqTyRes
+ {-# INLINE go_with_kc #-}
+ go_with_kc ty1 ty2 = case go ty1 ty2 of
+ NotEq -> NotEq
+ IsEq -> IsEq
+ IsEqCast -> go (typeKind ty1) (typeKind ty2)
- go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True
+ -------------------
+ inline_go !t1 !t2 | 1# <- reallyUnsafePtrEquality# t1 t2 = IsEq
- go env t1 t2 | ExpandSynonyms <- syn_flag, Just t1' <- coreView t1 = go env t1' t2
- go env t1 t2 | ExpandSynonyms <- syn_flag, Just t2' <- coreView t2 = go env t1 t2'
+ inline_go (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = IsEq
+ -- Do this first so the function is strict in both args
- go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
- go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2
- go env (CastTy t1 _) t2 = go env t1 t2
- go env t1 (CastTy t2 _) = go env t1 t2
- go _ (CoercionTy {}) (CoercionTy {}) = True
+ inline_go t1 t2 | ExpandSynonyms <- syn_flag, Just t1' <- coreView t1 = go t1' t2
+ inline_go t1 t2 | ExpandSynonyms <- syn_flag, Just t2' <- coreView t2 = go t1 t2'
- go env (ForAllTy (Bndr tv1 vis1) ty1)
- (ForAllTy (Bndr tv2 vis2) ty2)
- = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality]
- && go env (varType tv1) (varType tv2) -- Always do kind-check
- && go (rnBndr2 env tv1 tv2) ty1 ty2
+ inline_go (TyVarTy tv1) (TyVarTy tv2)
+ = case mb_env of
+ Nothing -> boolEqTyRes (tv1 == tv2)
+ Just env -> boolEqTyRes (rnOccL env tv1 == rnOccR env tv2)
+
+ inline_go (LitTy lit1) (LitTy lit2) = boolEqTyRes (lit1 == lit2)
+ inline_go (CastTy t1 _) t2 = addEqCast (go t1 t2)
+ inline_go t1 (CastTy t2 _) = addEqCast (go t1 t2)
+ inline_go (CoercionTy {}) (CoercionTy {}) = IsEq
-- Make sure we handle all FunTy cases since falling through to the
-- AppTy case means that tcSplitAppTyNoView_maybe may see an unzonked
-- kind variable, which causes things to blow up.
-- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check
-- kinds here
- go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)
- = go_with_kc env arg1 arg2
- && go_with_kc env res1 res2
- && (case mult_flag of
- RespectMultiplicities -> go env w1 w2
- IgnoreMultiplicities -> True)
+ inline_go (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)
+ = go_with_kc arg1 arg2
+ &=& go_with_kc res1 res2
+ &=& (case mult_flag of
+ RespectMultiplicities -> go w1 w2
+ IgnoreMultiplicities -> IsEq)
-- See Note [Equality on AppTys] in GHC.Core.Type
- go env (AppTy s1 t1) ty2
+ inline_go (AppTy s1 t1) ty2
| Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2
- = go env s1 s2 && go env t1 t2
- go env ty1 (AppTy s2 t2)
+ = go s1 s2 &=& go t1 t2
+ inline_go ty1 (AppTy s2 t2)
| Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1
- = go env s1 s2 && go env t1 t2
-
- go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)
- = tc1 == tc2 && gos env ts1 ts2
-
- go _ _ _ = False
-
- gos _ [] [] = True
- gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2
- gos _ _ _ = False
-
+ = go s1 s2 &=& go t1 t2
+
+ inline_go (TyConApp tc1 ts1) (TyConApp tc2 ts2)
+ | tc1 == tc2 = gos ts1 ts2
+ | otherwise = NotEq
+ where
+ gos [] [] = IsEq
+ gos (t1:ts1) (t2:ts2) = go t1 t2 &=& gos ts1 ts2
+ gos _ _ = NotEq
+
+ inline_go ty1@(ForAllTy (Bndr tv1 vis1) body1)
+ ty2@(ForAllTy (Bndr tv2 vis2) body2)
+ = case mb_env of
+ Nothing -> generic_eq_type_x syn_flag mult_flag
+ (Just (initRnEnv ty1 ty2)) ty1 ty2
+ Just env
+ | vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality]
+ -> go (varType tv1) (varType tv2) -- Always do kind-check
+ &=& generic_eq_type_x syn_flag mult_flag
+ (Just (rnBndr2 env tv1 tv2)) body1 body2
+ | otherwise
+ -> NotEq
+
+ inline_go _ _ = NotEq
+
+
+data EqTyRes = IsEq | IsEqCast | NotEq
+
+(&=&) :: EqTyRes -> EqTyRes -> EqTyRes
+(&=&) NotEq _ = NotEq
+(&=&) _ NotEq = NotEq
+(&=&) IsEq x = x
+(&=&) IsEqCast _ = IsEqCast
+
+addEqCast :: EqTyRes -> EqTyRes
+addEqCast NotEq = NotEq
+addEqCast _ = IsEqCast
+
+boolEqTyRes :: Bool -> EqTyRes
+boolEqTyRes True = IsEq
+boolEqTyRes False = NotEq
+
+eqTyResBool :: EqTyRes -> Bool
+eqTyResBool IsEq = True
+eqTyResBool IsEqCast = True
+eqTyResBool NotEq = False
{- *********************************************************************
* *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8484934d1431615097fbc6ed4fa09f1cddc8eea8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8484934d1431615097fbc6ed4fa09f1cddc8eea8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240616/c597ae34/attachment-0001.html>
More information about the ghc-commits
mailing list