[Git][ghc/ghc][wip/T25647] go
Patrick (@soulomoon)
gitlab at gitlab.haskell.org
Fri Mar 14 23:53:01 UTC 2025
Patrick pushed to branch wip/T25647 at Glasgow Haskell Compiler / GHC
Commits:
169f0cd7 by Patrick at 2025-03-15T07:52:49+08:00
go
- - - - -
4 changed files:
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Types/Basic.hs
Changes:
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -1795,7 +1795,7 @@ defaultTyVarsAndSimplify rhs_tclvl candidates
; poly_kinds <- xoptM LangExt.PolyKinds
; let default_kv | poly_kinds = default_tv
| otherwise = defaultTyVar DefaultKindVars
- default_tv = defaultTyVar NonStandardDefaulting
+ default_tv = defaultTyVar (NonStandardDefaulting DefaultNonStandardTyVars)
; mapM_ default_kv (dVarSetElems cand_kvs)
; mapM_ default_tv (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -259,13 +259,12 @@ tcFamInstLHSBinders tclvl skol_info outer_bndrs hs_outer_bndrs wcs lhs_ty wanted
-- See GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts]
-- See Note [Type variables in type families instance decl]
; (dvs, outer_wcs_imp_dvs) <- candidateQTyVarsWithBinders outer_exp_tvs (outer_imp_tvs ++ wcs) lhs_ty
- ; qtvs <- quantifyTyVarsWithBinders skol_info dvs outer_wcs_imp_dvs
+ ; (qtvs, outer_wcs_imp_qtvs) <- quantifyTyVarsWithBinders skol_info dvs outer_wcs_imp_dvs
-- Have to make a same defaulting choice for result kind here
-- and the `kindGeneralizeAll` in `tcConDecl`.
-- see (GT4) in
-- GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts]
- ; let final_tvs = scopedSort (qtvs ++ outer_exp_tvs)
- ; let non_user_tvs = dVarSetElems $ mkDVarSet qtvs `delDVarSetList` outer_wcs_imp_dvs
+ ; let final_tvs = scopedSort (qtvs ++ outer_wcs_imp_qtvs ++ outer_exp_tvs)
-- This scopedSort is important: the qtvs may be /interleaved/ with
-- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts]
; traceTc "tcFamInstLHSBinders" $
@@ -278,15 +277,15 @@ tcFamInstLHSBinders tclvl skol_info outer_bndrs hs_outer_bndrs wcs lhs_ty wanted
-- after zonking
, text "dvs:" <+> ppr dvs
- , text "outer_wcs_imp_dvs:" <+> pprTyVars outer_wcs_imp_dvs
+ , text "outer_wcs_imp_dvs:" <+> ppr outer_wcs_imp_dvs
-- after quantification
, text "qtvs:" <+> pprTyVars qtvs
- , text "non_user_tvs:" <+> pprTyVars non_user_tvs
+ , text "outer_wcs_imp_qtvs:" <+> pprTyVars outer_wcs_imp_qtvs
, text "final_tvs:" <+> pprTyVars final_tvs
]
; reportUnsolvedEqualities skol_info final_tvs tclvl wanted
- return (final_tvs, non_user_tvs)
+ return (final_tvs, qtvs)
-- Gives the kind for every TyCon that has a standalone kind signature
type KindSigEnv = NameEnv Kind
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -142,7 +142,8 @@ import GHC.Builtin.Types
import GHC.Types.Var.Env
import GHC.Types.Unique.Set
import GHC.Types.Basic ( TypeOrKind(..)
- , DefaultingStrategy(..))
+ , NonStandardDefaultingStrategy(..)
+ , DefaultingStrategy(..), defaultNonStandardTyVars )
import GHC.Data.FastString
import GHC.Data.Bag
@@ -1370,10 +1371,13 @@ candidateVars (DV { dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set })
candidateKindVars :: CandidatesQTvs -> TyVarSet
candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs)
-intersectCandidates :: CandidatesQTvs -> [Var] -> [Var]
-intersectCandidates (DV { dv_kvs = kvs, dv_tvs = tvs }) varList
- = dVarSetElems $ kvs `intersectDVarSet` vars `unionDVarSet` (tvs `intersectDVarSet` vars)
- where vars = mkDVarSet varList
+intersectCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs
+intersectCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) varList
+ = DV { dv_kvs = kvs `intersectDVarSet` vars
+ , dv_tvs = tvs `intersectDVarSet` vars
+ , dv_cvs = cvs `intersectVarSet` mkVarSet varList }
+ where
+ vars = mkDVarSet varList
delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs
delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars
@@ -1390,7 +1394,7 @@ partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred
(extracted_tvs, rest_tvs) = partitionDVarSet pred tvs
extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs
-candidateQTyVarsWithBinders :: [TyVar] -> [TyVar] -> Type -> TcM (CandidatesQTvs, [TyVar])
+candidateQTyVarsWithBinders :: [TyVar] -> [TyVar] -> Type -> TcM (CandidatesQTvs, CandidatesQTvs)
-- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars
-- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose
-- of Note [Naughty quantification candidates]. Why?
@@ -1753,14 +1757,14 @@ quantifyTyVars :: SkolemInfo
-> CandidatesQTvs -- See Note [Dependent type variables]
-- Already zonked
-> TcM [TcTyVar]
-quantifyTyVars ski tvs = quantifyTyVarsWithBinders ski tvs []
+quantifyTyVars ski tvs = fst <$> quantifyTyVarsWithBinders ski tvs mempty
quantifyTyVarsWithBinders ::
SkolemInfo
-> CandidatesQTvs -- See Note [Dependent type variables]
-- Already zonked
- -> [TcTyVar]
- -> TcM [TcTyVar]
+ -> CandidatesQTvs -- try not to default
+ -> TcM ([TcTyVar], [TcTyVar])
-- See Note [quantifyTyVars]
-- Can be given a mixture of TcTyVars and TyVars, in the case of
-- associated type declarations. Also accepts covars, but *never* returns any.
@@ -1770,35 +1774,38 @@ quantifyTyVarsWithBinders ::
-- to the restrictions in Note [quantifyTyVars].
-- for outer_wcs_imp_tvs, do not default, just skolemise add to the list of quantified
-quantifyTyVarsWithBinders skol_info dvs outer_wcs_imp_tvs
+quantifyTyVarsWithBinders skol_info dvs outer_wcs_imp_dvs
-- short-circuit common case
- | isEmptyCandidates dvs && null outer_wcs_imp_tvs
+ | isEmptyCandidates dvs && isEmptyCandidates outer_wcs_imp_dvs
= do { traceTc "quantifyTyVars has nothing to quantify" empty
- ; return [] }
+ ; return ([], []) }
| otherwise
= do { traceTc "quantifyTyVars {"
( vcat [
text "dvs =" <+> ppr dvs,
- text "outer_wc_imp_qtvs=" <+> ppr outer_wcs_imp_tvs
+ text "outer_wc_imp_qtvs=" <+> ppr outer_wcs_imp_dvs
])
- ; undefaulted <- defaultTyVars dvs
- ; final_qtvs <- liftZonkM $ do
+ ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs
+ ; undefaulted_outer_wcs_imp_tvs <- defaultTyVars TryNotToDefaultNonStandardTyVars outer_wcs_imp_dvs
+ ; (final_qtvs, final_outer_wcs_imp_qtvs) <- liftZonkM $ do
-- resume order and then skolemise
- qtvs <- mapMaybeM zonk_quant undefaulted
- return qtvs
+ qtvs <- mapMaybeM zonk_quant $ undefaulted
+ outer_wcs_imp_qtvs <- mapMaybeM zonk_quant $ undefaulted_outer_wcs_imp_tvs
+ return (qtvs, outer_wcs_imp_qtvs)
; traceTc "quantifyTyVars }"
(vcat [ text "undefaulted:" <+> pprTyVars undefaulted
+ , text "final_outer_wcs_imp_qtvs:" <+> pprTyVars final_outer_wcs_imp_qtvs
, text "final_qtvs:" <+> pprTyVars final_qtvs
])
-- We should never quantify over coercion variables; check this
- ; let co_vars = filter isCoVar final_qtvs
+ ; let co_vars = filter isCoVar (final_qtvs ++ final_outer_wcs_imp_qtvs)
; massertPpr (null co_vars) (ppr co_vars)
- ; return final_qtvs }
+ ; return (final_qtvs, final_outer_wcs_imp_qtvs) }
where
-- zonk_quant returns a tyvar if it should be quantified over;
-- otherwise, it returns Nothing. The latter case happens for
@@ -1865,7 +1872,7 @@ defaultTyVar :: DefaultingStrategy
-> TcTyVar -- If it's a MetaTyVar then it is unbound
-> TcM Bool -- True <=> defaulted away altogether
defaultTyVar def_strat tv
- | not (isMetaTyVar tv )
+ | not (isMetaTyVar tv)
|| isTyVarTyVar tv
-- Do not default TyVarTvs. Doing so would violate the invariants
-- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType.
@@ -1874,16 +1881,19 @@ defaultTyVar def_strat tv
= return False
| isRuntimeRepVar tv
+ , default_ns_vars
= do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)
; liftZonkM $ writeMetaTyVar tv liftedRepTy
; return True }
| isLevityVar tv
+ , default_ns_vars
= do { traceTc "Defaulting a Levity var to Lifted" (ppr tv)
; liftZonkM $ writeMetaTyVar tv liftedDataConTy
; return True }
| isMultiplicityVar tv
+ , default_ns_vars
= do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv)
; liftZonkM $ writeMetaTyVar tv manyDataConTy
; return True }
@@ -1906,6 +1916,8 @@ defaultTyVar def_strat tv
= return False
where
+ default_ns_vars :: Bool
+ default_ns_vars = defaultNonStandardTyVars def_strat
default_kind_var :: TyVar -> TcM Bool
-- defaultKindVar is used exclusively with -XNoPolyKinds
-- See Note [Defaulting with -XNoPolyKinds]
@@ -1936,13 +1948,14 @@ defaultTyVar def_strat tv
-- - 'Multiplicity' tyvars default to 'Many'
-- - 'Type' tyvars from dv_kvs default to 'Type', when -XNoPolyKinds
-- (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error)
-defaultTyVars :: CandidatesQTvs -- ^ all candidates for quantification
+defaultTyVars :: NonStandardDefaultingStrategy
+ -> CandidatesQTvs -- ^ all candidates for quantification
-> TcM [TcTyVar] -- ^ those variables not defaulted
-defaultTyVars dvs
+defaultTyVars ns_strat dvs
= do { poly_kinds <- xoptM LangExt.PolyKinds
; let
def_tvs, def_kvs :: DefaultingStrategy
- def_tvs = NonStandardDefaulting
+ def_tvs = NonStandardDefaulting ns_strat
def_kvs | poly_kinds = def_tvs
| otherwise = DefaultKindVars
-- As -XNoPolyKinds precludes polymorphic kind variables, we default them.
@@ -2124,7 +2137,7 @@ doNotQuantifyTyVars dvs where_found
| otherwise
= do { traceTc "doNotQuantifyTyVars" (ppr dvs)
- ; undefaulted <- defaultTyVars dvs
+ ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs
-- could have regular TyVars here, in an associated type RHS, or
-- bound by a type declaration head. So filter looking only for
-- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c`
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -116,7 +116,8 @@ module GHC.Types.Basic (
TyConFlavour(..), TypeOrData(..), NewOrData(..), tyConFlavourAssoc_maybe,
- DefaultingStrategy(..),
+ NonStandardDefaultingStrategy(..),
+ DefaultingStrategy(..), defaultNonStandardTyVars,
ForeignSrcLang (..)
) where
@@ -2395,6 +2396,19 @@ GHC.Iface.Type.defaultIfaceTyVarsOfKind
-}
+-- | Specify whether to default type variables of kind 'RuntimeRep'/'Levity'/'Multiplicity'.
+data NonStandardDefaultingStrategy
+ -- | Default type variables of the given kinds:
+ --
+ -- - default 'RuntimeRep' variables to 'LiftedRep'
+ -- - default 'Levity' variables to 'Lifted'
+ -- - default 'Multiplicity' variables to 'Many'
+ = DefaultNonStandardTyVars
+ -- | Try not to default type variables of the kinds 'RuntimeRep'/'Levity'/'Multiplicity'.
+ --
+ -- Note that these might get defaulted anyway, if they are kind variables
+ -- and `-XNoPolyKinds` is enabled.
+ | TryNotToDefaultNonStandardTyVars
-- | Specify whether to default kind variables, and type variables
-- of kind 'RuntimeRep'/'Levity'/'Multiplicity'.
@@ -2410,12 +2424,19 @@ data DefaultingStrategy
--
-- Usually, we pass this option when -XNoPolyKinds is enabled.
= DefaultKindVars
- -- | Default non-standard variables, of kinds
+ -- | Default (or don't default) non-standard variables, of kinds
-- 'RuntimeRep', 'Levity' and 'Multiplicity'.
- | NonStandardDefaulting
+ | NonStandardDefaulting NonStandardDefaultingStrategy
+defaultNonStandardTyVars :: DefaultingStrategy -> Bool
+defaultNonStandardTyVars DefaultKindVars = True
+defaultNonStandardTyVars (NonStandardDefaulting DefaultNonStandardTyVars) = True
+defaultNonStandardTyVars (NonStandardDefaulting TryNotToDefaultNonStandardTyVars) = False
+instance Outputable NonStandardDefaultingStrategy where
+ ppr DefaultNonStandardTyVars = text "DefaultOnlyNonStandardTyVars"
+ ppr TryNotToDefaultNonStandardTyVars = text "TryNotToDefaultNonStandardTyVars"
instance Outputable DefaultingStrategy where
ppr DefaultKindVars = text "DefaultKindVars"
- ppr NonStandardDefaulting = text "NonStandardDefaulting"
+ ppr (NonStandardDefaulting ns) = text "NonStandardDefaulting" <+> ppr ns
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/169f0cd7af57b9eaea817f205aa6f53d1398f282
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/169f0cd7af57b9eaea817f205aa6f53d1398f282
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/20250314/a6e92c62/attachment-0001.html>
More information about the ghc-commits
mailing list