- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/fendor/t23703] 2 commits: Refactor distinct constructor tables map construction
by Hannes Siebenhandl (＠fendor) 08 Oct '25

08 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/t23703 at Glasgow Haskell Compiler / GHC Commits: f727ab5f by Finley McIlwaine at 2025-10-08T09:23:26+02:00 Refactor distinct constructor tables map construction Adds `GHC.Types.Unique.FM.alterUFM_L`, `GHC.Types.Unique.DFM.alterUDFM_L` `GHC.Data.Word64Map.alterLookupWithKey` to support fusion of distinct constructor data insertion and lookup during the construction of the data con map in `GHC.Stg.Debug.numberDataCon`. - - - - - f417a8bb by Finley McIlwaine at 2025-10-08T09:27:10+02:00 Allow per constructor refinement of distinct-constructor-tables Introduce `-fno-distinct-constructor-tables`. A distinct constructor table configuration is built from the combination of flags given, in order. For example, to only generate distinct constructor tables for a few specific constructors and no others, just pass `-fdistinct-constructor-tables-only=C1,...,CN`. This flag can be supplied multiple times to extend the set of constructors to generate a distinct info table for. You can disable generation of distinct constructor tables for all configurations by passing `-fno-distinct-constructor-tables`. The various configurations of these flags is included in the `DynFlags` fingerprints, which should result in the expected recompilation logic. Adds a test that checks for distinct tables for various given or omitted constructors. Updates CountDepsAst and CountDepsParser tests to account for new dependencies. Fixes #23703 - - - - - 33 changed files: - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Lazy.hs - compiler/GHC/Driver/Config/Stg/Debug.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Flags.hs - compiler/GHC/Iface/Recomp/Flags.hs - compiler/GHC/Stg/Debug.hs - + compiler/GHC/Stg/Debug/Types.hs - compiler/GHC/Types/Unique/DFM.hs - compiler/GHC/Types/Unique/FM.hs - compiler/ghc.cabal.in - docs/users_guide/debug-info.rst - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/rts/ipe/distinct-tables/Main.hs - + testsuite/tests/rts/ipe/distinct-tables/Makefile - + testsuite/tests/rts/ipe/distinct-tables/X.hs - + testsuite/tests/rts/ipe/distinct-tables/all.T - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables01.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables02.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables03.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables04.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables05.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables06.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables07.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables08.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables09.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables10.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables11.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables12.stdout - + testsuite/tests/rts/ipe/distinct-tables/distinct_tables13.stdout The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b54fce328838356fe626e539c95a37… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b54fce328838356fe626e539c95a37… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/occ_anal_tuning] OccAnal: Be stricter when combining usageDetails.
by Andreas Klebinger (＠AndreasK) 08 Oct '25

08 Oct '25

Andreas Klebinger pushed to branch wip/andreask/occ_anal_tuning at Glasgow Haskell Compiler / GHC Commits: 2076be78 by Andreas Klebinger at 2025-10-08T09:13:36+02:00 OccAnal: Be stricter when combining usageDetails. In combineUsageDetails when combining the underlying adds we compute a new `LocalOcc` for each entry by combining the two existing ones. Rather than wait for those entries to be forced down the road we now force them immediately. Speeding up T26425 by about 10% with little effect on the common case. ------------------------- Metric Decrease: T26425 ------------------------- - - - - - 4 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Data/Graph/UnVar.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var/Env.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -9,6 +9,8 @@ -- many /other/ arguments the function has. Inconsistent unboxing is very -- bad for performance, so I increased the limit to allow it to unbox -- consistently. +-- AK: Seems we no longer unbox OccEnv now anyway so it might be redundant. + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -62,6 +64,7 @@ import GHC.Utils.Misc import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) +import GHC.Data.Graph.UnVar as UnVar import Data.List (mapAccumL) import Data.List.NonEmpty (NonEmpty (..)) @@ -984,7 +987,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine = -- Analyse the RHS and /then/ the body let -- Analyse the rhs first, generating rhs_uds !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs - rhs_uds = foldr1 orUDs rhs_uds_s -- NB: orUDs. See (W4) of + rhs_uds = foldl1' orUDs rhs_uds_s -- NB: orUDs. See (W4) of -- Note [Occurrence analysis for join points] -- Now analyse the body, adding the join point @@ -3610,6 +3613,7 @@ localTailCallInfo :: LocalOcc -> TailCallInfo localTailCallInfo (OneOccL { lo_tail = tci }) = tci localTailCallInfo (ManyOccL tci) = tci +-- type ZappedSet = UnVar.UnVarSet -- Values are ignored type ZappedSet = OccInfoEnv -- Values are ignored data UsageDetails @@ -3650,8 +3654,8 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a ------------------- -- UsageDetails API -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails +andUDs:: UsageDetails -> UsageDetails -> UsageDetails +orUDs :: UsageDetails -> UsageDetails -> UsageDetails andUDs = combineUsageDetailsWith andLocalOcc orUDs = combineUsageDetailsWith orLocalOcc @@ -3760,16 +3764,20 @@ restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc) -> UsageDetails -> UsageDetails -> UsageDetails {-# INLINE combineUsageDetailsWith #-} +{-# SCC combineUsageDetailsWith #-} combineUsageDetailsWith plus_occ_info uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 }) uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 }) | isEmptyVarEnv env1 = uds2 | isEmptyVarEnv env2 = uds1 | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2 - , ud_z_many = plusVarEnv z_many1 z_many2 - , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 - , ud_z_tail = plusVarEnv z_tail1 z_tail2 } + -- Typically we end up forcing those values later anyway. So we can avoid storking thunks retaining + -- the original LocalOcc by using a strict combination function here. The fields themselves are already + -- strict so no need to force those explicitly. + = UD { ud_env = {-# SCC ud_env #-} strictPlusVarEnv_C plus_occ_info env1 env2 + , ud_z_many = {-# SCC ud_z_many #-} strictPlusVarEnv z_many1 z_many2 + , ud_z_in_lam = {-# SCC ud_z_in_lam #-} strictPlusVarEnv z_in_lam1 z_in_lam2 + , ud_z_tail = {-# SCC ud_z_tail #-} strictPlusVarEnv z_tail1 z_tail2 } lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- Don't use locally-generated occ_info for exported (visible-elsewhere) ===================================== compiler/GHC/Data/Graph/UnVar.hs ===================================== @@ -17,8 +17,8 @@ equal to g, but twice as expensive and large. module GHC.Data.Graph.UnVar ( UnVarSet , emptyUnVarSet, mkUnVarSet, unionUnVarSet, unionUnVarSets - , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList - , elemUnVarSet, isEmptyUnVarSet + , extendUnVarSet, extendUnVarSet_Directly, extendUnVarSetList, delUnVarSet, delUnVarSetList + , elemUnVarSet, elemUnVarSet_Directly, isEmptyUnVarSet , UnVarGraph , emptyUnVarGraph , unionUnVarGraph, unionUnVarGraphs @@ -60,6 +60,9 @@ emptyUnVarSet = UnVarSet S.empty elemUnVarSet :: Var -> UnVarSet -> Bool elemUnVarSet v (UnVarSet s) = k v `S.member` s +{-# INLINE elemUnVarSet_Directly #-} +elemUnVarSet_Directly :: Uniquable key => key -> UnVarSet -> Bool +elemUnVarSet_Directly v (UnVarSet s) = (getKey $ getUnique v) `S.member` s isEmptyUnVarSet :: UnVarSet -> Bool isEmptyUnVarSet (UnVarSet s) = S.null s @@ -82,6 +85,10 @@ mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs extendUnVarSet :: Var -> UnVarSet -> UnVarSet extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s +{-# INLINE extendUnVarSet_Directly #-} +extendUnVarSet_Directly :: Uniquable key => key -> UnVarSet -> UnVarSet +extendUnVarSet_Directly u (UnVarSet s) = UnVarSet $ S.insert (getKey $ getUnique u) s + extendUnVarSetList :: [Var] -> UnVarSet -> UnVarSet extendUnVarSetList vs s = s `unionUnVarSet` mkUnVarSet vs ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -51,7 +51,9 @@ module GHC.Types.Unique.FM ( delListFromUFM, delListFromUFM_Directly, plusUFM, + strictPlusUFM, plusUFM_C, + strictPlusUFM_C, plusUFM_CD, plusUFM_CD2, mergeUFM, @@ -251,16 +253,24 @@ delListFromUFM_Directly = foldl' delFromUFM_Directly delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) --- Bindings in right argument shadow those in the left +-- | Bindings in right argument shadow those in the left. +-- +-- Unlike containers this union is right-biased for historic reasons. plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt --- M.union is left-biased, plusUFM should be right-biased. plusUFM (UFM x) (UFM y) = UFM (M.union y x) -- Note (M.union y x), with arguments flipped -- M.union is left-biased, plusUFM should be right-biased. +-- | Right biased +strictPlusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM (UFM x) (UFM y) = UFM (MS.union y x) + plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) +strictPlusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM_C f (UFM x) (UFM y) = UFM (MS.unionWith f x y) + -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the -- combinding function and `d1` resp. `d2` as the default value if -- there is no entry in `m1` reps. `m2`. The domain is the union of ===================================== compiler/GHC/Types/Var/Env.hs ===================================== @@ -12,7 +12,8 @@ module GHC.Types.Var.Env ( elemVarEnv, disjointVarEnv, anyVarEnv, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + strictPlusVarEnv, plusVarEnv, plusVarEnv_C, strictPlusVarEnv_C, + plusVarEnv_CD, plusMaybeVarEnv_C, plusVarEnvList, alterVarEnv, delVarEnvList, delVarEnv, minusVarEnv, @@ -511,6 +512,7 @@ extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a plusVarEnvList :: [VarEnv a] -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a varEnvDomain :: VarEnv elt -> UnVarSet @@ -522,6 +524,7 @@ delVarEnvList :: Foldable f => VarEnv a -> f Var -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b @@ -548,6 +551,7 @@ extendVarEnv_C = addToUFM_C extendVarEnv_Acc = addToUFM_Acc extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C +strictPlusVarEnv_C = strictPlusUFM_C plusVarEnv_CD = plusUFM_CD plusMaybeVarEnv_C = plusMaybeUFM_C delVarEnvList = delListFromUFM @@ -556,6 +560,7 @@ delVarEnvList = delListFromUFM delVarEnv = delFromUFM minusVarEnv = minusUFM plusVarEnv = plusUFM +strictPlusVarEnv = strictPlusUFM plusVarEnvList = plusUFMList -- lookupVarEnv is very hot (in part due to being called by substTyVar), -- if it's not inlined than the mere allocation of the Just constructor causes View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2076be78cec3f31fac74492e63922ec… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2076be78cec3f31fac74492e63922ec… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/occ_anal_tuning] OccAnal: Be stricter when combining usageDetails.
by Andreas Klebinger (＠AndreasK) 08 Oct '25

08 Oct '25

Andreas Klebinger pushed to branch wip/andreask/occ_anal_tuning at Glasgow Haskell Compiler / GHC Commits: 19b591cd by Andreas Klebinger at 2025-10-08T09:05:48+02:00 OccAnal: Be stricter when combining usageDetails. In combineUsageDetails when combining the underlying adds we compute a new `LocalOcc` for each entry by combining the two existing ones. Rather than wait for those entries to be forced down the road we now force them immediately. Speeding up T26425 by about 10% with little effect on the common case. ------------------------- Metric Decrease: T26425 ------------------------- - - - - - 4 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var/Env.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -10,6 +10,10 @@ -- bad for performance, so I increased the limit to allow it to unbox -- consistently. +-- {-# OPTIONS_GHC -ddump-simpl -ddump-stg -dumpdir dumps -ddump-to-file #-} +-- {-# OPTIONS_GHC -fdistinct-constructor-tables -finfo-table-map #-} +-- {-# OPTIONS_GHC -ticky -ticky-allocd -ticky-LNE #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -984,7 +988,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine = -- Analyse the RHS and /then/ the body let -- Analyse the rhs first, generating rhs_uds !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs - rhs_uds = foldr1 orUDs rhs_uds_s -- NB: orUDs. See (W4) of + rhs_uds = foldl1' orUDs rhs_uds_s -- NB: orUDs. See (W4) of -- Note [Occurrence analysis for join points] -- Now analyse the body, adding the join point @@ -3650,8 +3654,10 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a ------------------- -- UsageDetails API -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails +-- {-# NOINLINE andUDs #-} +-- {-# NOINLINE orUDs #-} +andUDs:: UsageDetails -> UsageDetails -> UsageDetails +orUDs :: UsageDetails -> UsageDetails -> UsageDetails andUDs = combineUsageDetailsWith andLocalOcc orUDs = combineUsageDetailsWith orLocalOcc @@ -3760,16 +3766,17 @@ restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc) -> UsageDetails -> UsageDetails -> UsageDetails {-# INLINE combineUsageDetailsWith #-} +{-# SCC combineUsageDetailsWith #-} combineUsageDetailsWith plus_occ_info uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 }) uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 }) | isEmptyVarEnv env1 = uds2 | isEmptyVarEnv env2 = uds1 | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2 - , ud_z_many = plusVarEnv z_many1 z_many2 - , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 - , ud_z_tail = plusVarEnv z_tail1 z_tail2 } + = UD { ud_env = {-# SCC ud_env #-} strictPlusVarEnv_C plus_occ_info env1 env2 + , ud_z_many = {-# SCC ud_z_many #-} strictPlusVarEnv z_many1 z_many2 + , ud_z_in_lam = {-# SCC ud_z_in_lam #-} strictPlusVarEnv z_in_lam1 z_in_lam2 + , ud_z_tail = {-# SCC ud_z_tail #-} strictPlusVarEnv z_tail1 z_tail2 } lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- Don't use locally-generated occ_info for exported (visible-elsewhere) ===================================== compiler/GHC/Data/Word64Map/Internal.hs ===================================== @@ -3,6 +3,7 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -ddump-simpl -ddump-stg-final -ddump-to-file -dumpdir dumps #-} ----------------------------------------------------------------------------- ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -51,7 +51,9 @@ module GHC.Types.Unique.FM ( delListFromUFM, delListFromUFM_Directly, plusUFM, + strictPlusUFM, plusUFM_C, + strictPlusUFM_C, plusUFM_CD, plusUFM_CD2, mergeUFM, @@ -251,16 +253,24 @@ delListFromUFM_Directly = foldl' delFromUFM_Directly delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) --- Bindings in right argument shadow those in the left +-- | Bindings in right argument shadow those in the left. +-- +-- Unlike containers this union is right-biased for historic reasons. plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt --- M.union is left-biased, plusUFM should be right-biased. plusUFM (UFM x) (UFM y) = UFM (M.union y x) -- Note (M.union y x), with arguments flipped -- M.union is left-biased, plusUFM should be right-biased. +-- | Right biased +strictPlusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM (UFM x) (UFM y) = UFM (MS.union y x) + plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) +strictPlusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM_C f (UFM x) (UFM y) = UFM (MS.unionWith f x y) + -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the -- combinding function and `d1` resp. `d2` as the default value if -- there is no entry in `m1` reps. `m2`. The domain is the union of ===================================== compiler/GHC/Types/Var/Env.hs ===================================== @@ -12,7 +12,8 @@ module GHC.Types.Var.Env ( elemVarEnv, disjointVarEnv, anyVarEnv, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + strictPlusVarEnv, plusVarEnv, plusVarEnv_C, strictPlusVarEnv_C, + plusVarEnv_CD, plusMaybeVarEnv_C, plusVarEnvList, alterVarEnv, delVarEnvList, delVarEnv, minusVarEnv, @@ -511,6 +512,7 @@ extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a plusVarEnvList :: [VarEnv a] -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a varEnvDomain :: VarEnv elt -> UnVarSet @@ -522,6 +524,7 @@ delVarEnvList :: Foldable f => VarEnv a -> f Var -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b @@ -548,6 +551,7 @@ extendVarEnv_C = addToUFM_C extendVarEnv_Acc = addToUFM_Acc extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C +strictPlusVarEnv_C = strictPlusUFM_C plusVarEnv_CD = plusUFM_CD plusMaybeVarEnv_C = plusMaybeUFM_C delVarEnvList = delListFromUFM @@ -556,6 +560,7 @@ delVarEnvList = delListFromUFM delVarEnv = delFromUFM minusVarEnv = minusUFM plusVarEnv = plusUFM +strictPlusVarEnv = strictPlusUFM plusVarEnvList = plusUFMList -- lookupVarEnv is very hot (in part due to being called by substTyVar), -- if it's not inlined than the mere allocation of the Just constructor causes View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19b591cd6036700f788cc082cb819ed… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19b591cd6036700f788cc082cb819ed… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: T22033 is only relevant if the word size is 64-bit
by Marge Bot (＠marge-bot) 08 Oct '25

08 Oct '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 18d68a70 by ARATA Mizuki at 2025-10-08T00:46:36-04:00 T22033 is only relevant if the word size is 64-bit Fixes #25497 - - - - - 0bb9836d by Ben Gamari at 2025-10-08T00:46:38-04:00 rts/posix: Enforce iteration limit on heap reservation logic Previously we could loop indefinitely when attempting to get an address space reservation for our heap. Limit the logic to 8 iterations to ensure we instead issue a reasonable error message. Addresses #26151. - - - - - 5a4a02d6 by Ben Gamari at 2025-10-08T00:46:39-04:00 rts/posix: Hold on to low reservations when reserving heap Previously when the OS gave us an address space reservation in low memory we would immediately release it and try again. However, on some platforms this meant that we would get the same allocation again in the next iteration (since mmap's `hint` argument is just that, a hint). Instead we now hold on to low reservations until we have found a suitable heap reservation. Fixes #26151. - - - - - cf643449 by Sven Tennie at 2025-10-08T00:46:39-04:00 Build terminfo only in upper stages in cross-builds (#26288) Currently, there's no way to provide library paths for [n]curses for both - build and target - in cross-builds. As stage0 is only used to build upper stages, it should be fine to build terminfo only for them. This re-enables building cross-compilers with terminfo. - - - - - b6bbcd37 by Julian Ospald at 2025-10-08T00:46:45-04:00 ghc-toolchain: Drop `ld.gold` from merge object command It's deprecated. Also see #25716 - - - - - 6 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - hadrian/src/Settings/Default.hs - rts/posix/OSMem.c - testsuite/tests/llvm/should_run/all.T - utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -489,7 +489,6 @@ alpineVariables arch = mconcat $ [ mconcat [ brokenTest test "#25498" | test <- ["simd009", "T25169"] ] | I386 <- [arch] ] ++ - [ brokenTest "T22033" "#25497" | I386 <- [arch] ] ++ [ -- Bootstrap compiler has incorrectly configured target triple #25200 "CONFIGURE_ARGS" =: "--enable-ignore-build-platform-mismatch --build=aarch64-unknown-linux --host=aarch64-unknown-linux --target=aarch64-unknown-linux" | AArch64 <- [arch] ===================================== .gitlab/jobs.yaml ===================================== @@ -532,7 +532,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-i386-linux-alpine3_22-validate", - "BROKEN_TESTS": "encoding004 T10458 simd009 T25169 T22033", + "BROKEN_TESTS": "encoding004 T10458 simd009 T25169", "BUILD_FLAVOUR": "validate", "CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check", @@ -1203,7 +1203,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-i386-linux-alpine3_22-validate", - "BROKEN_TESTS": "encoding004 T10458 simd009 T25169 T22033", + "BROKEN_TESTS": "encoding004 T10458 simd009 T25169", "BUILD_FLAVOUR": "validate", "CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check", @@ -4017,7 +4017,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-i386-linux-alpine3_22-release+no_split_sections", - "BROKEN_TESTS": "encoding004 T10458 simd009 T25169 T22033", + "BROKEN_TESTS": "encoding004 T10458 simd009 T25169", "BUILD_FLAVOUR": "release+no_split_sections", "CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check", "IGNORE_PERF_FAILURES": "all", ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -80,7 +80,6 @@ stageBootPackages = return stage0Packages :: Action [Package] stage0Packages = do cross <- flag CrossCompiling - haveCurses <- any (/= "") <$> traverse setting [ CursesIncludeDir, CursesLibDir ] return $ [ cabalSyntax , cabal , compiler @@ -116,7 +115,11 @@ stage0Packages = do -- that confused Hadrian, so we must make those a stage0 package as well. -- Once we drop `Win32`/`unix` it should be possible to drop those too. ] - ++ [ terminfo | not windowsHost, (not cross || haveCurses) ] + -- Currently, we have no way to provide paths to [n]curses libs for + -- both - build and target - in cross builds. Thus, we only build it + -- for upper stages. As we only use stage0 to build upper stages, + -- this should be fine. + ++ [ terminfo | not windowsHost, not cross ] ++ [ timeout | windowsHost ] -- | Packages built in 'Stage1' by default. You can change this in "UserSettings". @@ -136,6 +139,7 @@ stage1Packages = do libraries0 <- filter good_stage0_package <$> stage0Packages cross <- flag CrossCompiling winTarget <- isWinTarget + haveCurses <- any (/= "") <$> traverse setting [ CursesIncludeDir, CursesLibDir ] let when c xs = if c then xs else mempty @@ -185,6 +189,10 @@ stage1Packages = do [ -- See Note [Hadrian's ghci-wrapper package] ghciWrapper ] + , when (cross && haveCurses) + [ + terminfo + ] ] -- | Packages built in 'Stage2' by default. You can change this in "UserSettings". ===================================== rts/posix/OSMem.c ===================================== @@ -585,8 +585,14 @@ void *osReserveHeapMemory(void *startAddressPtr, W_ *len) } #endif + const int MAX_ATTEMPTS = 256; + void *bad_allocs[MAX_ATTEMPTS]; + size_t bad_alloc_lens[MAX_ATTEMPTS]; + memset(bad_allocs, 0, sizeof(void*) * MAX_ATTEMPTS); + memset(bad_alloc_lens, 0, sizeof(size_t) * MAX_ATTEMPTS); + attempt = 0; - while (1) { + while (attempt < MAX_ATTEMPTS) { *len &= ~MBLOCK_MASK; if (*len < MBLOCK_SIZE) { @@ -611,18 +617,35 @@ void *osReserveHeapMemory(void *startAddressPtr, W_ *len) } else if ((W_)at >= minimumAddress) { // Success! We were given a block of memory starting above the 8 GB // mark, which is what we were looking for. - break; } else { // We got addressing space but it wasn't above the 8GB mark. - // Try again. - if (munmap(at, *len) < 0) { - sysErrorBelch("unable to release reserved heap"); + // Free any portion *above* 8GB and hang on to the rest to increase + // the likelihood that we get a suitable allocation next iteration. + uintptr_t end = (W_) at + *len; + bad_allocs[attempt] = at; + if (end > minimumAddress) { + if (munmap((void *) minimumAddress, end - minimumAddress) < 0) { + sysErrorBelch("unable to release high portion of low memory reservation"); + } + bad_alloc_lens[attempt] = minimumAddress - (W_) at; + } else { + bad_alloc_lens[attempt] = *len; } } attempt++; } + for (int i=0; i < MAX_ATTEMPTS; i++) { + if (bad_allocs[i] != NULL && munmap(bad_allocs[i], bad_alloc_lens[i]) < 0) { + sysErrorBelch("unable to release reserved heap"); + } + } + + if (at == NULL) { + sysErrorBelch("failed to reserve heap memory"); + } + return at; } ===================================== testsuite/tests/llvm/should_run/all.T ===================================== @@ -14,7 +14,7 @@ def ignore_llvm_and_vortex( msg ): test('T25770', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['']) test('T22487', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['']) -test('T22033', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['']) +test('T22033', [normal, unless(wordsize(64), skip), normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['']) test('T25730', [req_c, unless(arch('x86_64'), skip), normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['T25730C.c']) # T25730C.c contains Intel instrinsics, so only run this test on x86 test('T20645', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex), when(have_llvm(), extra_ways(["optllvm"]))], compile_and_run, ['']) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs ===================================== @@ -22,7 +22,7 @@ data MergeObjs = MergeObjs { mergeObjsProgram :: Program findMergeObjs :: ProgOpt -> Cc -> CcLink -> Nm -> M MergeObjs findMergeObjs progOpt cc ccLink nm = checking "for linker for merging objects" $ do - prog <- findProgram "linker for merging objects" progOpt ["ld.gold", "ld"] + prog <- findProgram "linker for merging objects" progOpt ["ld"] let mo = prog & _prgFlags %++ "-r" checkMergingWorks cc nm mo checkForGoldT22266 cc ccLink mo View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4c29333b7ce6e90b7849764c0546b8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4c29333b7ce6e90b7849764c0546b8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Improve how we detect user type errors in types
by Marge Bot (＠marge-bot) 07 Oct '25

07 Oct '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 7471eb6a by sheaf at 2025-10-07T21:39:43-04:00 Improve how we detect user type errors in types This commit cleans up all the code responsible for detecting whether a type contains "TypeError msg" applications nested inside it. All the logic is now in 'userTypeError_maybe', which is always deep. Whether it looks inside type family applications is determined by the passed-in boolean flag: - When deciding whether a constraint is definitely insoluble, don't look inside type family applications, as they may still reduce -- in which case the TypeError could disappear. - When reporting unsolved constraints, look inside type family applications: they had the chance to reduce but didn't, and the custom type error might contain valuable information. All the details are explained in Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint. Another benefit of this change is that it allows us to get rid of the deeply dodgy 'getUserTypeErrorMsg' function. This commit also improves the detection of custom type errors, for example in equality constraints: TypeError blah ~# rhs It used to be the case that we didn't detect the TypeError on the LHS, because we never considered that equality constraints could be insoluble due to the presence of custom type errors. Addressing this oversight improves detection of redundant pattern match warnings, fixing #26400. - - - - - 29955267 by Rodrigo Mesquita at 2025-10-07T21:40:25-04:00 cleanup: Drop obsolete settings from config.mk.in These values used to be spliced into the bindist's `config.mk` s.t. when `make` was run, the values were read and written into the bindist installation `settings` file. However, we now carry these values to the bindist directly in the default.target toolchain file, and `make` writes almost nothing to `settings` now (see #26227) The entries deleted in this MR were already unused. Fixes #26478 - - - - - 254b7315 by ARATA Mizuki at 2025-10-07T22:13:38-04:00 T22033 is only relevant if the word size is 64-bit Fixes #25497 - - - - - cb811a89 by Ben Gamari at 2025-10-07T22:13:41-04:00 rts/posix: Enforce iteration limit on heap reservation logic Previously we could loop indefinitely when attempting to get an address space reservation for our heap. Limit the logic to 8 iterations to ensure we instead issue a reasonable error message. Addresses #26151. - - - - - 54182de6 by Ben Gamari at 2025-10-07T22:13:41-04:00 rts/posix: Hold on to low reservations when reserving heap Previously when the OS gave us an address space reservation in low memory we would immediately release it and try again. However, on some platforms this meant that we would get the same allocation again in the next iteration (since mmap's `hint` argument is just that, a hint). Instead we now hold on to low reservations until we have found a suitable heap reservation. Fixes #26151. - - - - - 61d3835d by Sven Tennie at 2025-10-07T22:13:42-04:00 Build terminfo only in upper stages in cross-builds (#26288) Currently, there's no way to provide library paths for [n]curses for both - build and target - in cross-builds. As stage0 is only used to build upper stages, it should be fine to build terminfo only for them. This re-enables building cross-compilers with terminfo. - - - - - 4c29333b by Julian Ospald at 2025-10-07T22:13:52-04:00 ghc-toolchain: Drop `ld.gold` from merge object command It's deprecated. Also see #25716 - - - - - 21 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Validity.hs - hadrian/bindist/config.mk.in - hadrian/src/Settings/Default.hs - rts/posix/OSMem.c - testsuite/tests/llvm/should_run/all.T - + testsuite/tests/pmcheck/should_compile/T26400.hs - + testsuite/tests/pmcheck/should_compile/T26400.stderr - + testsuite/tests/pmcheck/should_compile/T26400b.hs - testsuite/tests/pmcheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/T20241b.stderr - testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr - utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -489,7 +489,6 @@ alpineVariables arch = mconcat $ [ mconcat [ brokenTest test "#25498" | test <- ["simd009", "T25169"] ] | I386 <- [arch] ] ++ - [ brokenTest "T22033" "#25497" | I386 <- [arch] ] ++ [ -- Bootstrap compiler has incorrectly configured target triple #25200 "CONFIGURE_ARGS" =: "--enable-ignore-build-platform-mismatch --build=aarch64-unknown-linux --host=aarch64-unknown-linux --target=aarch64-unknown-linux" | AArch64 <- [arch] ===================================== .gitlab/jobs.yaml ===================================== @@ -532,7 +532,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-i386-linux-alpine3_22-validate", - "BROKEN_TESTS": "encoding004 T10458 simd009 T25169 T22033", + "BROKEN_TESTS": "encoding004 T10458 simd009 T25169", "BUILD_FLAVOUR": "validate", "CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check", @@ -1203,7 +1203,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-i386-linux-alpine3_22-validate", - "BROKEN_TESTS": "encoding004 T10458 simd009 T25169 T22033", + "BROKEN_TESTS": "encoding004 T10458 simd009 T25169", "BUILD_FLAVOUR": "validate", "CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check", "INSTALL_CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check", @@ -4017,7 +4017,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-i386-linux-alpine3_22-release+no_split_sections", - "BROKEN_TESTS": "encoding004 T10458 simd009 T25169 T22033", + "BROKEN_TESTS": "encoding004 T10458 simd009 T25169", "BUILD_FLAVOUR": "release+no_split_sections", "CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check", "IGNORE_PERF_FAILURES": "all", ===================================== compiler/GHC/Core/Predicate.hs ===================================== @@ -217,7 +217,7 @@ in GHC.Tc.Solver.Dict. -- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep" isEqPred :: PredType -> Bool -- True of (s ~# t) (s ~R# t) --- NB: but NOT true of (s ~ t) or (s ~~ t) or (Coecible s t) +-- NB: but NOT true of (s ~ t) or (s ~~ t) or (Coercible s t) isEqPred ty | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -74,8 +74,7 @@ module GHC.Core.Type ( mkCastTy, mkCoercionTy, splitCastTy_maybe, - ErrorMsgType, - userTypeError_maybe, deepUserTypeError_maybe, pprUserTypeErrorTy, + ErrorMsgType, pprUserTypeErrorTy, coAxNthLHS, stripCoercionTy, @@ -272,7 +271,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString -import GHC.Data.Maybe ( orElse, isJust, firstJust ) +import GHC.Data.Maybe ( orElse, isJust ) import GHC.List (build) -- $type_classification @@ -1223,45 +1222,6 @@ isLitTy ty -- | A type of kind 'ErrorMessage' (from the 'GHC.TypeError' module). type ErrorMsgType = Type --- | Is this type a custom user error? --- If so, give us the error message. -userTypeError_maybe :: Type -> Maybe ErrorMsgType -userTypeError_maybe ty - | Just ty' <- coreView ty = userTypeError_maybe ty' -userTypeError_maybe (TyConApp tc (_kind : msg : _)) - | tyConName tc == errorMessageTypeErrorFamName - -- There may be more than 2 arguments, if the type error is - -- used as a type constructor (e.g. at kind `Type -> Type`). - = Just msg -userTypeError_maybe _ - = Nothing - -deepUserTypeError_maybe :: Type -> Maybe ErrorMsgType --- Look for custom user error, deeply inside the type -deepUserTypeError_maybe ty - | Just ty' <- coreView ty = userTypeError_maybe ty' -deepUserTypeError_maybe (TyConApp tc tys) - | tyConName tc == errorMessageTypeErrorFamName - , _kind : msg : _ <- tys - -- There may be more than 2 arguments, if the type error is - -- used as a type constructor (e.g. at kind `Type -> Type`). - = Just msg - - | tyConMustBeSaturated tc -- Don't go looking for user type errors - -- inside type family arguments (see #20241). - = foldr (firstJust . deepUserTypeError_maybe) Nothing (drop (tyConArity tc) tys) - | otherwise - = foldr (firstJust . deepUserTypeError_maybe) Nothing tys -deepUserTypeError_maybe (ForAllTy _ ty) = deepUserTypeError_maybe ty -deepUserTypeError_maybe (FunTy { ft_arg = arg, ft_res = res }) - = deepUserTypeError_maybe arg `firstJust` deepUserTypeError_maybe res -deepUserTypeError_maybe (AppTy t1 t2) - = deepUserTypeError_maybe t1 `firstJust` deepUserTypeError_maybe t2 -deepUserTypeError_maybe (CastTy ty _) - = deepUserTypeError_maybe ty -deepUserTypeError_maybe _ -- TyVarTy, CoercionTy, LitTy - = Nothing - -- | Render a type corresponding to a user type error into a SDoc. pprUserTypeErrorTy :: ErrorMsgType -> SDoc pprUserTypeErrorTy ty = ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -671,11 +671,14 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics non_tv_eq _ _ = False -- Catch TypeError and Unsatisfiable. - -- Here, we want any nested TypeErrors to bubble up, so we use - -- 'containsUserTypeError' and not 'isTopLevelUserTypeError'. + -- Here, we want any nested TypeErrors to bubble up, even if they are + -- inside type family applications, so we pass 'True' to + -- 'containsUserTypeError'. -- -- See also Note [Implementation of Unsatisfiable constraints], point (F). - is_user_type_error item _ = containsUserTypeError (errorItemPred item) + is_user_type_error item _ = containsUserTypeError True (errorItemPred item) + -- True <=> look under ty-fam apps, AppTy etc. + -- See (UTE2) in Note [Custom type errors in constraints]. is_implicit_lifting item _ = case (errorItemOrigin item) of @@ -977,6 +980,8 @@ Its implementation consists of the following: This is the only way that "Unsatisfiable msg" constraints are reported, which makes their behaviour much more predictable than TypeError. + We don't go looking for Unsatisfiable constraints deeply nested inside + a type like we do for TypeError. -} @@ -1124,12 +1129,21 @@ mkUserTypeErrorReporter ctxt ; maybeReportError ctxt (item :| []) err ; addSolverDeferredBinding err item } + + mkUserTypeError :: ErrorItem -> TcSolverReportMsg mkUserTypeError item - | Just msg <- getUserTypeErrorMsg pty - = UserTypeError msg | Just msg <- isUnsatisfiableCt_maybe pty = UnsatisfiableError msg + | Just msg <- userTypeError_maybe True pty + -- ^^^^ + -- Look under type-family applications! We are reporting an error, + -- so we may as well look to see if there are any custom type errors + -- anywhere, as they might be helpful to the user. We gave the type + -- family application the chance to reduce, but it didn't. + -- + -- See (UTE2) in Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint. + = UserTypeError msg | otherwise = pprPanic "mkUserTypeError" (ppr item) where ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -659,20 +659,70 @@ equality constraint, but it is also important to detect custom type errors: To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble because it is a custom type error. -Failing to do so proved quite inconvenient for users, as evidence by the +Failing to do so proved quite inconvenient for users, as evidenced by the tickets #11503 #14141 #16377 #20180. Test cases: T11503, T14141. -Examples of constraints that tcCheckGivens considers insoluble: +To do this, tcCheckGivens calls getInertInsols, which returns all Given +constraints that are definitely insoluble. See Note [When is a constraint insoluble?]. + +Note [When is a constraint insoluble?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whether a constraint is insoluble matters for accurate pattern-match +warnings, as explained in Note [Pattern match warnings with insoluble Givens]. + +We consider a constraint to be insoluble if it definitely cannot be solved, +no matter what information we might further discover. For example, the following +constraints are insoluble: + - Int ~ Bool, - Coercible Float Word, - - TypeError msg. - -Non-examples: - - constraints which we know aren't satisfied, - e.g. Show (Int -> Int) when no such instance is in scope, - - Eq (TypeError msg), - - C (Int ~ Bool), with @class C (c :: Constraint)@. + - TypeError msg + - TypeError msg ~ Int + - Unsatisfiable msg + +Many constraints that look like they can't be solved are in fact not reported +as insoluble, as there might still be a possibility (no matter how remote) that +they can still be solved: + + 1: Show (Int -> Int) + + Reason: even though there is no relevant instance in scope, this constraint + could later get solved by a new instance. + + 2: C (Int ~ Bool), where C :: Constraint -> Constraint + + Reason: even though 'Int ~ Bool' is insoluble, the constraint 'C (Int ~ Bool)' + might be soluble, e.g. if 'C' is a class and we have 'instance forall c. C c', + or 'C' is a type family and we have 'type instance C c = (() :: Constraint)'. + + 3: Nested occurences of TypeError don't always lead to insolubility. For + example, none of the following constraints are definitely insoluble: + + (a) F alpha (TypeError msg) -- 'F' is an arity 2 type family + (b) Eq (TypeError msg) + (c) c (TypeError msg) -- 'c' is a metavariable + (d) (TC alpha) (TypeError msg) -- 'TC' is an arity 1 type family + (e) TypeError msg ~ rhs -- (depends on rhs) + + None of these constraints are definitely insoluble: + + (a) Can be solved if 'F' reduces, e.g. 'alpha := Int', 'type instance F Int a = (() :: Constraint)'. + (b) Can be solved by 'instance forall x. Eq x'. + (c) Can be solved if 'c' unifies with 'C', as in example (2). + (d) Can be solved if 'TC alpha' reduces to 'C', as in example (2). + (e) If 'rhs' is a rigid type such as 'Int' or 'Maybe Char', then this + constraint is definitely insoluble. Otherwise, however, the constraint + could be soluble: + - rhs = G alpha, for an arity 1 type family G + G alpha could reduce to TypeError msg. + - rhs = k, for a skolem type variable k. + We could instantiate k to something else, and then the constraint + could become soluble. + + For this reason, we are careful to not pull out certain occurrences of TypeError, + e.g. inside type family applications and class constraints. + See Note [Custom type errors in constraints]. -} tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -172,7 +172,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Constraint -import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName ) +import GHC.Builtin.Names ( callStackTyConName, exceptionContextTyConName ) import GHC.Core.Type import GHC.Core.TyCo.Rep as Rep @@ -185,6 +185,10 @@ import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Unify (typesAreApart) +import GHC.LanguageExtensions as LangExt +import GHC.Rename.Env +import qualified GHC.Rename.Env as TcM + import GHC.Types.Name import GHC.Types.TyThing import GHC.Types.Name.Reader @@ -199,8 +203,7 @@ import GHC.Types.ThLevelIndex (thLevelIndexFromImportLevel) import GHC.Types.SrcLoc import GHC.Unit.Module -import qualified GHC.Rename.Env as TcM -import GHC.Rename.Env +import GHC.Unit.Module.Graph import GHC.Utils.Outputable import GHC.Utils.Panic @@ -220,15 +223,13 @@ import Data.List ( mapAccumL ) import Data.List.NonEmpty ( nonEmpty ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as S -import GHC.LanguageExtensions as LangExt +import qualified Data.Set as Set #if defined(DEBUG) import GHC.Types.Unique.Set (nonDetEltsUniqSet) import GHC.Data.Graph.Directed #endif -import qualified Data.Set as Set -import GHC.Unit.Module.Graph {- ********************************************************************* * * @@ -666,9 +667,10 @@ getInnermostGivenEqLevel = do { inert <- getInertCans -- This consists of: -- -- - insoluble equalities, such as @Int ~# Bool@; --- - constraints that are top-level custom type errors, of the form --- @TypeError msg@, but not constraints such as @Eq (TypeError msg)@ --- in which the type error is nested; +-- - constraints that are custom type errors, of the form +-- @TypeError msg@ or @Maybe (TypeError msg)@, but not constraints such as +-- @F x (TypeError msg)@ in which the type error is nested under +-- a type family application, -- - unsatisfiable constraints, of the form @Unsatisfiable msg@. -- -- The inclusion of Givens is important for pattern match warnings, as we @@ -676,21 +678,26 @@ getInnermostGivenEqLevel = do { inert <- getInertCans -- redundant (see Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver). getInertInsols :: TcS Cts getInertInsols - = do { inert <- getInertCans - ; let insols = filterBag insolubleIrredCt (inert_irreds inert) - unsats = findDictsByTyConKey (inert_dicts inert) unsatisfiableClassNameKey - ; return $ fmap CDictCan unsats `unionBags` fmap CIrredCan insols } + -- See Note [When is a constraint insoluble?] + = do { inert_cts <- getInertCts + ; return $ filterBag insolubleCt inert_cts } + +getInertCts :: TcS Cts +getInertCts + = do { inerts <- getInertCans + ; return $ + unionManyBags + [ fmap CIrredCan $ inert_irreds inerts + , foldDicts (consBag . CDictCan) (inert_dicts inerts) emptyBag + , foldFunEqs (consBag . CEqCan ) (inert_funeqs inerts) emptyBag + , foldTyEqs (consBag . CEqCan ) (inert_eqs inerts) emptyBag + ] } getInertGivens :: TcS [Ct] -- Returns the Given constraints in the inert set getInertGivens - = do { inerts <- getInertCans - ; let all_cts = foldIrreds ((:) . CIrredCan) (inert_irreds inerts) - $ foldDicts ((:) . CDictCan) (inert_dicts inerts) - $ foldFunEqs ((:) . CEqCan) (inert_funeqs inerts) - $ foldTyEqs ((:) . CEqCan) (inert_eqs inerts) - $ [] - ; return (filter isGivenCt all_cts) } + = do { all_cts <- getInertCts + ; return (filter isGivenCt $ bagToList all_cts) } getPendingGivenScs :: TcS [Ct] -- Find all inert Given dictionaries, or quantified constraints, such that ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -471,7 +471,9 @@ findRedundantGivens (Implic { ic_info = info, ic_need = need, ic_given = givens | otherwise = filterOut is_minimal givens -- See #15232 - is_type_error id = isTopLevelUserTypeError (idType id) + is_type_error id = containsUserTypeError False (idType id) + -- False <=> do not look under ty-fam apps, AppTy etc. + -- See (UTE1) in Note [Custom type errors in constraints]. is_improving pred -- (transSuperClasses p) does not include p = any isImprovementPred (pred : transSuperClasses pred) ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} -- | This module defines types and simple operations over constraints, as used @@ -13,7 +14,7 @@ module GHC.Tc.Types.Constraint ( isPendingScDictCt, isPendingScDict, pendingScDict_maybe, superClassesMightHelp, getPendingWantedScs, isWantedCt, isGivenCt, - isTopLevelUserTypeError, containsUserTypeError, getUserTypeErrorMsg, + userTypeError_maybe, containsUserTypeError, isUnsatisfiableCt_maybe, ctEvidence, updCtEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, @@ -59,7 +60,7 @@ module GHC.Tc.Types.Constraint ( addInsols, dropMisleading, addSimples, addImplics, addHoles, addNotConcreteError, addMultiplicityCoercionError, addDelayedErrors, tyCoVarsOfWC, tyCoVarsOfWCList, - insolubleWantedCt, insolubleCt, insolubleIrredCt, + insolubleWantedCt, insolubleCt, insolubleImplic, nonDefaultableTyVarsOfWC, approximateWCX, approximateWC, @@ -113,6 +114,7 @@ import GHC.Core.Coercion import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Rep import GHC.Types.Name import GHC.Types.Var @@ -136,16 +138,13 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Data.Bag +import Control.Monad ( when ) import Data.Coerce -import qualified Data.Semigroup as S -import Control.Monad ( msum, when ) +import Data.List ( intersperse ) import Data.Maybe ( mapMaybe, isJust ) - --- these are for CheckTyEqResult +import GHC.Data.Maybe ( firstJust, firstJusts ) +import qualified Data.Semigroup as S import Data.Word ( Word8 ) -import Data.List ( intersperse ) - - {- ************************************************************************ @@ -1198,73 +1197,53 @@ insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors }) is_insoluble (DE_Multiplicity {}) = False insolubleWantedCt :: Ct -> Bool --- Definitely insoluble, in particular /excluding/ type-hole constraints --- Namely: --- a) an insoluble constraint as per 'insolubleIrredCt', i.e. either --- - an insoluble equality constraint (e.g. Int ~ Bool), or --- - a custom type error constraint, TypeError msg :: Constraint --- b) that does not arise from a Given or a Wanted/Wanted fundep interaction +-- | Is this a definitely insoluble Wanted constraint? Namely: +-- +-- - a Wanted, +-- - which is insoluble (as per 'insolubleCt'), +-- - that does not arise from a Given or a Wanted/Wanted fundep interaction. +-- -- See Note [Insoluble Wanteds] insolubleWantedCt ct - | CIrredCan ir_ct <- ct - -- CIrredCan: see (IW1) in Note [Insoluble Wanteds] - , IrredCt { ir_ev = ev } <- ir_ct - , CtWanted (WantedCt { ctev_loc = loc, ctev_rewriters = rewriters }) <- ev + | CtWanted (WantedCt { ctev_loc = loc, ctev_rewriters = rewriters }) + <- ctEvidence ct -- It's a Wanted - , insolubleIrredCt ir_ct + , insolubleCt ct -- It's insoluble , isEmptyRewriterSet rewriters - -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds] + -- It has no rewriters – see (IW1) in Note [Insoluble Wanteds] , not (isGivenLoc loc) - -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds] + -- It doesn't arise from a Given – see (IW2) in Note [Insoluble Wanteds] , not (isWantedWantedFunDepOrigin (ctLocOrigin loc)) - -- origin check: see (IW4) in Note [Insoluble Wanteds] + -- It doesn't arise from a W/W fundep interaction – see (IW3) in Note [Insoluble Wanteds] = True | otherwise = False --- | Returns True of constraints that are definitely insoluble, --- as well as TypeError constraints. --- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. +-- | Returns True of constraints that are definitely insoluble, including +-- constraints that include custom type errors, as per (1) +-- in Note [Custom type errors in constraints]. -- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- That's why it looks only for IrredCt; all insoluble constraints --- are put into CIrredCan +-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. insolubleCt :: Ct -> Bool -insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct -insolubleCt _ = False - -insolubleIrredCt :: IrredCt -> Bool --- Returns True of Irred constraints that are /definitely/ insoluble --- --- This function is critical for accurate pattern-match overlap warnings. --- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver --- --- Note that this does not traverse through the constraint to find --- nested custom type errors: it only detects @TypeError msg :: Constraint@, --- and not e.g. @Eq (TypeError msg)@. -insolubleIrredCt (IrredCt { ir_ev = ev, ir_reason = reason }) - = isInsolubleReason reason - || isTopLevelUserTypeError (ctEvPred ev) - -- NB: 'isTopLevelUserTypeError' detects constraints of the form "TypeError msg" - -- and "Unsatisfiable msg". It deliberately does not detect TypeError - -- nested in a type (e.g. it does not use "containsUserTypeError"), as that - -- would be too eager: the TypeError might appear inside a type family - -- application which might later reduce, but we only want to return 'True' - -- for constraints that are definitely insoluble. - -- - -- For example: Num (F Int (TypeError "msg")), where F is a type family. - -- - -- Test case: T11503, with the 'Assert' type family: - -- - -- > type Assert :: Bool -> Constraint -> Constraint - -- > type family Assert check errMsg where - -- > Assert 'True _errMsg = () - -- > Assert _check errMsg = errMsg +insolubleCt ct + | CIrredCan (IrredCt { ir_reason = reason }) <- ct + , isInsolubleReason reason + = True + | isJust $ isUnsatisfiableCt_maybe pred + = True + | containsUserTypeError False pred + -- False <=> do not look under ty-fam apps, AppTy etc. + -- See (UTE1) in Note [Custom type errors in constraints]. + = True + | otherwise + = False + where + pred = ctPred ct -- | Does this hole represent an "out of scope" error? +-- -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore (occName occ)) @@ -1312,12 +1291,7 @@ Note [Insoluble Wanteds] insolubleWantedCt returns True of a Wanted constraint that definitely can't be solved. But not quite all such constraints; see wrinkles. -(IW1) insolubleWantedCt is tuned for application /after/ constraint - solving i.e. assuming canonicalisation has been done. That's why - it looks only for IrredCt; all insoluble constraints are put into - CIrredCan - -(IW2) We only treat it as insoluble if it has an empty rewriter set. (See Note +(IW1) We only treat it as insoluble if it has an empty rewriter set. (See Note [Wanteds rewrite Wanteds].) Otherwise #25325 happens: a Wanted constraint A that is /not/ insoluble rewrites some other Wanted constraint B, so B has A in its rewriter set. Now B looks insoluble. The danger is that we'll @@ -1325,10 +1299,10 @@ can't be solved. But not quite all such constraints; see wrinkles. reporting A because there is an insoluble B lying around. (This suppression happens in GHC.Tc.Errors.mkErrorItem.) Solution: don't treat B as insoluble. -(IW3) If the Wanted arises from a Given (how can that happen?), don't +(IW2) If the Wanted arises from a Given (how can that happen?), don't treat it as a Wanted insoluble (obviously). -(IW4) If the Wanted came from a Wanted/Wanted fundep interaction, don't +(IW3) If the Wanted came from a Wanted/Wanted fundep interaction, don't treat the constraint as insoluble. See Note [Suppressing confusing errors] in GHC.Tc.Errors @@ -1354,71 +1328,165 @@ Yuk! {- Note [Custom type errors in constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When GHC reports a type-error about an unsolved-constraint, we check -to see if the constraint contains any custom-type errors, and if so -we report them. Here are some examples of constraints containing type -errors: - - TypeError msg -- The actual constraint is a type error - - TypError msg ~ Int -- Some type was supposed to be Int, but ended up - -- being a type error instead - - Eq (TypeError msg) -- A class constraint is stuck due to a type error - - F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err - -It is also possible to have constraints where the type error is nested deeper, -for example see #11990, and also: - - Eq (F (TypeError msg)) -- Here the type error is nested under a type-function - -- call, which failed to evaluate because of it, - -- and so the `Eq` constraint was unsolved. - -- This may happen when one function calls another - -- and the called function produced a custom type error. - -A good use-case is described in "Detecting the undetectable" - https://blog.csongor.co.uk/report-stuck-families/ -which features - type family Assert (err :: Constraint) (break :: Type -> Type) (a :: k) :: k where - Assert _ Dummy _ = Any - Assert _ _ k = k -and an unsolved constraint like - Assert (TypeError ...) (F ty1) ty1 ~ ty2 -that reports that (F ty1) remains stuck. +A custom type error is a type family application 'TypeError msg' where +'msg :: ErrorMessage', or an Unsatisfiable constraint. +See Note [Custom type errors] and Note [The Unsatisfiable constraint] +in GHC.Internal.TypeError. + +There are two ways in which the presence of such custom type errors inside a +type impact GHC's behaviour: + + (UTE1) + Constraints that contain a custom type error are considered to be + insoluble. This affects pattern-match warnings, as explained in + Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver. + + This includes examples such as: + + TypeError msg -- The actual constraint is a type error + + TypeError msg ~# Int -- Some type was supposed to be Int, but ended up + -- being a type error instead + + However, we must be careful about occurrences of custom type errors + nested inside the constraint, as they may not make the constraint + insoluble. This is explained in Note [When is a constraint insoluble?] + in GHC.Tc.Solver. In particular: + + a. Do not look inside type family applications. + b. Do not look inside class constraints. + c. Do not look inside AppTy or in arguments of a type family past its arity. + d. Only consider 'TypeError msg ~ rhs' to be insoluble if rhs definitely + cannot unify with 'TypeError msg', e.g. if 'rhs = Int' the constraint + is insoluble, but if 'rhs = k[sk]' then it isn't. + + These subtle cases are tested in T26400b. + + A good use-case for type errors nested under type family applications is + described in "Detecting the undetectable" (https://blog.csongor.co.uk/report-stuck-families/) + which features: + type family Assert (err :: Constraint) (break :: Type -> Type) (a :: k) :: k where + Assert _ Dummy _ = Any + Assert _ _ k = k + and an unsolved constraint like 'Assert (TypeError ...) (F ty1) ty1 ~ ty2' + which reports when (F ty1) remains stuck. + + (UTE2) + When reporting unsolved constraints, we pull out any custom type errors + and report the corresponding message to the user. + + Unlike in (UTE1), we do want to pull out 'TypeError' wherever it occurs + inside the type, including inside type-family applications. We tried to + solve the constraint, reduce type families etc, but the constraint + remained unsolved all the way till the end. Now that we are reporting the + error, it makes sense to pull out the 'TypeError' and report the custom + error message to the user, as the intention is that this message might + be informative. + + Examples: + + Num (TypeError msg) -- A class constraint is stuck due to a type error + + F (TypeError msg) ~ a -- A type function failed to evaluate due to a type error + + Eq (F (TypeError msg)) -- Here the type error is nested under a type-function + -- call, which failed to evaluate because of it, + -- and so the `Eq` constraint was unsolved. + -- This may happen when one function calls another + -- and the called function produced a custom type error. + +We use a single function, 'userTypeError_maybe', to pull out TypeError according +to the rules of either (UTE1) or (UTE2), depending on the passed in boolean +flag to 'userTypeError_maybe': 'False' for (UTE1) and 'True' for (UTE2). -} --- | A constraint is considered to be a custom type error, if it contains --- custom type errors anywhere in it. --- See Note [Custom type errors in constraints] -getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType -getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred - : map getUserTypeErrorMsg (subTys pred) +-- | Does this type contain 'TypeError msg', either at the top-level or +-- nested within it somewhere? +-- +-- If so, return the error message. +-- +-- See Note [Custom type errors in constraints]. +userTypeError_maybe + :: Bool -- ^ Look everywhere: inside type-family applications, class constraints, AppTys etc? + -> Type + -> Maybe ErrorMsgType +userTypeError_maybe look_everywhere = go where - -- Richard thinks this function is very broken. What is subTys - -- supposed to be doing? Why are exactly-saturated tyconapps special? - -- What stops this from accidentally ripping apart a call to TypeError? - subTys t = case splitAppTys t of - (t,[]) -> - case splitTyConApp_maybe t of - Nothing -> [] - Just (_,ts) -> ts - (t,ts) -> t : ts - --- | Is this an user error message type, i.e. either the form @TypeError err@ or --- @Unsatisfiable err@? -isTopLevelUserTypeError :: PredType -> Bool -isTopLevelUserTypeError pred = - isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred) + go ty + | Just ty' <- coreView ty + = go ty' + go (TyConApp tc tys) + | tyConName tc == errorMessageTypeErrorFamName + , _kind : msg : _ <- tys + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + = Just msg + + -- (UTE1.d) TypeError msg ~ a is only insoluble if 'a' cannot be a type error + | not look_everywhere + , tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + , [ ki1, ki2, ty1, ty2 ] <- tys + = if | Just msg <- go ki1 + , isRigidTy ki2 + -> Just msg + | Just msg <- go ki2 + , isRigidTy ki1 + -> Just msg + | Just msg <- go ty1 + , isRigidTy ty2 + -> Just msg + | Just msg <- go ty2 + , isRigidTy ty1 + -> Just msg + | otherwise + -> Nothing + + -- (UTE1.a) Don't look under type family applications. + | tyConMustBeSaturated tc + , not look_everywhere + = Nothing + -- (UTE1.c) Don't even look in the arguments past the arity of the TyCon. + + -- (UTE1.b) Don't look inside class constraints. + | isClassTyCon tc + , not look_everywhere + = foldr (firstJust . go) Nothing (drop (tyConArity tc) tys) + | otherwise + = foldr (firstJust . go) Nothing tys + go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `firstJust` go ty + go (FunTy { ft_mult = mult, ft_arg = arg, ft_res = res }) + = firstJusts + [ go mult + , go (typeKind arg) + , go (typeKind res) + , go arg + , go res ] + go (AppTy t1 t2) + -- (UTE1.c) Don't look inside AppTy. + | not look_everywhere + = Nothing + | otherwise + = go t1 `firstJust` go t2 + go (CastTy ty _co) = go ty + go (TyVarTy tv) = go (tyVarKind tv) + go (CoercionTy {}) = Nothing + go (LitTy {}) = Nothing -- | Does this constraint contain an user error message? -- -- That is, the type is either of the form @Unsatisfiable err@, or it contains -- a type of the form @TypeError msg@, either at the top level or nested inside -- the type. -containsUserTypeError :: PredType -> Bool -containsUserTypeError pred = - isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred) +-- +-- See Note [Custom type errors in constraints]. +containsUserTypeError + :: Bool -- ^ look inside type-family applications, 'AppTy', etc? + -> PredType + -> Bool +containsUserTypeError look_in_famapps pred = + isJust (isUnsatisfiableCt_maybe pred) + || + isJust (userTypeError_maybe look_in_famapps pred) -- | Is this type an unsatisfiable constraint? -- If so, return the error message. ===================================== compiler/GHC/Tc/Validity.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin import GHC.Tc.Types.Rank import GHC.Tc.Errors.Types +import GHC.Tc.Types.Constraint ( userTypeError_maybe ) import GHC.Tc.Utils.Env (tcLookupId) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad @@ -282,7 +283,12 @@ checkUserTypeError ctxt ty | TySynCtxt {} <- ctxt -- Do not complain about TypeError on the = return () -- RHS of type synonyms. See #20181 - | Just msg <- deepUserTypeError_maybe ty + | Just msg <- userTypeError_maybe False ty + -- ^^^^^ + -- Don't look under type-family applications! We only want to pull out + -- definite errors. + -- + -- See (UTE1) in Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint. = do { env0 <- liftZonkM tcInitTidyEnv ; let (env1, tidy_msg) = tidyOpenTypeX env0 msg ; failWithTcM (env1, TcRnUserTypeError tidy_msg) } ===================================== hadrian/bindist/config.mk.in ===================================== @@ -174,34 +174,3 @@ UseLibffiForAdjustors=@UseLibffiForAdjustors@ # rts/Libdw.c:set_initial_registers() UseLibdw=$(strip $(if $(filter $(TargetArch_CPP),i386 x86_64 s390x),@UseLibdw@,NO)) -#----------------------------------------------------------------------------- -# Settings - -# We are in the process of moving the settings file from being entirely -# generated by configure, to generated being by the build system. Many of these -# might become redundant. -# See Note [tooldir: How GHC finds mingw on Windows] - -LdHasFilelist = @LdHasFilelist@ -MergeObjsSupportsResponseFiles = @MergeObjsSupportsResponseFiles@ -LdHasBuildId = @LdHasBuildId@ -LdHasFilelist = @LdHasFilelist@ -LdIsGNULd = @LdIsGNULd@ -LdHasNoCompactUnwind = @LdHasNoCompactUnwind@ -LdHasSingleModule = @LdHasSingleModule@ -ArArgs = @ArArgs@ -ArSupportsAtFile = @ArSupportsAtFile@ -ArSupportsDashL = @ArSupportsDashL@ -HaskellHostOs = @HaskellHostOs@ -HaskellHostArch = @HaskellHostArch@ -HaskellTargetOs = @HaskellTargetOs@ -HaskellTargetArch = @HaskellTargetArch@ -TargetWordSize = @TargetWordSize@ -TargetWordBigEndian = @TargetWordBigEndian@ -TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ -TargetHasIdentDirective = @TargetHasIdentDirective@ -TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ -TargetHasLibm = @TargetHasLibm@ -TablesNextToCode = @TablesNextToCode@ -LeadingUnderscore = @LeadingUnderscore@ -LlvmTarget = @LlvmTarget@ ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -80,7 +80,6 @@ stageBootPackages = return stage0Packages :: Action [Package] stage0Packages = do cross <- flag CrossCompiling - haveCurses <- any (/= "") <$> traverse setting [ CursesIncludeDir, CursesLibDir ] return $ [ cabalSyntax , cabal , compiler @@ -116,7 +115,11 @@ stage0Packages = do -- that confused Hadrian, so we must make those a stage0 package as well. -- Once we drop `Win32`/`unix` it should be possible to drop those too. ] - ++ [ terminfo | not windowsHost, (not cross || haveCurses) ] + -- Currently, we have no way to provide paths to [n]curses libs for + -- both - build and target - in cross builds. Thus, we only build it + -- for upper stages. As we only use stage0 to build upper stages, + -- this should be fine. + ++ [ terminfo | not windowsHost, not cross ] ++ [ timeout | windowsHost ] -- | Packages built in 'Stage1' by default. You can change this in "UserSettings". @@ -136,6 +139,7 @@ stage1Packages = do libraries0 <- filter good_stage0_package <$> stage0Packages cross <- flag CrossCompiling winTarget <- isWinTarget + haveCurses <- any (/= "") <$> traverse setting [ CursesIncludeDir, CursesLibDir ] let when c xs = if c then xs else mempty @@ -185,6 +189,10 @@ stage1Packages = do [ -- See Note [Hadrian's ghci-wrapper package] ghciWrapper ] + , when (cross && haveCurses) + [ + terminfo + ] ] -- | Packages built in 'Stage2' by default. You can change this in "UserSettings". ===================================== rts/posix/OSMem.c ===================================== @@ -585,8 +585,14 @@ void *osReserveHeapMemory(void *startAddressPtr, W_ *len) } #endif + const int MAX_ATTEMPTS = 256; + void *bad_allocs[MAX_ATTEMPTS]; + size_t bad_alloc_lens[MAX_ATTEMPTS]; + memset(bad_allocs, 0, sizeof(void*) * MAX_ATTEMPTS); + memset(bad_alloc_lens, 0, sizeof(size_t) * MAX_ATTEMPTS); + attempt = 0; - while (1) { + while (attempt < MAX_ATTEMPTS) { *len &= ~MBLOCK_MASK; if (*len < MBLOCK_SIZE) { @@ -611,18 +617,35 @@ void *osReserveHeapMemory(void *startAddressPtr, W_ *len) } else if ((W_)at >= minimumAddress) { // Success! We were given a block of memory starting above the 8 GB // mark, which is what we were looking for. - break; } else { // We got addressing space but it wasn't above the 8GB mark. - // Try again. - if (munmap(at, *len) < 0) { - sysErrorBelch("unable to release reserved heap"); + // Free any portion *above* 8GB and hang on to the rest to increase + // the likelihood that we get a suitable allocation next iteration. + uintptr_t end = (W_) at + *len; + bad_allocs[attempt] = at; + if (end > minimumAddress) { + if (munmap((void *) minimumAddress, end - minimumAddress) < 0) { + sysErrorBelch("unable to release high portion of low memory reservation"); + } + bad_alloc_lens[attempt] = minimumAddress - (W_) at; + } else { + bad_alloc_lens[attempt] = *len; } } attempt++; } + for (int i=0; i < MAX_ATTEMPTS; i++) { + if (bad_allocs[i] != NULL && munmap(bad_allocs[i], bad_alloc_lens[i]) < 0) { + sysErrorBelch("unable to release reserved heap"); + } + } + + if (at == NULL) { + sysErrorBelch("failed to reserve heap memory"); + } + return at; } ===================================== testsuite/tests/llvm/should_run/all.T ===================================== @@ -14,7 +14,7 @@ def ignore_llvm_and_vortex( msg ): test('T25770', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['']) test('T22487', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['']) -test('T22033', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['']) +test('T22033', [normal, unless(wordsize(64), skip), normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['']) test('T25730', [req_c, unless(arch('x86_64'), skip), normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['T25730C.c']) # T25730C.c contains Intel instrinsics, so only run this test on x86 test('T20645', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex), when(have_llvm(), extra_ways(["optllvm"]))], compile_and_run, ['']) ===================================== testsuite/tests/pmcheck/should_compile/T26400.hs ===================================== @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module T26400 where + +import GHC.Exts ( UnliftedType ) +import GHC.TypeLits ( TypeError, ErrorMessage(..) ) + +data N = Z | S N + +-- Make this type unlifted to avoid any subtleties about laziness +type SNat :: N -> UnliftedType +data SNat n where + SZ :: SNat Z + SS :: SNat n -> SNat (S n) + +type (-) :: N -> N -> N +type family a - b where + n - Z = n + Z - S _ = TypeError ( Text "impossible" ) + S n - S m = n - m + +testFn :: SNat n -> SNat m -> SNat (n - m) -> Int +testFn SZ (SS _) SZ = 666 +testFn SZ (SS _) (SS _) = 999 + -- [G] g1 :: n ~ Z + -- [G] g2 :: m ~ S m1 + -- [G] g3 :: (n-m) ~ S m2 + -- Use the first two givens to substitute in the third, we get: + -- [G] g3' :: Z - S m1 ~ S m2 + -- Reduce the LHS using the type family + -- [G] g3'' :: TypeError ... ~ S m2 + -- Hence g3'' is insoluble and the equation can never match +testFn _ _ _ = 1 ===================================== testsuite/tests/pmcheck/should_compile/T26400.stderr ===================================== @@ -0,0 +1,8 @@ +T26400.hs:27:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘testFn’: testFn SZ (SS _) SZ = ... + +T26400.hs:28:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘testFn’: testFn SZ (SS _) (SS _) = ... + ===================================== testsuite/tests/pmcheck/should_compile/T26400b.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module T26400b where + +import Data.Kind +import GHC.TypeLits ( TypeError, ErrorMessage(..) ) + +type F :: Type -> Type -> Type +type family F a b where + F Float _ = Bool + F _ a = a + +type C :: Type -> Type -> Constraint +class C a b +instance C () b + +type Boom :: Type -> Type +type family Boom a where + Boom () = TypeError (Text "boom") + +type TF :: Type -> ( Type -> Type -> Constraint ) +type family TF a where + TF () = C + +type G :: Type -> Type -> Type +data G a b where + G1 :: a -> F b (Boom a) -> G a b + G2 :: C a (Boom a) => a -> G a b + G3 :: (TF b) a (Boom a) => a -> G a b + G4 :: (b ~ Boom a) => G a b + +g :: G () b -> Int +g (G1 {}) = 1 -- not redundant: F b (TypeError ...) can be solved if F reduces +g (G2 {}) = 2 -- not redundant: C () (TypeError ...) is not insoluble +g (G3 {}) = 3 -- not redundant: TF b () (TypeError ...) could reduce to C () (TypeError ...) +g (G4 {}) = 4 -- not redundant: b ~ TypeError ... could be solved depending on instantiation of b ===================================== testsuite/tests/pmcheck/should_compile/all.T ===================================== @@ -123,6 +123,8 @@ test('T21761', [], compile, [overlapping_incomplete]) test('T22964', [], compile, [overlapping_incomplete]) test('T23445', [], compile, [overlapping_incomplete]) test('T24234', [], compile, [overlapping_incomplete+'-Wincomplete-uni-patterns']) +test('T26400', [], compile, [overlapping_incomplete]) +test('T26400b', [], compile, [overlapping_incomplete]) # Series (inspired) by Luke Maranget ===================================== testsuite/tests/typecheck/should_fail/T20241b.stderr ===================================== @@ -1,4 +1,3 @@ - T20241b.hs:16:8: error: [GHC-47403] • Boom • In the type signature: @@ -6,11 +5,14 @@ T20241b.hs:16:8: error: [GHC-47403] -> Type -> Constraint) IO) a => Proxy a -> () -T20241b.hs:20:8: error: [GHC-47403] +T20241b.hs:20:8: error: [GHC-64725] • Boom - • In the type signature: + • In the ambiguity check for ‘bar’ + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + In the type signature: bar :: ((c :: Constraint -> Type -> Constraint) (((TypeError (Text "Boom") :: (Type -> Type) -> Type -> Constraint) IO) a)) a => Proxy a -> () + ===================================== testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr ===================================== @@ -9,11 +9,11 @@ UnliftedNewtypesFamilyKindFail2.hs:12:20: error: [GHC-83865] • In the first argument of ‘F’, namely ‘5’ In the newtype family instance declaration for ‘F’ -UnliftedNewtypesFamilyKindFail2.hs:12:31: [GHC-83865] - Expected a type, +UnliftedNewtypesFamilyKindFail2.hs:12:31: error: [GHC-83865] + • Expected a type, but ‘5’ has kind ‘GHC.Internal.Bignum.Natural.Natural’ - In the first argument of ‘F’, namely ‘5’ + • In the first argument of ‘F’, namely ‘5’ In the type ‘(F 5)’ In the definition of data constructor ‘MkF’ ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs ===================================== @@ -22,7 +22,7 @@ data MergeObjs = MergeObjs { mergeObjsProgram :: Program findMergeObjs :: ProgOpt -> Cc -> CcLink -> Nm -> M MergeObjs findMergeObjs progOpt cc ccLink nm = checking "for linker for merging objects" $ do - prog <- findProgram "linker for merging objects" progOpt ["ld.gold", "ld"] + prog <- findProgram "linker for merging objects" progOpt ["ld"] let mo = prog & _prgFlags %++ "-r" checkMergingWorks cc nm mo checkForGoldT22266 cc ccLink mo View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/742ae2b4db5379e75e93ca2a042731… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/742ae2b4db5379e75e93ca2a042731… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] cleanup: Drop obsolete settings from config.mk.in
by Marge Bot (＠marge-bot) 07 Oct '25

07 Oct '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 29955267 by Rodrigo Mesquita at 2025-10-07T21:40:25-04:00 cleanup: Drop obsolete settings from config.mk.in These values used to be spliced into the bindist's `config.mk` s.t. when `make` was run, the values were read and written into the bindist installation `settings` file. However, we now carry these values to the bindist directly in the default.target toolchain file, and `make` writes almost nothing to `settings` now (see #26227) The entries deleted in this MR were already unused. Fixes #26478 - - - - - 1 changed file: - hadrian/bindist/config.mk.in Changes: ===================================== hadrian/bindist/config.mk.in ===================================== @@ -174,34 +174,3 @@ UseLibffiForAdjustors=@UseLibffiForAdjustors@ # rts/Libdw.c:set_initial_registers() UseLibdw=$(strip $(if $(filter $(TargetArch_CPP),i386 x86_64 s390x),@UseLibdw@,NO)) -#----------------------------------------------------------------------------- -# Settings - -# We are in the process of moving the settings file from being entirely -# generated by configure, to generated being by the build system. Many of these -# might become redundant. -# See Note [tooldir: How GHC finds mingw on Windows] - -LdHasFilelist = @LdHasFilelist@ -MergeObjsSupportsResponseFiles = @MergeObjsSupportsResponseFiles@ -LdHasBuildId = @LdHasBuildId@ -LdHasFilelist = @LdHasFilelist@ -LdIsGNULd = @LdIsGNULd@ -LdHasNoCompactUnwind = @LdHasNoCompactUnwind@ -LdHasSingleModule = @LdHasSingleModule@ -ArArgs = @ArArgs@ -ArSupportsAtFile = @ArSupportsAtFile@ -ArSupportsDashL = @ArSupportsDashL@ -HaskellHostOs = @HaskellHostOs@ -HaskellHostArch = @HaskellHostArch@ -HaskellTargetOs = @HaskellTargetOs@ -HaskellTargetArch = @HaskellTargetArch@ -TargetWordSize = @TargetWordSize@ -TargetWordBigEndian = @TargetWordBigEndian@ -TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ -TargetHasIdentDirective = @TargetHasIdentDirective@ -TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ -TargetHasLibm = @TargetHasLibm@ -TablesNextToCode = @TablesNextToCode@ -LeadingUnderscore = @LeadingUnderscore@ -LlvmTarget = @LlvmTarget@ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29955267c03e417b1e5f182e3f0d90f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29955267c03e417b1e5f182e3f0d90f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Improve how we detect user type errors in types
by Marge Bot (＠marge-bot) 07 Oct '25

07 Oct '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 7471eb6a by sheaf at 2025-10-07T21:39:43-04:00 Improve how we detect user type errors in types This commit cleans up all the code responsible for detecting whether a type contains "TypeError msg" applications nested inside it. All the logic is now in 'userTypeError_maybe', which is always deep. Whether it looks inside type family applications is determined by the passed-in boolean flag: - When deciding whether a constraint is definitely insoluble, don't look inside type family applications, as they may still reduce -- in which case the TypeError could disappear. - When reporting unsolved constraints, look inside type family applications: they had the chance to reduce but didn't, and the custom type error might contain valuable information. All the details are explained in Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint. Another benefit of this change is that it allows us to get rid of the deeply dodgy 'getUserTypeErrorMsg' function. This commit also improves the detection of custom type errors, for example in equality constraints: TypeError blah ~# rhs It used to be the case that we didn't detect the TypeError on the LHS, because we never considered that equality constraints could be insoluble due to the presence of custom type errors. Addressing this oversight improves detection of redundant pattern match warnings, fixing #26400. - - - - - 14 changed files: - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Validity.hs - + testsuite/tests/pmcheck/should_compile/T26400.hs - + testsuite/tests/pmcheck/should_compile/T26400.stderr - + testsuite/tests/pmcheck/should_compile/T26400b.hs - testsuite/tests/pmcheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/T20241b.stderr - testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr Changes: ===================================== compiler/GHC/Core/Predicate.hs ===================================== @@ -217,7 +217,7 @@ in GHC.Tc.Solver.Dict. -- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep" isEqPred :: PredType -> Bool -- True of (s ~# t) (s ~R# t) --- NB: but NOT true of (s ~ t) or (s ~~ t) or (Coecible s t) +-- NB: but NOT true of (s ~ t) or (s ~~ t) or (Coercible s t) isEqPred ty | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -74,8 +74,7 @@ module GHC.Core.Type ( mkCastTy, mkCoercionTy, splitCastTy_maybe, - ErrorMsgType, - userTypeError_maybe, deepUserTypeError_maybe, pprUserTypeErrorTy, + ErrorMsgType, pprUserTypeErrorTy, coAxNthLHS, stripCoercionTy, @@ -272,7 +271,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString -import GHC.Data.Maybe ( orElse, isJust, firstJust ) +import GHC.Data.Maybe ( orElse, isJust ) import GHC.List (build) -- $type_classification @@ -1223,45 +1222,6 @@ isLitTy ty -- | A type of kind 'ErrorMessage' (from the 'GHC.TypeError' module). type ErrorMsgType = Type --- | Is this type a custom user error? --- If so, give us the error message. -userTypeError_maybe :: Type -> Maybe ErrorMsgType -userTypeError_maybe ty - | Just ty' <- coreView ty = userTypeError_maybe ty' -userTypeError_maybe (TyConApp tc (_kind : msg : _)) - | tyConName tc == errorMessageTypeErrorFamName - -- There may be more than 2 arguments, if the type error is - -- used as a type constructor (e.g. at kind `Type -> Type`). - = Just msg -userTypeError_maybe _ - = Nothing - -deepUserTypeError_maybe :: Type -> Maybe ErrorMsgType --- Look for custom user error, deeply inside the type -deepUserTypeError_maybe ty - | Just ty' <- coreView ty = userTypeError_maybe ty' -deepUserTypeError_maybe (TyConApp tc tys) - | tyConName tc == errorMessageTypeErrorFamName - , _kind : msg : _ <- tys - -- There may be more than 2 arguments, if the type error is - -- used as a type constructor (e.g. at kind `Type -> Type`). - = Just msg - - | tyConMustBeSaturated tc -- Don't go looking for user type errors - -- inside type family arguments (see #20241). - = foldr (firstJust . deepUserTypeError_maybe) Nothing (drop (tyConArity tc) tys) - | otherwise - = foldr (firstJust . deepUserTypeError_maybe) Nothing tys -deepUserTypeError_maybe (ForAllTy _ ty) = deepUserTypeError_maybe ty -deepUserTypeError_maybe (FunTy { ft_arg = arg, ft_res = res }) - = deepUserTypeError_maybe arg `firstJust` deepUserTypeError_maybe res -deepUserTypeError_maybe (AppTy t1 t2) - = deepUserTypeError_maybe t1 `firstJust` deepUserTypeError_maybe t2 -deepUserTypeError_maybe (CastTy ty _) - = deepUserTypeError_maybe ty -deepUserTypeError_maybe _ -- TyVarTy, CoercionTy, LitTy - = Nothing - -- | Render a type corresponding to a user type error into a SDoc. pprUserTypeErrorTy :: ErrorMsgType -> SDoc pprUserTypeErrorTy ty = ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -671,11 +671,14 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics non_tv_eq _ _ = False -- Catch TypeError and Unsatisfiable. - -- Here, we want any nested TypeErrors to bubble up, so we use - -- 'containsUserTypeError' and not 'isTopLevelUserTypeError'. + -- Here, we want any nested TypeErrors to bubble up, even if they are + -- inside type family applications, so we pass 'True' to + -- 'containsUserTypeError'. -- -- See also Note [Implementation of Unsatisfiable constraints], point (F). - is_user_type_error item _ = containsUserTypeError (errorItemPred item) + is_user_type_error item _ = containsUserTypeError True (errorItemPred item) + -- True <=> look under ty-fam apps, AppTy etc. + -- See (UTE2) in Note [Custom type errors in constraints]. is_implicit_lifting item _ = case (errorItemOrigin item) of @@ -977,6 +980,8 @@ Its implementation consists of the following: This is the only way that "Unsatisfiable msg" constraints are reported, which makes their behaviour much more predictable than TypeError. + We don't go looking for Unsatisfiable constraints deeply nested inside + a type like we do for TypeError. -} @@ -1124,12 +1129,21 @@ mkUserTypeErrorReporter ctxt ; maybeReportError ctxt (item :| []) err ; addSolverDeferredBinding err item } + + mkUserTypeError :: ErrorItem -> TcSolverReportMsg mkUserTypeError item - | Just msg <- getUserTypeErrorMsg pty - = UserTypeError msg | Just msg <- isUnsatisfiableCt_maybe pty = UnsatisfiableError msg + | Just msg <- userTypeError_maybe True pty + -- ^^^^ + -- Look under type-family applications! We are reporting an error, + -- so we may as well look to see if there are any custom type errors + -- anywhere, as they might be helpful to the user. We gave the type + -- family application the chance to reduce, but it didn't. + -- + -- See (UTE2) in Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint. + = UserTypeError msg | otherwise = pprPanic "mkUserTypeError" (ppr item) where ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -659,20 +659,70 @@ equality constraint, but it is also important to detect custom type errors: To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble because it is a custom type error. -Failing to do so proved quite inconvenient for users, as evidence by the +Failing to do so proved quite inconvenient for users, as evidenced by the tickets #11503 #14141 #16377 #20180. Test cases: T11503, T14141. -Examples of constraints that tcCheckGivens considers insoluble: +To do this, tcCheckGivens calls getInertInsols, which returns all Given +constraints that are definitely insoluble. See Note [When is a constraint insoluble?]. + +Note [When is a constraint insoluble?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whether a constraint is insoluble matters for accurate pattern-match +warnings, as explained in Note [Pattern match warnings with insoluble Givens]. + +We consider a constraint to be insoluble if it definitely cannot be solved, +no matter what information we might further discover. For example, the following +constraints are insoluble: + - Int ~ Bool, - Coercible Float Word, - - TypeError msg. - -Non-examples: - - constraints which we know aren't satisfied, - e.g. Show (Int -> Int) when no such instance is in scope, - - Eq (TypeError msg), - - C (Int ~ Bool), with @class C (c :: Constraint)@. + - TypeError msg + - TypeError msg ~ Int + - Unsatisfiable msg + +Many constraints that look like they can't be solved are in fact not reported +as insoluble, as there might still be a possibility (no matter how remote) that +they can still be solved: + + 1: Show (Int -> Int) + + Reason: even though there is no relevant instance in scope, this constraint + could later get solved by a new instance. + + 2: C (Int ~ Bool), where C :: Constraint -> Constraint + + Reason: even though 'Int ~ Bool' is insoluble, the constraint 'C (Int ~ Bool)' + might be soluble, e.g. if 'C' is a class and we have 'instance forall c. C c', + or 'C' is a type family and we have 'type instance C c = (() :: Constraint)'. + + 3: Nested occurences of TypeError don't always lead to insolubility. For + example, none of the following constraints are definitely insoluble: + + (a) F alpha (TypeError msg) -- 'F' is an arity 2 type family + (b) Eq (TypeError msg) + (c) c (TypeError msg) -- 'c' is a metavariable + (d) (TC alpha) (TypeError msg) -- 'TC' is an arity 1 type family + (e) TypeError msg ~ rhs -- (depends on rhs) + + None of these constraints are definitely insoluble: + + (a) Can be solved if 'F' reduces, e.g. 'alpha := Int', 'type instance F Int a = (() :: Constraint)'. + (b) Can be solved by 'instance forall x. Eq x'. + (c) Can be solved if 'c' unifies with 'C', as in example (2). + (d) Can be solved if 'TC alpha' reduces to 'C', as in example (2). + (e) If 'rhs' is a rigid type such as 'Int' or 'Maybe Char', then this + constraint is definitely insoluble. Otherwise, however, the constraint + could be soluble: + - rhs = G alpha, for an arity 1 type family G + G alpha could reduce to TypeError msg. + - rhs = k, for a skolem type variable k. + We could instantiate k to something else, and then the constraint + could become soluble. + + For this reason, we are careful to not pull out certain occurrences of TypeError, + e.g. inside type family applications and class constraints. + See Note [Custom type errors in constraints]. -} tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -172,7 +172,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Constraint -import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName ) +import GHC.Builtin.Names ( callStackTyConName, exceptionContextTyConName ) import GHC.Core.Type import GHC.Core.TyCo.Rep as Rep @@ -185,6 +185,10 @@ import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Unify (typesAreApart) +import GHC.LanguageExtensions as LangExt +import GHC.Rename.Env +import qualified GHC.Rename.Env as TcM + import GHC.Types.Name import GHC.Types.TyThing import GHC.Types.Name.Reader @@ -199,8 +203,7 @@ import GHC.Types.ThLevelIndex (thLevelIndexFromImportLevel) import GHC.Types.SrcLoc import GHC.Unit.Module -import qualified GHC.Rename.Env as TcM -import GHC.Rename.Env +import GHC.Unit.Module.Graph import GHC.Utils.Outputable import GHC.Utils.Panic @@ -220,15 +223,13 @@ import Data.List ( mapAccumL ) import Data.List.NonEmpty ( nonEmpty ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as S -import GHC.LanguageExtensions as LangExt +import qualified Data.Set as Set #if defined(DEBUG) import GHC.Types.Unique.Set (nonDetEltsUniqSet) import GHC.Data.Graph.Directed #endif -import qualified Data.Set as Set -import GHC.Unit.Module.Graph {- ********************************************************************* * * @@ -666,9 +667,10 @@ getInnermostGivenEqLevel = do { inert <- getInertCans -- This consists of: -- -- - insoluble equalities, such as @Int ~# Bool@; --- - constraints that are top-level custom type errors, of the form --- @TypeError msg@, but not constraints such as @Eq (TypeError msg)@ --- in which the type error is nested; +-- - constraints that are custom type errors, of the form +-- @TypeError msg@ or @Maybe (TypeError msg)@, but not constraints such as +-- @F x (TypeError msg)@ in which the type error is nested under +-- a type family application, -- - unsatisfiable constraints, of the form @Unsatisfiable msg@. -- -- The inclusion of Givens is important for pattern match warnings, as we @@ -676,21 +678,26 @@ getInnermostGivenEqLevel = do { inert <- getInertCans -- redundant (see Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver). getInertInsols :: TcS Cts getInertInsols - = do { inert <- getInertCans - ; let insols = filterBag insolubleIrredCt (inert_irreds inert) - unsats = findDictsByTyConKey (inert_dicts inert) unsatisfiableClassNameKey - ; return $ fmap CDictCan unsats `unionBags` fmap CIrredCan insols } + -- See Note [When is a constraint insoluble?] + = do { inert_cts <- getInertCts + ; return $ filterBag insolubleCt inert_cts } + +getInertCts :: TcS Cts +getInertCts + = do { inerts <- getInertCans + ; return $ + unionManyBags + [ fmap CIrredCan $ inert_irreds inerts + , foldDicts (consBag . CDictCan) (inert_dicts inerts) emptyBag + , foldFunEqs (consBag . CEqCan ) (inert_funeqs inerts) emptyBag + , foldTyEqs (consBag . CEqCan ) (inert_eqs inerts) emptyBag + ] } getInertGivens :: TcS [Ct] -- Returns the Given constraints in the inert set getInertGivens - = do { inerts <- getInertCans - ; let all_cts = foldIrreds ((:) . CIrredCan) (inert_irreds inerts) - $ foldDicts ((:) . CDictCan) (inert_dicts inerts) - $ foldFunEqs ((:) . CEqCan) (inert_funeqs inerts) - $ foldTyEqs ((:) . CEqCan) (inert_eqs inerts) - $ [] - ; return (filter isGivenCt all_cts) } + = do { all_cts <- getInertCts + ; return (filter isGivenCt $ bagToList all_cts) } getPendingGivenScs :: TcS [Ct] -- Find all inert Given dictionaries, or quantified constraints, such that ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -471,7 +471,9 @@ findRedundantGivens (Implic { ic_info = info, ic_need = need, ic_given = givens | otherwise = filterOut is_minimal givens -- See #15232 - is_type_error id = isTopLevelUserTypeError (idType id) + is_type_error id = containsUserTypeError False (idType id) + -- False <=> do not look under ty-fam apps, AppTy etc. + -- See (UTE1) in Note [Custom type errors in constraints]. is_improving pred -- (transSuperClasses p) does not include p = any isImprovementPred (pred : transSuperClasses pred) ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} -- | This module defines types and simple operations over constraints, as used @@ -13,7 +14,7 @@ module GHC.Tc.Types.Constraint ( isPendingScDictCt, isPendingScDict, pendingScDict_maybe, superClassesMightHelp, getPendingWantedScs, isWantedCt, isGivenCt, - isTopLevelUserTypeError, containsUserTypeError, getUserTypeErrorMsg, + userTypeError_maybe, containsUserTypeError, isUnsatisfiableCt_maybe, ctEvidence, updCtEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, @@ -59,7 +60,7 @@ module GHC.Tc.Types.Constraint ( addInsols, dropMisleading, addSimples, addImplics, addHoles, addNotConcreteError, addMultiplicityCoercionError, addDelayedErrors, tyCoVarsOfWC, tyCoVarsOfWCList, - insolubleWantedCt, insolubleCt, insolubleIrredCt, + insolubleWantedCt, insolubleCt, insolubleImplic, nonDefaultableTyVarsOfWC, approximateWCX, approximateWC, @@ -113,6 +114,7 @@ import GHC.Core.Coercion import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Rep import GHC.Types.Name import GHC.Types.Var @@ -136,16 +138,13 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Data.Bag +import Control.Monad ( when ) import Data.Coerce -import qualified Data.Semigroup as S -import Control.Monad ( msum, when ) +import Data.List ( intersperse ) import Data.Maybe ( mapMaybe, isJust ) - --- these are for CheckTyEqResult +import GHC.Data.Maybe ( firstJust, firstJusts ) +import qualified Data.Semigroup as S import Data.Word ( Word8 ) -import Data.List ( intersperse ) - - {- ************************************************************************ @@ -1198,73 +1197,53 @@ insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors }) is_insoluble (DE_Multiplicity {}) = False insolubleWantedCt :: Ct -> Bool --- Definitely insoluble, in particular /excluding/ type-hole constraints --- Namely: --- a) an insoluble constraint as per 'insolubleIrredCt', i.e. either --- - an insoluble equality constraint (e.g. Int ~ Bool), or --- - a custom type error constraint, TypeError msg :: Constraint --- b) that does not arise from a Given or a Wanted/Wanted fundep interaction +-- | Is this a definitely insoluble Wanted constraint? Namely: +-- +-- - a Wanted, +-- - which is insoluble (as per 'insolubleCt'), +-- - that does not arise from a Given or a Wanted/Wanted fundep interaction. +-- -- See Note [Insoluble Wanteds] insolubleWantedCt ct - | CIrredCan ir_ct <- ct - -- CIrredCan: see (IW1) in Note [Insoluble Wanteds] - , IrredCt { ir_ev = ev } <- ir_ct - , CtWanted (WantedCt { ctev_loc = loc, ctev_rewriters = rewriters }) <- ev + | CtWanted (WantedCt { ctev_loc = loc, ctev_rewriters = rewriters }) + <- ctEvidence ct -- It's a Wanted - , insolubleIrredCt ir_ct + , insolubleCt ct -- It's insoluble , isEmptyRewriterSet rewriters - -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds] + -- It has no rewriters – see (IW1) in Note [Insoluble Wanteds] , not (isGivenLoc loc) - -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds] + -- It doesn't arise from a Given – see (IW2) in Note [Insoluble Wanteds] , not (isWantedWantedFunDepOrigin (ctLocOrigin loc)) - -- origin check: see (IW4) in Note [Insoluble Wanteds] + -- It doesn't arise from a W/W fundep interaction – see (IW3) in Note [Insoluble Wanteds] = True | otherwise = False --- | Returns True of constraints that are definitely insoluble, --- as well as TypeError constraints. --- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. +-- | Returns True of constraints that are definitely insoluble, including +-- constraints that include custom type errors, as per (1) +-- in Note [Custom type errors in constraints]. -- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- That's why it looks only for IrredCt; all insoluble constraints --- are put into CIrredCan +-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. insolubleCt :: Ct -> Bool -insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct -insolubleCt _ = False - -insolubleIrredCt :: IrredCt -> Bool --- Returns True of Irred constraints that are /definitely/ insoluble --- --- This function is critical for accurate pattern-match overlap warnings. --- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver --- --- Note that this does not traverse through the constraint to find --- nested custom type errors: it only detects @TypeError msg :: Constraint@, --- and not e.g. @Eq (TypeError msg)@. -insolubleIrredCt (IrredCt { ir_ev = ev, ir_reason = reason }) - = isInsolubleReason reason - || isTopLevelUserTypeError (ctEvPred ev) - -- NB: 'isTopLevelUserTypeError' detects constraints of the form "TypeError msg" - -- and "Unsatisfiable msg". It deliberately does not detect TypeError - -- nested in a type (e.g. it does not use "containsUserTypeError"), as that - -- would be too eager: the TypeError might appear inside a type family - -- application which might later reduce, but we only want to return 'True' - -- for constraints that are definitely insoluble. - -- - -- For example: Num (F Int (TypeError "msg")), where F is a type family. - -- - -- Test case: T11503, with the 'Assert' type family: - -- - -- > type Assert :: Bool -> Constraint -> Constraint - -- > type family Assert check errMsg where - -- > Assert 'True _errMsg = () - -- > Assert _check errMsg = errMsg +insolubleCt ct + | CIrredCan (IrredCt { ir_reason = reason }) <- ct + , isInsolubleReason reason + = True + | isJust $ isUnsatisfiableCt_maybe pred + = True + | containsUserTypeError False pred + -- False <=> do not look under ty-fam apps, AppTy etc. + -- See (UTE1) in Note [Custom type errors in constraints]. + = True + | otherwise + = False + where + pred = ctPred ct -- | Does this hole represent an "out of scope" error? +-- -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore (occName occ)) @@ -1312,12 +1291,7 @@ Note [Insoluble Wanteds] insolubleWantedCt returns True of a Wanted constraint that definitely can't be solved. But not quite all such constraints; see wrinkles. -(IW1) insolubleWantedCt is tuned for application /after/ constraint - solving i.e. assuming canonicalisation has been done. That's why - it looks only for IrredCt; all insoluble constraints are put into - CIrredCan - -(IW2) We only treat it as insoluble if it has an empty rewriter set. (See Note +(IW1) We only treat it as insoluble if it has an empty rewriter set. (See Note [Wanteds rewrite Wanteds].) Otherwise #25325 happens: a Wanted constraint A that is /not/ insoluble rewrites some other Wanted constraint B, so B has A in its rewriter set. Now B looks insoluble. The danger is that we'll @@ -1325,10 +1299,10 @@ can't be solved. But not quite all such constraints; see wrinkles. reporting A because there is an insoluble B lying around. (This suppression happens in GHC.Tc.Errors.mkErrorItem.) Solution: don't treat B as insoluble. -(IW3) If the Wanted arises from a Given (how can that happen?), don't +(IW2) If the Wanted arises from a Given (how can that happen?), don't treat it as a Wanted insoluble (obviously). -(IW4) If the Wanted came from a Wanted/Wanted fundep interaction, don't +(IW3) If the Wanted came from a Wanted/Wanted fundep interaction, don't treat the constraint as insoluble. See Note [Suppressing confusing errors] in GHC.Tc.Errors @@ -1354,71 +1328,165 @@ Yuk! {- Note [Custom type errors in constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When GHC reports a type-error about an unsolved-constraint, we check -to see if the constraint contains any custom-type errors, and if so -we report them. Here are some examples of constraints containing type -errors: - - TypeError msg -- The actual constraint is a type error - - TypError msg ~ Int -- Some type was supposed to be Int, but ended up - -- being a type error instead - - Eq (TypeError msg) -- A class constraint is stuck due to a type error - - F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err - -It is also possible to have constraints where the type error is nested deeper, -for example see #11990, and also: - - Eq (F (TypeError msg)) -- Here the type error is nested under a type-function - -- call, which failed to evaluate because of it, - -- and so the `Eq` constraint was unsolved. - -- This may happen when one function calls another - -- and the called function produced a custom type error. - -A good use-case is described in "Detecting the undetectable" - https://blog.csongor.co.uk/report-stuck-families/ -which features - type family Assert (err :: Constraint) (break :: Type -> Type) (a :: k) :: k where - Assert _ Dummy _ = Any - Assert _ _ k = k -and an unsolved constraint like - Assert (TypeError ...) (F ty1) ty1 ~ ty2 -that reports that (F ty1) remains stuck. +A custom type error is a type family application 'TypeError msg' where +'msg :: ErrorMessage', or an Unsatisfiable constraint. +See Note [Custom type errors] and Note [The Unsatisfiable constraint] +in GHC.Internal.TypeError. + +There are two ways in which the presence of such custom type errors inside a +type impact GHC's behaviour: + + (UTE1) + Constraints that contain a custom type error are considered to be + insoluble. This affects pattern-match warnings, as explained in + Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver. + + This includes examples such as: + + TypeError msg -- The actual constraint is a type error + + TypeError msg ~# Int -- Some type was supposed to be Int, but ended up + -- being a type error instead + + However, we must be careful about occurrences of custom type errors + nested inside the constraint, as they may not make the constraint + insoluble. This is explained in Note [When is a constraint insoluble?] + in GHC.Tc.Solver. In particular: + + a. Do not look inside type family applications. + b. Do not look inside class constraints. + c. Do not look inside AppTy or in arguments of a type family past its arity. + d. Only consider 'TypeError msg ~ rhs' to be insoluble if rhs definitely + cannot unify with 'TypeError msg', e.g. if 'rhs = Int' the constraint + is insoluble, but if 'rhs = k[sk]' then it isn't. + + These subtle cases are tested in T26400b. + + A good use-case for type errors nested under type family applications is + described in "Detecting the undetectable" (https://blog.csongor.co.uk/report-stuck-families/) + which features: + type family Assert (err :: Constraint) (break :: Type -> Type) (a :: k) :: k where + Assert _ Dummy _ = Any + Assert _ _ k = k + and an unsolved constraint like 'Assert (TypeError ...) (F ty1) ty1 ~ ty2' + which reports when (F ty1) remains stuck. + + (UTE2) + When reporting unsolved constraints, we pull out any custom type errors + and report the corresponding message to the user. + + Unlike in (UTE1), we do want to pull out 'TypeError' wherever it occurs + inside the type, including inside type-family applications. We tried to + solve the constraint, reduce type families etc, but the constraint + remained unsolved all the way till the end. Now that we are reporting the + error, it makes sense to pull out the 'TypeError' and report the custom + error message to the user, as the intention is that this message might + be informative. + + Examples: + + Num (TypeError msg) -- A class constraint is stuck due to a type error + + F (TypeError msg) ~ a -- A type function failed to evaluate due to a type error + + Eq (F (TypeError msg)) -- Here the type error is nested under a type-function + -- call, which failed to evaluate because of it, + -- and so the `Eq` constraint was unsolved. + -- This may happen when one function calls another + -- and the called function produced a custom type error. + +We use a single function, 'userTypeError_maybe', to pull out TypeError according +to the rules of either (UTE1) or (UTE2), depending on the passed in boolean +flag to 'userTypeError_maybe': 'False' for (UTE1) and 'True' for (UTE2). -} --- | A constraint is considered to be a custom type error, if it contains --- custom type errors anywhere in it. --- See Note [Custom type errors in constraints] -getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType -getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred - : map getUserTypeErrorMsg (subTys pred) +-- | Does this type contain 'TypeError msg', either at the top-level or +-- nested within it somewhere? +-- +-- If so, return the error message. +-- +-- See Note [Custom type errors in constraints]. +userTypeError_maybe + :: Bool -- ^ Look everywhere: inside type-family applications, class constraints, AppTys etc? + -> Type + -> Maybe ErrorMsgType +userTypeError_maybe look_everywhere = go where - -- Richard thinks this function is very broken. What is subTys - -- supposed to be doing? Why are exactly-saturated tyconapps special? - -- What stops this from accidentally ripping apart a call to TypeError? - subTys t = case splitAppTys t of - (t,[]) -> - case splitTyConApp_maybe t of - Nothing -> [] - Just (_,ts) -> ts - (t,ts) -> t : ts - --- | Is this an user error message type, i.e. either the form @TypeError err@ or --- @Unsatisfiable err@? -isTopLevelUserTypeError :: PredType -> Bool -isTopLevelUserTypeError pred = - isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred) + go ty + | Just ty' <- coreView ty + = go ty' + go (TyConApp tc tys) + | tyConName tc == errorMessageTypeErrorFamName + , _kind : msg : _ <- tys + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + = Just msg + + -- (UTE1.d) TypeError msg ~ a is only insoluble if 'a' cannot be a type error + | not look_everywhere + , tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + , [ ki1, ki2, ty1, ty2 ] <- tys + = if | Just msg <- go ki1 + , isRigidTy ki2 + -> Just msg + | Just msg <- go ki2 + , isRigidTy ki1 + -> Just msg + | Just msg <- go ty1 + , isRigidTy ty2 + -> Just msg + | Just msg <- go ty2 + , isRigidTy ty1 + -> Just msg + | otherwise + -> Nothing + + -- (UTE1.a) Don't look under type family applications. + | tyConMustBeSaturated tc + , not look_everywhere + = Nothing + -- (UTE1.c) Don't even look in the arguments past the arity of the TyCon. + + -- (UTE1.b) Don't look inside class constraints. + | isClassTyCon tc + , not look_everywhere + = foldr (firstJust . go) Nothing (drop (tyConArity tc) tys) + | otherwise + = foldr (firstJust . go) Nothing tys + go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `firstJust` go ty + go (FunTy { ft_mult = mult, ft_arg = arg, ft_res = res }) + = firstJusts + [ go mult + , go (typeKind arg) + , go (typeKind res) + , go arg + , go res ] + go (AppTy t1 t2) + -- (UTE1.c) Don't look inside AppTy. + | not look_everywhere + = Nothing + | otherwise + = go t1 `firstJust` go t2 + go (CastTy ty _co) = go ty + go (TyVarTy tv) = go (tyVarKind tv) + go (CoercionTy {}) = Nothing + go (LitTy {}) = Nothing -- | Does this constraint contain an user error message? -- -- That is, the type is either of the form @Unsatisfiable err@, or it contains -- a type of the form @TypeError msg@, either at the top level or nested inside -- the type. -containsUserTypeError :: PredType -> Bool -containsUserTypeError pred = - isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred) +-- +-- See Note [Custom type errors in constraints]. +containsUserTypeError + :: Bool -- ^ look inside type-family applications, 'AppTy', etc? + -> PredType + -> Bool +containsUserTypeError look_in_famapps pred = + isJust (isUnsatisfiableCt_maybe pred) + || + isJust (userTypeError_maybe look_in_famapps pred) -- | Is this type an unsatisfiable constraint? -- If so, return the error message. ===================================== compiler/GHC/Tc/Validity.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin import GHC.Tc.Types.Rank import GHC.Tc.Errors.Types +import GHC.Tc.Types.Constraint ( userTypeError_maybe ) import GHC.Tc.Utils.Env (tcLookupId) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad @@ -282,7 +283,12 @@ checkUserTypeError ctxt ty | TySynCtxt {} <- ctxt -- Do not complain about TypeError on the = return () -- RHS of type synonyms. See #20181 - | Just msg <- deepUserTypeError_maybe ty + | Just msg <- userTypeError_maybe False ty + -- ^^^^^ + -- Don't look under type-family applications! We only want to pull out + -- definite errors. + -- + -- See (UTE1) in Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint. = do { env0 <- liftZonkM tcInitTidyEnv ; let (env1, tidy_msg) = tidyOpenTypeX env0 msg ; failWithTcM (env1, TcRnUserTypeError tidy_msg) } ===================================== testsuite/tests/pmcheck/should_compile/T26400.hs ===================================== @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module T26400 where + +import GHC.Exts ( UnliftedType ) +import GHC.TypeLits ( TypeError, ErrorMessage(..) ) + +data N = Z | S N + +-- Make this type unlifted to avoid any subtleties about laziness +type SNat :: N -> UnliftedType +data SNat n where + SZ :: SNat Z + SS :: SNat n -> SNat (S n) + +type (-) :: N -> N -> N +type family a - b where + n - Z = n + Z - S _ = TypeError ( Text "impossible" ) + S n - S m = n - m + +testFn :: SNat n -> SNat m -> SNat (n - m) -> Int +testFn SZ (SS _) SZ = 666 +testFn SZ (SS _) (SS _) = 999 + -- [G] g1 :: n ~ Z + -- [G] g2 :: m ~ S m1 + -- [G] g3 :: (n-m) ~ S m2 + -- Use the first two givens to substitute in the third, we get: + -- [G] g3' :: Z - S m1 ~ S m2 + -- Reduce the LHS using the type family + -- [G] g3'' :: TypeError ... ~ S m2 + -- Hence g3'' is insoluble and the equation can never match +testFn _ _ _ = 1 ===================================== testsuite/tests/pmcheck/should_compile/T26400.stderr ===================================== @@ -0,0 +1,8 @@ +T26400.hs:27:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘testFn’: testFn SZ (SS _) SZ = ... + +T26400.hs:28:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘testFn’: testFn SZ (SS _) (SS _) = ... + ===================================== testsuite/tests/pmcheck/should_compile/T26400b.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module T26400b where + +import Data.Kind +import GHC.TypeLits ( TypeError, ErrorMessage(..) ) + +type F :: Type -> Type -> Type +type family F a b where + F Float _ = Bool + F _ a = a + +type C :: Type -> Type -> Constraint +class C a b +instance C () b + +type Boom :: Type -> Type +type family Boom a where + Boom () = TypeError (Text "boom") + +type TF :: Type -> ( Type -> Type -> Constraint ) +type family TF a where + TF () = C + +type G :: Type -> Type -> Type +data G a b where + G1 :: a -> F b (Boom a) -> G a b + G2 :: C a (Boom a) => a -> G a b + G3 :: (TF b) a (Boom a) => a -> G a b + G4 :: (b ~ Boom a) => G a b + +g :: G () b -> Int +g (G1 {}) = 1 -- not redundant: F b (TypeError ...) can be solved if F reduces +g (G2 {}) = 2 -- not redundant: C () (TypeError ...) is not insoluble +g (G3 {}) = 3 -- not redundant: TF b () (TypeError ...) could reduce to C () (TypeError ...) +g (G4 {}) = 4 -- not redundant: b ~ TypeError ... could be solved depending on instantiation of b ===================================== testsuite/tests/pmcheck/should_compile/all.T ===================================== @@ -123,6 +123,8 @@ test('T21761', [], compile, [overlapping_incomplete]) test('T22964', [], compile, [overlapping_incomplete]) test('T23445', [], compile, [overlapping_incomplete]) test('T24234', [], compile, [overlapping_incomplete+'-Wincomplete-uni-patterns']) +test('T26400', [], compile, [overlapping_incomplete]) +test('T26400b', [], compile, [overlapping_incomplete]) # Series (inspired) by Luke Maranget ===================================== testsuite/tests/typecheck/should_fail/T20241b.stderr ===================================== @@ -1,4 +1,3 @@ - T20241b.hs:16:8: error: [GHC-47403] • Boom • In the type signature: @@ -6,11 +5,14 @@ T20241b.hs:16:8: error: [GHC-47403] -> Type -> Constraint) IO) a => Proxy a -> () -T20241b.hs:20:8: error: [GHC-47403] +T20241b.hs:20:8: error: [GHC-64725] • Boom - • In the type signature: + • In the ambiguity check for ‘bar’ + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + In the type signature: bar :: ((c :: Constraint -> Type -> Constraint) (((TypeError (Text "Boom") :: (Type -> Type) -> Type -> Constraint) IO) a)) a => Proxy a -> () + ===================================== testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr ===================================== @@ -9,11 +9,11 @@ UnliftedNewtypesFamilyKindFail2.hs:12:20: error: [GHC-83865] • In the first argument of ‘F’, namely ‘5’ In the newtype family instance declaration for ‘F’ -UnliftedNewtypesFamilyKindFail2.hs:12:31: [GHC-83865] - Expected a type, +UnliftedNewtypesFamilyKindFail2.hs:12:31: error: [GHC-83865] + • Expected a type, but ‘5’ has kind ‘GHC.Internal.Bignum.Natural.Natural’ - In the first argument of ‘F’, namely ‘5’ + • In the first argument of ‘F’, namely ‘5’ In the type ‘(F 5)’ In the definition of data constructor ‘MkF’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7471eb6a250ff713f9416346478f46b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7471eb6a250ff713f9416346478f46b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/gbc-files] Add support for generating bytecode objects
by Matthew Pickering (＠mpickering) 07 Oct '25

07 Oct '25

Matthew Pickering pushed to branch wip/gbc-files at Glasgow Haskell Compiler / GHC Commits: 612da2fa by Matthew Pickering at 2025-10-07T16:00:49+01:00 Add support for generating bytecode objects This commit adds the `-fwrite-byte-code` option which makes GHC emit a `.gbc` file which contains a serialised representation of bytecode. The bytecode can be loaded by the compiler to avoid having to reinterpret a module when using the bytecode interpreter (for example, in GHCi). There are also the new options: * -gbcdir=<DIR>: Specify the directory to place the gbc files * -gbcsuf=<suffix>: Specify the suffix for gbc files The option `-fbyte-code-and-object-code` now implies `-fwrite-byte-code`. These performance tests fail due to https://github.com/haskell/directory/issues/204 ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiComponentModulesRecomp MultiLayerModulesRecomp MultiLayerModulesTH_Make MultiLayerModulesTH_OneShot T13701 ------------------------- The bytecode serialisation part was implemented by Cheng Shao Co-authored-by: Cheng Shao <terrorjack(a)type.dance> - - - - - 67 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/Breakpoints.hs - + compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Data/FlatBag.hs - compiler/GHC/Data/SmallArray.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/Backpack.hs - + compiler/GHC/Driver/ByteCode.hs - compiler/GHC/Driver/Config/Finder.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Messager.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/Location.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/Module/WholeCoreBindings.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in - docs/users_guide/phases.rst - docs/users_guide/separate_compilation.rst - testsuite/tests/bytecode/T24634/T24634a.stdout - testsuite/tests/bytecode/T24634/T24634b.stdout - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/driver/bytecode-object/A.hs - + testsuite/tests/driver/bytecode-object/BytecodeForeign.c - + testsuite/tests/driver/bytecode-object/BytecodeForeign.hs - + testsuite/tests/driver/bytecode-object/BytecodeMain.hs - + testsuite/tests/driver/bytecode-object/BytecodeTest.hs - + testsuite/tests/driver/bytecode-object/Makefile - + testsuite/tests/driver/bytecode-object/all.T - + testsuite/tests/driver/bytecode-object/bytecode_object12.stderr - + testsuite/tests/driver/bytecode-object/bytecode_object13.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object14.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object15.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object16.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object17.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object18.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object19.script - + testsuite/tests/driver/bytecode-object/bytecode_object19.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object25.script - + testsuite/tests/driver/bytecode-object/bytecode_object25.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object4.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object5.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object6.stdout - testsuite/tests/driver/fat-iface/T22405/T22405.stdout - testsuite/tests/driver/fat-iface/T22405/T22405b.stdout - testsuite/tests/driver/fat-iface/fat011.stderr - testsuite/tests/perf/compiler/Makefile - + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciWithBytecodeFiles.script - testsuite/tests/perf/compiler/all.T - testsuite/tests/simplStg/should_compile/T22840.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/612da2fae21b6525bac96e8c47d1f11… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/612da2fae21b6525bac96e8c47d1f11… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26470] compiler: "role" is only a keyword when RoleAnnotations is set
by Zubin (＠wz1000) 07 Oct '25

07 Oct '25

Zubin pushed to branch wip/26470 at Glasgow Haskell Compiler / GHC Commits: e6bf1b2b by Zubin Duggal at 2025-10-07T20:23:04+05:30 compiler: "role" is only a keyword when RoleAnnotations is set Fixes #26470 - - - - - 3 changed files: - compiler/GHC/Parser/Lexer.x - + testsuite/tests/parser/should_compile/T26470.hs - testsuite/tests/parser/should_compile/all.T Changes: ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -1068,7 +1068,7 @@ reservedWordsFM = listToUFM $ ( "mdo", ITmdo Nothing, xbit RecursiveDoBit), -- See Note [Lexing type pseudo-keywords] ( "family", ITfamily, 0 ), - ( "role", ITrole, 0 ), + ( "role", ITrole, xbit RoleAnnotationsBit ), ( "pattern", ITpattern, xbit PatternSynonymsBit), ( "static", ITstatic, xbit StaticPointersBit ), ( "stock", ITstock, 0 ), @@ -2790,6 +2790,7 @@ data ExtBits | RequiredTypeArgumentsBit | MultilineStringsBit | LevelImportsBit + | RoleAnnotationsBit -- Flags that are updated once parsing starts | InRulePragBit @@ -2874,6 +2875,7 @@ mkParserOpts extensionFlags diag_opts .|. RequiredTypeArgumentsBit `xoptBit` LangExt.RequiredTypeArguments .|. MultilineStringsBit `xoptBit` LangExt.MultilineStrings .|. LevelImportsBit `xoptBit` LangExt.ExplicitLevelImports + .|. RoleAnnotationsBit `xoptBit` LangExt.RoleAnnotations optBits = HaddockBit `setBitIf` isHaddock .|. RawTokenStreamBit `setBitIf` rawTokStream ===================================== testsuite/tests/parser/should_compile/T26470.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE Haskell2010 #-} +module T26470 where + +role :: Int +role = 42 + +f :: Int -> Int +f role = role + 1 + +data T = MkT { role :: String } + +newtype T2 role = MkT2 Int ===================================== testsuite/tests/parser/should_compile/all.T ===================================== @@ -208,3 +208,4 @@ test('T25258', normal, compile, ['']) test('T17045b', extra_files(["T17045"]), multimod_compile, ['-iT17045 Test', '-v0']) test('T25900', normal, compile, ['']) test('T25900_noext', normal, compile, ['']) +test('T26470', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e6bf1b2b0cd66653ad07e8785cb1360… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e6bf1b2b0cd66653ad07e8785cb1360… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26470] compiler: "role" is only a keyword when RoleAnnotations is set
by Zubin (＠wz1000) 07 Oct '25

07 Oct '25

Zubin pushed to branch wip/26470 at Glasgow Haskell Compiler / GHC Commits: ee4bac18 by Zubin Duggal at 2025-10-07T20:08:25+05:30 compiler: "role" is only a keyword when RoleAnnotations is set Fixes #26470 - - - - - 2 changed files: - compiler/GHC/Parser/Lexer.x - testsuite/tests/parser/should_compile/all.T Changes: ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -1068,7 +1068,7 @@ reservedWordsFM = listToUFM $ ( "mdo", ITmdo Nothing, xbit RecursiveDoBit), -- See Note [Lexing type pseudo-keywords] ( "family", ITfamily, 0 ), - ( "role", ITrole, 0 ), + ( "role", ITrole, xbit RoleAnnotationsBit ), ( "pattern", ITpattern, xbit PatternSynonymsBit), ( "static", ITstatic, xbit StaticPointersBit ), ( "stock", ITstock, 0 ), @@ -2790,6 +2790,7 @@ data ExtBits | RequiredTypeArgumentsBit | MultilineStringsBit | LevelImportsBit + | RoleAnnotationsBit -- Flags that are updated once parsing starts | InRulePragBit @@ -2874,6 +2875,7 @@ mkParserOpts extensionFlags diag_opts .|. RequiredTypeArgumentsBit `xoptBit` LangExt.RequiredTypeArguments .|. MultilineStringsBit `xoptBit` LangExt.MultilineStrings .|. LevelImportsBit `xoptBit` LangExt.ExplicitLevelImports + .|. RoleAnnotationsBit `xoptBit` LangExt.RoleAnnotations optBits = HaddockBit `setBitIf` isHaddock .|. RawTokenStreamBit `setBitIf` rawTokStream ===================================== testsuite/tests/parser/should_compile/all.T ===================================== @@ -208,3 +208,4 @@ test('T25258', normal, compile, ['']) test('T17045b', extra_files(["T17045"]), multimod_compile, ['-iT17045 Test', '-v0']) test('T25900', normal, compile, ['']) test('T25900_noext', normal, compile, ['']) +test('T26470', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee4bac18ad0df86d0601f849d5f5803… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee4bac18ad0df86d0601f849d5f5803… You're receiving this email because of your account on gitlab.haskell.org.

1 0