[Git][ghc/ghc][wip/T24978] 2 commits: Fix windows test output
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Sep 11 15:01:47 UTC 2024
Simon Peyton Jones pushed to branch wip/T24978 at Glasgow Haskell Compiler / GHC
Commits:
ede5eaa4 by Simon Peyton Jones at 2024-09-11T10:00:34+01:00
Fix windows test output
- - - - -
e4bdc821 by Simon Peyton Jones at 2024-09-11T16:01:14+01:00
Cache AxiomRule in CoAxBranch
- - - - -
18 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Axiom.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- utils/haddock/haddock-api/src/Haddock/Convert.hs
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -2009,55 +2009,56 @@ unsatisfiableClassNameKey = mkPreludeTyConUnique 170
-- Custom user type-errors
errorMessageTypeErrorFamKey :: Unique
-errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181
+errorMessageTypeErrorFamKey = mkPreludeTyConUnique 171
coercibleTyConKey :: Unique
-coercibleTyConKey = mkPreludeTyConUnique 183
+coercibleTyConKey = mkPreludeTyConUnique 172
proxyPrimTyConKey :: Unique
-proxyPrimTyConKey = mkPreludeTyConUnique 184
+proxyPrimTyConKey = mkPreludeTyConUnique 173
specTyConKey :: Unique
-specTyConKey = mkPreludeTyConUnique 185
+specTyConKey = mkPreludeTyConUnique 174
-anyTyConKey :: Unique
-anyTyConKey = mkPreludeTyConUnique 186
+anyTyConKey, anyAxKey :: Unique
+anyTyConKey = mkPreludeTyConUnique 175
+anyAxKey = mkPreludeTyConUnique 176
-smallArrayPrimTyConKey = mkPreludeTyConUnique 187
-smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 188
+smallArrayPrimTyConKey = mkPreludeTyConUnique 180
+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 181
staticPtrTyConKey :: Unique
-staticPtrTyConKey = mkPreludeTyConUnique 189
+staticPtrTyConKey = mkPreludeTyConUnique 182
staticPtrInfoTyConKey :: Unique
-staticPtrInfoTyConKey = mkPreludeTyConUnique 190
+staticPtrInfoTyConKey = mkPreludeTyConUnique 183
callStackTyConKey :: Unique
-callStackTyConKey = mkPreludeTyConUnique 191
+callStackTyConKey = mkPreludeTyConUnique 184
-- Typeables
typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique
-typeRepTyConKey = mkPreludeTyConUnique 192
-someTypeRepTyConKey = mkPreludeTyConUnique 193
-someTypeRepDataConKey = mkPreludeTyConUnique 194
+typeRepTyConKey = mkPreludeTyConUnique 185
+someTypeRepTyConKey = mkPreludeTyConUnique 186
+someTypeRepDataConKey = mkPreludeTyConUnique 187
typeSymbolAppendFamNameKey :: Unique
-typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195
+typeSymbolAppendFamNameKey = mkPreludeTyConUnique 188
-- Unsafe equality
unsafeEqualityTyConKey :: Unique
-unsafeEqualityTyConKey = mkPreludeTyConUnique 196
+unsafeEqualityTyConKey = mkPreludeTyConUnique 189
-- Linear types
multiplicityTyConKey :: Unique
-multiplicityTyConKey = mkPreludeTyConUnique 197
+multiplicityTyConKey = mkPreludeTyConUnique 190
unrestrictedFunTyConKey :: Unique
-unrestrictedFunTyConKey = mkPreludeTyConUnique 198
+unrestrictedFunTyConKey = mkPreludeTyConUnique 191
multMulTyConKey :: Unique
-multMulTyConKey = mkPreludeTyConUnique 199
+multMulTyConKey = mkPreludeTyConUnique 192
---------------- Template Haskell -------------------
-- GHC.Builtin.Names.TH: USES TyConUniques 200-299
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -196,6 +196,7 @@ import GHC.Types.Name.Env ( lookupNameEnv_NF, mkNameEnv )
import GHC.Types.Basic
import GHC.Types.ForeignCall
import GHC.Types.Unique.Set
+import GHC.Types.SrcLoc( wiredInSrcSpan )
import {-# SOURCE #-} GHC.Tc.Types.Origin
( FixedRuntimeRepOrigin(..), mkFRRUnboxedTuple, mkFRRUnboxedSum )
@@ -486,17 +487,21 @@ bit of history.
anyTyConName :: Name
-anyTyConName =
- mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon
+anyTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon
+
+anyAxName :: Name
+anyAxName = mkExternalName anyAxKey gHC_TYPES (mkTcOccFS (fsLit "R:Any")) wiredInSrcSpan
anyTyCon :: TyCon
-anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing
- (ClosedSynFamilyTyCon Nothing)
- Nothing
- NotInjective
+anyTyCon = tc
where
+ tc = mkFamilyTyCon anyTyConName binders res_kind Nothing
+ (ClosedSynFamilyTyCon co_ax)
+ Nothing
+ NotInjective
binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind]
res_kind = mkTyVarTy (binderVar kv)
+ co_ax = mkEmptyCoAxiom anyAxName tc
anyTy :: Type
anyTy = mkTyConTy anyTyCon
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1051,8 +1051,12 @@ mkAxiomCo = AxiomCo
-- to be used only with unbranched axioms
mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched
-> [Type] -> [Coercion] -> Coercion
-mkUnbranchedAxInstCo role ax tys cos
- = mkAxInstCo role (UnbranchedAxiom ax) tys cos
+mkUnbranchedAxInstCo role ax tys cos
+ = mkAxInstCo role ax_rule tys cos
+ where
+ !ax_rule = cab_axr (coAxiomNthBranch ax 0)
+ -- This will be (UnbranchedAxiom ax),
+ -- but we avoid allocating it every time
mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type
-- Instantiate the axiom with specified types,
=====================================
compiler/GHC/Core/Coercion/Axiom.hs
=====================================
@@ -19,6 +19,7 @@ module GHC.Core.Coercion.Axiom (
CoAxiom(..), CoAxBranch(..),
+ mkEmptyCoAxiom,
toBranchedAxiom, toUnbranchedAxiom,
coAxiomName, coAxiomArity, coAxiomBranches,
coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats,
@@ -26,7 +27,7 @@ module GHC.Core.Coercion.Axiom (
coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars,
coAxBranchRoles,
coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,
- placeHolderIncomps,
+ placeHolderIncomps, pairWithAxiomRules,
Role(..), fsFromRole,
@@ -158,10 +159,13 @@ newtype Branches (br :: BranchFlag)
type role Branches nominal
manyBranches :: [CoAxBranch] -> Branches Branched
-manyBranches brs = assert (snd bnds >= fst bnds )
+manyBranches brs = assert (snd bnds >= fst bnds - 1)
MkBranches (listArray bnds brs)
where
bnds = (0, length brs - 1)
+ -- The list of branches can be empty;
+ -- e.g. type family F a where {}
+ -- Then bnds = (0,-1) and the array is empty
unbranched :: CoAxBranch -> Branches Unbranched
unbranched br = MkBranches (listArray (0, 0) [br])
@@ -279,9 +283,25 @@ data CoAxBranch
, cab_incomps :: [CoAxBranch]
-- ^ The previous incompatible branches
-- See Note [Storing compatibility]
+
+ , cab_axr :: CoAxiomRule
+ -- ^ The parent axiom of this branch
+ -- Cached here so that we allocate it once and for all,
+ -- rather than re-allocating it every time we pick this branch
+ -- See Note [Avoiding allocating lots of CoAxiomRules]
}
deriving Data.Data
+mkEmptyCoAxiom :: Name -> TyCon -> CoAxiom Branched
+-- An axiom with no branches
+mkEmptyCoAxiom ax_name tycon
+ = CoAxiom { co_ax_unique = getUnique ax_name
+ , co_ax_name = ax_name
+ , co_ax_role = Nominal
+ , co_ax_tc = tycon
+ , co_ax_branches = manyBranches []
+ , co_ax_implicit = False }
+
toBranchedAxiom :: CoAxiom br -> CoAxiom Branched
toBranchedAxiom ax@(CoAxiom { co_ax_branches = branches })
= ax { co_ax_branches = toBranched branches }
@@ -353,6 +373,11 @@ coAxBranchIncomps = cab_incomps
placeHolderIncomps :: [CoAxBranch]
placeHolderIncomps = panic "placeHolderIncomps"
+pairWithAxiomRules :: CoAxiom Branched -> [a] -> [(a, CoAxiomRule)]
+pairWithAxiomRules ax [branch] = [(branch, UnbranchedAxiom (toUnbranchedAxiom ax))]
+pairWithAxiomRules ax branches = [(b, BranchedAxiom ax i)
+ | (b,i) <- branches `zip` [0..]]
+
{-
Note [CoAxBranch type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/FamInstEnv.hs
=====================================
@@ -71,7 +71,7 @@ import qualified GHC.Data.List.Infinite as Inf
import Control.Monad
import Data.List( mapAccumL )
-import Data.Array( Array, assocs )
+import Data.Array as Arr( Array, elems )
{-
************************************************************************
@@ -710,16 +710,16 @@ are tidying (changing OccNames only), not freshening, in accordance with
that Note.
-}
--- all axiom roles are Nominal, as this is only used with type families
mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars
-> [TyVar] -- Extra eta tyvars
-> [CoVar] -- possibly stale covars
-> [Type] -- LHS patterns
-> Type -- RHS
- -> [Role]
+ -> [Role] -- All axiom roles are Nominal, as this is only used with type families
-> SrcSpan
+ -> CoAxiomRule
-> CoAxBranch
-mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc
+mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc ax_rule
= CoAxBranch { cab_tvs = tvs'
, cab_eta_tvs = eta_tvs'
, cab_cvs = cvs'
@@ -727,7 +727,8 @@ mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc
, cab_roles = roles
, cab_rhs = tidyType env rhs
, cab_loc = loc
- , cab_incomps = placeHolderIncomps }
+ , cab_incomps = placeHolderIncomps
+ , cab_axr = ax_rule }
where
(env1, tvs') = tidyVarBndrs init_tidy_env tvs
(env2, eta_tvs') = tidyVarBndrs env1 eta_tvs
@@ -767,16 +768,17 @@ mkSingleCoAxiom :: Role -> Name
-- Used for both type family (Nominal) and data family (Representational)
-- axioms, hence passing in the Role
mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty
- = CoAxiom { co_ax_unique = nameUnique ax_name
- , co_ax_name = ax_name
- , co_ax_tc = fam_tc
- , co_ax_role = role
- , co_ax_implicit = False
- , co_ax_branches = unbranched (branch { cab_incomps = [] }) }
+ = co_ax
where
+ co_ax = CoAxiom { co_ax_unique = nameUnique ax_name
+ , co_ax_name = ax_name
+ , co_ax_tc = fam_tc
+ , co_ax_role = role
+ , co_ax_implicit = False
+ , co_ax_branches = unbranched (branch { cab_incomps = [] }) }
branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty
(map (const Nominal) tvs)
- (getSrcSpan ax_name)
+ (getSrcSpan ax_name) (UnbranchedAxiom co_ax)
-- | Create a coercion constructor (axiom) suitable for the given
-- newtype 'TyCon'. The 'Name' should be that of a new coercion
@@ -784,16 +786,18 @@ mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty
-- the type the appropriate right hand side of the @newtype@, with
-- the free variables a subset of those 'TyVar's.
mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched
-mkNewTypeCoAxiom name tycon tvs roles rhs_ty
- = CoAxiom { co_ax_unique = nameUnique name
- , co_ax_name = name
- , co_ax_implicit = True -- See Note [Implicit axioms] in GHC.Core.TyCon
- , co_ax_role = Representational
- , co_ax_tc = tycon
- , co_ax_branches = unbranched (branch { cab_incomps = [] }) }
+mkNewTypeCoAxiom ax_name tycon tvs roles rhs_ty
+ = co_ax
where
+ co_ax = CoAxiom { co_ax_unique = nameUnique ax_name
+ , co_ax_name = ax_name
+ , co_ax_implicit = True -- See Note [Implicit axioms] in GHC.Core.TyCon
+ , co_ax_role = Representational
+ , co_ax_tc = tycon
+ , co_ax_branches = unbranched (branch { cab_incomps = [] }) }
+
branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty
- roles (getSrcSpan name)
+ roles (getSrcSpan ax_name) (UnbranchedAxiom co_ax)
{-
************************************************************************
@@ -1192,8 +1196,8 @@ reduceTyFamApp_maybe envs role tc tys
in Just $ coercionRedn co
| Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc
- , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys
- = let co = mkAxInstCo role (BranchedAxiom ax ind) inst_tys inst_cos
+ , Just (ax_rule, inst_tys, inst_cos) <- chooseBranch ax tys
+ = let co = mkAxInstCo role ax_rule inst_tys inst_cos
in Just $ coercionRedn co
| Just builtin_fam <- isBuiltInSynFamTyCon_maybe tc
@@ -1206,30 +1210,30 @@ reduceTyFamApp_maybe envs role tc tys
-- The axiom can be oversaturated. (Closed families only.)
chooseBranch :: CoAxiom Branched -> [Type]
- -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args
+ -> Maybe (CoAxiomRule, [Type], [Coercion]) -- found match, with args
chooseBranch axiom tys
= do { let num_pats = coAxiomNumPats axiom
(target_tys, extra_tys) = splitAt num_pats tys
branches = coAxiomBranches axiom
- ; (ind, inst_tys, inst_cos)
+ ; (ax_rule, inst_tys, inst_cos)
<- findBranch (unMkBranches branches) target_tys
- ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) }
+ ; return (ax_rule, inst_tys `chkAppend` extra_tys, inst_cos) }
-- The axiom must *not* be oversaturated
findBranch :: Array BranchIndex CoAxBranch
-> [Type]
- -> Maybe (BranchIndex, [Type], [Coercion])
+ -> Maybe (CoAxiomRule, [Type], [Coercion])
-- coercions relate requested types to returned axiom LHS at role N
findBranch branches target_tys
- = foldr go Nothing (assocs branches)
+ = foldr go Nothing (Arr.elems branches)
where
- go :: (BranchIndex, CoAxBranch)
- -> Maybe (BranchIndex, [Type], [Coercion])
- -> Maybe (BranchIndex, [Type], [Coercion])
- go (index, branch) other
+ go :: CoAxBranch
+ -> Maybe (CoAxiomRule, [Type], [Coercion])
+ -> Maybe (CoAxiomRule, [Type], [Coercion])
+ go branch other
= let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs
, cab_lhs = tpl_lhs
- , cab_incomps = incomps }) = branch
+ , cab_incomps = incomps, cab_axr = ax_rule }) = branch
in_scope = mkInScopeSet (unionVarSets $
map (tyCoVarsOfTypes . coAxBranchLHS) incomps)
-- See Note [Flattening type-family applications when matching instances]
@@ -1241,7 +1245,7 @@ findBranch branches target_tys
-> -- matching worked & we're apart from all incompatible branches.
-- success
assert (all (isJust . lookupCoVar subst) tpl_cvs) $
- Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)
+ Just (ax_rule, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)
-- failure. keep looking
_ -> other
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -1280,7 +1280,7 @@ data FamTyConFlav
-- | A closed type synonym family e.g.
-- @type family F x where { F Int = Bool }@
- | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched))
+ | ClosedSynFamilyTyCon (CoAxiom Branched)
-- See Note [Closed type families]
-- | A closed type synonym family declared in an hs-boot file with
@@ -1293,8 +1293,7 @@ data FamTyConFlav
instance Outputable FamTyConFlav where
ppr (DataFamilyTyCon n) = text "data family" <+> ppr n
ppr OpenSynFamilyTyCon = text "open type family"
- ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family"
- ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax
+ ppr (ClosedSynFamilyTyCon coax) = text "closed type family" <+> ppr coax
ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family"
ppr (BuiltInSynFamTyCon _) = text "built-in type family"
@@ -2232,7 +2231,7 @@ isOpenTypeFamilyTyCon (TyCon { tyConDetails = details })
-- abstract or empty closed families.
isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched)
isClosedSynFamilyTyConWithAxiom_maybe (TyCon { tyConDetails = details })
- | FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb} <- details = mb
+ | FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon ax} <- details = Just ax
| otherwise = Nothing
isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily
=====================================
compiler/GHC/Iface/Decl.hs
=====================================
@@ -201,9 +201,8 @@ tyConToIfaceDecl env tycon
to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon
to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon
- to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing
- to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
- = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
+ to_if_fam_flav (ClosedSynFamilyTyCon ax)
+ = IfaceClosedSynFamilyTyCon (axn, ibr)
where defs = fromBranches $ coAxiomBranches ax
lhss = map coAxBranchLHS defs
ibr = map (coAxBranchToIfaceBranch tycon lhss) defs
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -518,9 +518,9 @@ rnIfaceClassBody d at IfConcreteClass{} = do
return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }
rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav
-rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))
- = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n
- <*> mapM rnIfaceAxBranch axs)
+rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (n, axs))
+ = IfaceClosedSynFamilyTyCon <$> ((,) <$> rnIfaceNeverExported n
+ <*> mapM rnIfaceAxBranch axs)
rnIfaceFamTyConFlav flav = pure flav
rnIfaceAT :: Rename IfaceAT
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -237,9 +237,8 @@ data IfaceTyConParent
data IfaceFamTyConFlav
= IfaceDataFamilyTyCon -- Data family
| IfaceOpenSynFamilyTyCon
- | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
+ | IfaceClosedSynFamilyTyCon (IfExtName, [IfaceAxBranch])
-- ^ Name of associated axiom and branches for pretty printing purposes,
- -- or 'Nothing' for an empty closed family without an axiom
-- See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr"
| IfaceAbstractClosedSynFamilyTyCon
| IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
@@ -1118,7 +1117,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon
pp_rhs IfaceBuiltInSynFamTyCon
= ppShowIface ss (text "built-in")
- pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs)))
+ pp_branches (IfaceClosedSynFamilyTyCon (ax, brs))
= vcat (unzipWith (pprAxBranch
(pprPrefixIfDeclBndr
(ss_how_much ss)
@@ -1708,9 +1707,8 @@ freeNamesIfIdDetails IfDFunId = emptyNameSet
freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet
-freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
+freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (ax, br))
= unitNameSet ax &&& fnList freeNamesIfAxBranch br
-freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -755,12 +755,13 @@ tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
tc_fam_flav tc_name IfaceDataFamilyTyCon
- = do { tc_rep_name <- newTyConRepName tc_name
- ; return (DataFamilyTyCon tc_rep_name) }
- tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
- tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
- = do { ax <- traverse (tcIfaceBranchedAxiom . fst) mb_ax_name_branches
- ; return (ClosedSynFamilyTyCon ax) }
+ = do { tc_rep_name <- newTyConRepName tc_name
+ ; return (DataFamilyTyCon tc_rep_name) }
+ tc_fam_flav _ IfaceOpenSynFamilyTyCon
+ = return OpenSynFamilyTyCon
+ tc_fam_flav _ (IfaceClosedSynFamilyTyCon (ax_name, _))
+ = do { ax <- tcIfaceBranchedAxiom ax_name
+ ; return (ClosedSynFamilyTyCon ax) }
tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
= return AbstractClosedSynFamilyTyCon
tc_fam_flav _ IfaceBuiltInSynFamTyCon
@@ -852,20 +853,22 @@ tc_iface_decl _parent ignore_prags
tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
, ifAxBranches = branches, ifRole = role })
= do { tc_tycon <- tcIfaceTyCon tc
- -- Must be done lazily, because axioms are forced when checking
- -- for family instance consistency, and the RHS may mention
- -- a hs-boot declared type constructor that is going to be
- -- defined by this module.
- -- e.g. type instance F Int = ToBeDefined
- -- See #13803
- ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)
- $ tc_ax_branches branches
- ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
- , co_ax_name = tc_name
- , co_ax_tc = tc_tycon
- , co_ax_role = role
- , co_ax_branches = manyBranches tc_branches
- , co_ax_implicit = False }
+ ; axiom <- fixM $ \ (axiom :: CoAxiom Branched) ->
+ -- Might actually be unbranched
+ -- fixM: just knot-tying for cab_ax_rule
+ do { tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name) $
+ tc_ax_branches (pairWithAxiomRules axiom branches)
+ -- forkM: Must be done lazily, because axioms are forced when
+ -- checking for family instance consistency, and the RHS may
+ -- mention a hs-boot declared type constructor that is going
+ -- to be defined by this module (see #13803)
+ -- e.g. type instance F Int = ToBeDefined
+ ; return (CoAxiom { co_ax_unique = nameUnique tc_name
+ , co_ax_name = tc_name
+ , co_ax_tc = tc_tycon
+ , co_ax_role = role
+ , co_ax_branches = manyBranches tc_branches
+ , co_ax_implicit = False }) }
; return (ACoAxiom axiom) }
tc_iface_decl _ _ (IfacePatSyn{ ifName = name
@@ -1068,16 +1071,16 @@ tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
-tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
+tc_ax_branches :: [(IfaceAxBranch, CoAxiomRule)] -> IfL [CoAxBranch]
tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
-tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
+tc_ax_branch :: [CoAxBranch] -> (IfaceAxBranch, CoAxiomRule) -> IfL [CoAxBranch]
tc_ax_branch prev_branches
(IfaceAxBranch { ifaxbTyVars = tv_bndrs
, ifaxbEtaTyVars = eta_tv_bndrs
, ifaxbCoVars = cv_bndrs
, ifaxbLHS = lhs, ifaxbRHS = rhs
- , ifaxbRoles = roles, ifaxbIncomps = incomps })
+ , ifaxbRoles = roles, ifaxbIncomps = incomps }, ax_rule)
= bindIfaceTyConBinders_AT
(map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
-- The _AT variant is needed here; see Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom
@@ -1095,7 +1098,8 @@ tc_ax_branch prev_branches
, cab_lhs = tc_lhs
, cab_roles = roles
, cab_rhs = tc_rhs
- , cab_incomps = map (prev_branches `getNth`) incomps }
+ , cab_incomps = map (prev_branches `getNth`) incomps
+ , cab_axr = ax_rule }
; return (prev_branches ++ [br]) }
tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -1422,13 +1422,10 @@ compatCon c1 c2
; check (eqType (dataConWrapperType c1) (dataConWrapperType c2))
MismatchedDataConTypes }
-eqClosedFamilyAx :: Maybe (CoAxiom br) -> Maybe (CoAxiom br1)
+eqClosedFamilyAx :: CoAxiom br -> CoAxiom br1
-> BootErrsM BootTyConMismatch
-eqClosedFamilyAx Nothing Nothing = checkSuccess
-eqClosedFamilyAx Nothing (Just _) = bootErr $ TyConAxiomMismatch $ NE.singleton MismatchedLength
-eqClosedFamilyAx (Just _) Nothing = bootErr $ TyConAxiomMismatch $ NE.singleton MismatchedLength
-eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))
- (Just (CoAxiom { co_ax_branches = branches2 }))
+eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 })
+ (CoAxiom { co_ax_branches = branches2 })
= checkListBy eqClosedFamilyBranch branch_list1 branch_list2
TyConAxiomMismatch
where
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -2978,28 +2978,31 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
False {- this doesn't matter here -}
ClosedTypeFamilyFlavour
- ; (branches, axiom_validity_infos) <-
- unzip <$> mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns
- -- Do not attempt to drop equations dominated by earlier
- -- ones here; in the case of mutual recursion with a data
- -- type, we get a knot-tying failure. Instead we check
- -- for this afterwards, in GHC.Tc.Validity.checkValidCoAxiom
- -- Example: tc265
-
-- Create a CoAxiom, with the correct src location.
; co_ax_name <- newFamInstAxiomName tc_lname []
- ; let mb_co_ax
- | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list
- | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)
+ ; (fam_tc, _, ax_validity_infos) <- fixM $ \ ~(_, co_ax, _) ->
+ -- fixM: just knot-tying, to pass co_ax to pairWithAxiomRule
+ do { (branches, ax_validity_infos) <-
+ unzip <$> mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated)
+ (pairWithAxiomRules co_ax eqns)
+ -- Do not attempt to drop equations dominated by earlier
+ -- ones here; in the case of mutual recursion with a data
+ -- type, we get a knot-tying failure. Instead we check
+ -- for this afterwards, in GHC.Tc.Validity.checkValidCoAxiom
+ -- Example: tc265
+
+ ; let fam_tc = mkFamilyTyCon tc_name tc_bndrs res_kind (resultVariableName sig)
+ (ClosedSynFamilyTyCon co_ax) parent inj'
+ co_ax = mkBranchedCoAxiom co_ax_name fam_tc branches
- fam_tc = mkFamilyTyCon tc_name tc_bndrs res_kind (resultVariableName sig)
- (ClosedSynFamilyTyCon mb_co_ax) parent inj'
+ ; return ( fam_tc, co_ax, ax_validity_infos ) }
-- We check for instance validity later, when doing validity
-- checking for the tycon. Exception: checking equations
-- overlap done by dropDominatedAxioms
- ; return (fam_tc, axiom_validity_infos) } }
+
+ ; return (fam_tc, ax_validity_infos) } }
-- | Maybe return a list of Bools that say whether a type family was declared
-- injective in the corresponding type arguments. Length of the list is equal to
@@ -3206,7 +3209,8 @@ kcTyFamInstEqn tc_fam_tc
}
--------------------------
-tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
+tcTyFamInstEqn :: TcTyCon -> AssocInstInfo
+ -> (LTyFamInstEqn GhcRn, KnotTied CoAxiomRule)
-> TcM (KnotTied CoAxBranch, TyFamEqnValidityInfo)
-- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families
-- (typechecked here) have TyFamInstEqns
@@ -3215,7 +3219,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo
(L loc (FamEqn { feqn_tycon = L _ eqn_tc_name
, feqn_bndrs = outer_bndrs
, feqn_pats = hs_pats
- , feqn_rhs = hs_rhs_ty }))
+ , feqn_rhs = hs_rhs_ty }), ax_rule)
= setSrcSpanA loc $
do { traceTc "tcTyFamInstEqn" $
vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats
@@ -3234,7 +3238,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo
; let ax = mkCoAxBranch qtvs [] [] pats rhs_ty
(map (const Nominal) qtvs)
- (locA loc)
+ (locA loc) ax_rule
vi = VI { vi_loc = locA loc
, vi_qtvs = qtvs
, vi_non_user_tvs = non_user_tvs
@@ -4505,10 +4509,9 @@ checkValidTyCon tc
| Just fam_flav <- famTyConFlav_maybe tc
-> case fam_flav of
- { ClosedSynFamilyTyCon (Just ax)
+ { ClosedSynFamilyTyCon ax
-> tcAddClosedTypeFamilyDeclCtxt tc $
checkValidCoAxiom ax
- ; ClosedSynFamilyTyCon Nothing -> return ()
; AbstractClosedSynFamilyTyCon ->
do { hsBoot <- tcIsHsBootOrSig
; checkTc hsBoot $ TcRnAbstractClosedTyFamDecl }
=====================================
compiler/GHC/Tc/TyCl/Build.hs
=====================================
@@ -50,8 +50,8 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
-- We pass the Name of the parent TyCon, as well as the TyCon itself,
-- because the latter is part of a knot, whereas the former is not.
mkNewTyConRhs tycon_name tycon con
- = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
- ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
+ = do { co_ax_name <- newImplicitBinder tycon_name mkNewTyCoOcc
+ ; let nt_ax = mkNewTypeCoAxiom co_ax_name tycon etad_tvs etad_roles etad_rhs
; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
; return (NewTyCon { data_con = con,
nt_rhs = rhs_ty,
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -605,22 +605,25 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
TcRnIllegalInstance $ IllegalFamilyInstance $
NotAnOpenFamilyTyCon fam_tc
- -- (1) do the work of verifying the synonym group
- -- For some reason we don't have a location for the equation
- -- itself, so we make do with the location of family name
- ; (co_ax_branch, co_ax_validity_info)
- <- tcTyFamInstEqn fam_tc mb_clsinfo
- (L (l2l $ getLoc fam_lname) eqn)
-
- -- (2) check for validity
+ ; (co_ax,co_ax_branch, co_ax_validity_info) <- fixM $ \ ~(co_ax, _, _) ->
+ -- fixM: just knot-tying
+ do { let eqn_w_loc = L (l2l $ getLoc fam_lname) eqn
+ -- eqn_w_loc: for some reason we don't have a location for the
+ -- equation itself, so we make do with the location of family name
+
+ ; (co_ax_branch, co_ax_validity_info) <- tcTyFamInstEqn fam_tc mb_clsinfo
+ (eqn_w_loc, UnbranchedAxiom co_ax)
+
+ ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]
+ ; let co_ax = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
+ ; return (co_ax, co_ax_branch, co_ax_validity_info) }
+
+ -- Check for validity
; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
; checkTyFamEqnValidityInfo fam_tc co_ax_validity_info
; checkValidCoAxBranch fam_tc co_ax_branch
- -- (3) construct coercion axiom
- ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]
- ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
- ; newFamInst SynFamilyInst axiom }
+ ; newFamInst SynFamilyInst co_ax }
---------------------
=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -410,9 +410,8 @@ thinModIface avails iface =
ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
ifaceDeclNeverExportedRefs d at IfaceFamily{} =
case ifFamFlav d of
- IfaceClosedSynFamilyTyCon (Just (n, _))
- -> [n]
- _ -> []
+ IfaceClosedSynFamilyTyCon (n, _) -> [n]
+ _ -> []
ifaceDeclNeverExportedRefs _ = []
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -858,7 +858,9 @@ data InjectivityAnn pass
data FamilyInfo pass
= DataFamily
+
| OpenTypeFamily
+
-- | 'Nothing' if we're in an hs-boot file and the user
-- said "type family Foo x where .."
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
@@ -869,11 +871,11 @@ familyInfoTyConFlavour
-> TyConFlavour tc
familyInfoTyConFlavour mb_parent_tycon info =
case info of
- DataFamily -> OpenFamilyFlavour IAmData mb_parent_tycon
- OpenTypeFamily -> OpenFamilyFlavour IAmType mb_parent_tycon
- ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon)
- -- See Note [Closed type family mb_parent_tycon]
- ClosedTypeFamilyFlavour
+ DataFamily -> OpenFamilyFlavour IAmData mb_parent_tycon
+ OpenTypeFamily -> OpenFamilyFlavour IAmType mb_parent_tycon
+ ClosedTypeFamily {} -> assert (isNothing mb_parent_tycon)
+ -- See Note [Closed type family mb_parent_tycon]
+ ClosedTypeFamilyFlavour
{- Note [Closed type family mb_parent_tycon]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -5424,8 +5424,8 @@ module GHC.Event.Windows.ManagedThreadPool where
thrCallBack :: GHC.Internal.Event.Windows.ManagedThreadPool.WorkerJob,
thrActiveThreads :: GHC.Internal.MVar.MVar GHC.Types.Int,
thrMonitor :: GHC.Internal.MVar.MVar (),
- thrThreadIds :: ! {-# UNPACK #-}(ghc-internal-0.1.0.0:GHC.Internal.Event.Array.N:Array[0] <GHC.Internal.Conc.Sync.ThreadId>_P
- ; GHC.Internal.IORef.N:IORef[0] <ghc-internal-0.1.0.0:GHC.Internal.Event.Array.AC GHC.Internal.Conc.Sync.ThreadId>_N)(ghc-internal-0.1.0.0:GHC.Internal.Event.Array.Array GHC.Internal.Conc.Sync.ThreadId)}
+ thrThreadIds :: ! {-# UNPACK #-}(ghc-internal-0.1.0.0:GHC.Internal.Event.Array.N:Array <GHC.Internal.Conc.Sync.ThreadId>_P
+ ; GHC.Internal.IORef.N:IORef <ghc-internal-0.1.0.0:GHC.Internal.Event.Array.AC GHC.Internal.Conc.Sync.ThreadId>_N)(ghc-internal-0.1.0.0:GHC.Internal.Event.Array.Array GHC.Internal.Conc.Sync.ThreadId)}
monitorThreadPool :: GHC.Internal.MVar.MVar () -> GHC.Types.IO ()
notifyRunning :: GHC.Internal.Maybe.Maybe ThreadPool -> GHC.Types.IO ()
notifyWaiting :: GHC.Internal.Maybe.Maybe ThreadPool -> GHC.Types.IO ()
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -291,14 +291,9 @@ synifyTyCon _prr _coax tc
case flav of
-- Type families
OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily
- ClosedSynFamilyTyCon mb
- | Just (CoAxiom{co_ax_branches = branches}) <- mb ->
- mkFamDecl $
- ClosedTypeFamily $
- Just $
- map (noLocA . synifyAxBranch tc) (fromBranches branches)
- | otherwise ->
- mkFamDecl $ ClosedTypeFamily $ Just []
+ ClosedSynFamilyTyCon (CoAxiom{co_ax_branches = branches}) ->
+ mkFamDecl $ ClosedTypeFamily $
+ Just $ map (noLocA . synifyAxBranch tc) (fromBranches branches)
BuiltInSynFamTyCon{} ->
mkFamDecl $ ClosedTypeFamily $ Just []
AbstractClosedSynFamilyTyCon{} ->
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a1f66dcb6e8d17f2c89b2a82f6a822fd64817886...e4bdc821f1e4863074a73cc032082dd2251a80f8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a1f66dcb6e8d17f2c89b2a82f6a822fd64817886...e4bdc821f1e4863074a73cc032082dd2251a80f8
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/20240911/f4a41c18/attachment-0001.html>
More information about the ghc-commits
mailing list