[Git][ghc/ghc][wip/T24725] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Jun 15 21:07:14 UTC 2024
Simon Peyton Jones pushed to branch wip/T24725 at Glasgow Haskell Compiler / GHC
Commits:
691fb238 by Simon Peyton Jones at 2024-06-15T12:04:14+01:00
Wibbles
- - - - -
2 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/TyCo/Compare.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -52,7 +52,7 @@ import GHC.Core.Type as Type
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Core.TyCo.Rep -- checks validity of types/coercions
-import GHC.Core.TyCo.Compare ( eqType, eqTypeIgnoringMultiplicity, eqForAllVis )
+import GHC.Core.TyCo.Compare ( eqType, eqTypes, eqTypeIgnoringMultiplicity, eqForAllVis )
import GHC.Core.TyCo.Subst
import GHC.Core.TyCo.FVs
import GHC.Core.TyCo.Ppr
@@ -2801,7 +2801,7 @@ lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches
extra_checks
| isNewTyCon tc
- = do { CoAxBranch { cab_tvs = tvs
+ = do { CoAxBranch { cab_tvs = ax_tvs
, cab_eta_tvs = eta_tvs
, cab_cvs = cvs
, cab_roles = roles
@@ -2809,14 +2809,10 @@ lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches
<- case branch_list of
[branch] -> return branch
_ -> failWithL (text "multi-branch axiom with newtype")
- ; let ax_lhs = mkInfForAllTys tvs $
- mkTyConApp tc lhs_tys
- nt_tvs = takeList tvs (tyConTyVars tc)
- -- axiom may be eta-reduced: Note [Newtype eta] in GHC.Core.TyCon
- nt_lhs = mkInfForAllTys nt_tvs $
- mkTyConApp tc (mkTyVarTys nt_tvs)
- -- See Note [Newtype eta] in GHC.Core.TyCon
- ; lintL (ax_lhs `eqType` nt_lhs)
+
+ -- The LHS of the axiom is (N lhs_tys)
+ -- We expect it to be (N ax_tvs)
+ ; lintL (mkTyVarTys ax_tvs `eqTypes` lhs_tys)
(text "Newtype axiom LHS does not match newtype definition")
; lintL (null cvs)
(text "Newtype axiom binds coercion variables")
@@ -2825,7 +2821,7 @@ lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches
(text "Newtype axiom has eta-tvs")
; lintL (ax_role == Representational)
(text "Newtype axiom role not representational")
- ; lintL (roles `equalLength` tvs)
+ ; lintL (roles `equalLength` ax_tvs)
(text "Newtype axiom roles list is the wrong length." $$
text "roles:" <+> sep (map ppr roles))
; lintL (roles == takeList roles (tyConRoles tc))
=====================================
compiler/GHC/Core/TyCo/Compare.hs
=====================================
@@ -122,33 +122,13 @@ tcEqTyConApps tc1 args1 tc2 args2
-- as differences in earlier (dependent) arguments
-{-
-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.
-
-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.
-
-See #19226.
--}
-
--- | This flag controls whether we expand synonyms during comparison
-data SynFlag = ExpandSynonyms | KeepSynonyms
-
-- | Type equality on lists of types, looking through type synonyms
eqTypes :: [Type] -> [Type] -> Bool
eqTypes [] [] = True
eqTypes (t1:ts1) (t2:ts2) = eqType t1 t2 && eqTypes ts1 ts2
eqTypes _ _ = False
-eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
+eqVarBndrs :: HasCallStack => RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
-- Check that the var lists are the same length
-- and have matching kinds; if so, extend the RnEnv2
-- Returns Nothing if they don't match
@@ -165,26 +145,26 @@ initRnEnv ta tb = mkRnEnv2 $ mkInScopeSet $
-- | Type equality comparing both visible and invisible arguments,
-- expanding synonyms and respecting multiplicities.
-eqType :: Type -> Type -> Bool
+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
-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.
-eqTypeX :: RnEnv2 -> Type -> Type -> Bool
+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_x ExpandSynonyms RespectMultiplicities
+eq_type_x = generic_eq_type ExpandSynonyms RespectMultiplicities
eqTypeIgnoringMultiplicity :: Type -> Type -> Bool
eqTypeIgnoringMultiplicity ta tb
= eq init_env ta tb
&& eq init_env (typeKind ta) (typeKind tb)
where
- eq = generic_eq_type_x ExpandSynonyms IgnoreMultiplicities
+ eq = generic_eq_type ExpandSynonyms IgnoreMultiplicities
init_env = initRnEnv ta tb
-- | Like 'pickyEqTypeVis', but returns a Bool for convenience
@@ -193,18 +173,37 @@ pickyEqType :: Type -> Type -> Bool
-- So (pickyEqType String [Char]) returns False
-- This ignores kinds and coercions, because this is used only for printing.
pickyEqType ta tb
- = generic_eq_type_x KeepSynonyms RespectMultiplicities (initRnEnv ta tb) ta tb
+ = generic_eq_type KeepSynonyms RespectMultiplicities (initRnEnv ta tb) 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.
+
+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.
+
+See #19226.
+-}
+
+-- | This flag controls whether we expand synonyms during comparison
+data SynFlag = ExpandSynonyms | KeepSynonyms
-- ---------------------------------------------------------------
-- | 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_x :: SynFlag -> MultiplicityFlag
+generic_eq_type :: SynFlag -> MultiplicityFlag
-> RnEnv2 -> Type -> Type
-> Bool
-- See Note [Computing equality on types] in Type
-{-# INLINE generic_eq_type_x #-} -- See Note [Specialising tc_eq_type].
-generic_eq_type_x syn_flag mult_flag
+{-# INLINE generic_eq_type #-} -- See Note [Specialising generic_eq_type].
+generic_eq_type syn_flag mult_flag
= go
where
go_with_kc :: RnEnv2 -> Type -> Type -> Bool
@@ -213,6 +212,8 @@ generic_eq_type_x syn_flag mult_flag
go :: RnEnv2 -> Type -> Type -> Bool
-- See Note [Comparing nullary type synonyms]
+ go _ t1 t2 | 1# <- reallyUnsafePtrEquality# t1 t2 = True
+
go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True
go env t1 t2 | ExpandSynonyms <- syn_flag, Just t1' <- coreView t1 = go env t1' t2
@@ -227,8 +228,8 @@ generic_eq_type_x syn_flag mult_flag
go env (ForAllTy (Bndr tv1 vis1) ty1)
(ForAllTy (Bndr tv2 vis2) ty2)
= vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality]
- && go (rnBndr2 env tv1 tv2) ty1 ty2
&& go env (varType tv1) (varType tv2) -- Always do kind-check
+ && go (rnBndr2 env tv1 tv2) ty1 ty2
-- Make sure we handle all FunTy cases since falling through to the
-- AppTy case means that tcSplitAppTyNoView_maybe may see an unzonked
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/691fb23802a952bf06b58a7021b72340d5a75cfd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/691fb23802a952bf06b58a7021b72340d5a75cfd
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/20240615/b081fd84/attachment-0001.html>
More information about the ghc-commits
mailing list