- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/apk/expose-overloaded-unfoldings] Enable -fexpose-overloaded-unfoldings by default when optimizations are on.
by Andreas Klebinger (＠AndreasK) 30 Sep '26

30 Sep '26

Andreas Klebinger pushed to branch wip/apk/expose-overloaded-unfoldings at Glasgow Haskell Compiler / GHC Commits: 1077867a by Andreas Klebinger at 2026-09-30T16:05:13+00:00 Enable -fexpose-overloaded-unfoldings by default when optimizations are on. I also made the -fexpose-*-unfoldings flags optimization flags rather than codeGen flags. This was needed to fix a test and is the correct place for them. Performance numbers: In general this averages out to ~1% more file size across the GHC build. Compiler allocations grow by 0.14% on nofib as the compiler needs to deal with more available unfoldings. On the cabal test it's awash. With some configurations getting slightly faster, some slightly slower. It's all in the +/- 0.2% range. On nofib itself we produce exactly the same code. Which is expected, as it doesn't use -fspecialize-aggresively anywhere afaik which is needed to take advantage of cross module specialization. Fixes #13090 ------------------------- Metric Increase: LinkableUsage01 LinkableUsage02 MultiLayerModulesTH_Make MultiLayerModulesTH_OneShot T21839c T24471 hard_hole_fits ------------------------- - - - - - 6 changed files: - + changelog.d/T13090-expose-overloaded-unfoldings - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Iface/Tidy.hs - docs/users_guide/using-optimisation.rst - testsuite/tests/dmdanal/should_compile/T23398.stderr Changes: ===================================== changelog.d/T13090-expose-overloaded-unfoldings ===================================== @@ -0,0 +1,6 @@ +section: compiler +issues: #13090 +mrs: !16684 +synopsis: + Enable :ghc-flag:`-fexpose-overloaded-unfoldings` by default with :ghc-flag:`-O` or higher. + ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1337,6 +1337,7 @@ optLevelFlags -- see Note [Documenting optimisation flags] , ([1,2], Opt_Specialise) , ([1,2], Opt_PolymorphicSpecialisation) -- Now on by default (#23559) , ([1,2], Opt_CrossModuleSpecialise) + , ([1,2], Opt_ExposeOverloadedUnfoldings) -- See Note [Exposing overloaded functions] in GHC.Iface.Tidy , ([1,2], Opt_InlineGenerics) , ([1,2], Opt_Strictness) , ([1,2], Opt_UnboxSmallStrictFields) ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -971,6 +971,8 @@ optimisationFlags = EnumSet.fromList , Opt_SolveConstantDicts , Opt_SpecEval , Opt_SpecEvalDictFun + , Opt_ExposeAllUnfoldings + , Opt_ExposeOverloadedUnfoldings ] -- | The set of flags which affect code generation and can change a program's @@ -1001,8 +1003,6 @@ codeGenFlags = EnumSet.fromList , Opt_OmitYields -- Flags that affect generated code - , Opt_ExposeAllUnfoldings - , Opt_ExposeOverloadedUnfoldings , Opt_NoTypeableBinds , Opt_NoBuiltinRules , Opt_NoBignumRules ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -806,8 +806,19 @@ anyway we allow for some false positives and simply expose all functions which have a constraint. This means we might expose more unhelpful unfoldings. But it seems like the better choice. -Currently this option is off by default and has to be enabled manually. But -we might change this in the future. +We enable the flag by default with -O/O2 to allow users to opt into specialization +at call sites. We do not enable -fspecialize-aggressively. See also #13090. + +In terms of performance impact the cost is very modest: +On GHC and it's boot libraries overall enabling this flag increases overall disk +space used by ~1%. With a highly variant distribution across various .hi files. +In terms of compile times the overhead is low enough to be hard to measure, but +seemed to be less than 0.2% if anything at all. + +It seems tempting to do the same for -fspecialize-aggressively, but that comes in +at a hefty 20% compile time overhead. So we only provide the unfoldings and leave +the choice of how much specialization to enable up to the user. + -} {- ===================================== docs/users_guide/using-optimisation.rst ===================================== @@ -624,10 +624,10 @@ as such you shouldn't need to set any of them explicitly. A flag :reverse: -fno-expose-overloaded-unfoldings :category: - :default: off + :default: -O and above :since: 9.12.1 - This experimental flag is a slightly less heavy weight alternative + This flag is a slightly less heavy weight alternative to :ghc-flag:`-fexpose-all-unfoldings`. Instead of exposing all functions it exposes only those functions which ===================================== testsuite/tests/dmdanal/should_compile/T23398.stderr ===================================== @@ -40,7 +40,9 @@ T23398.$wbar [InlPrag=[2], Occ=LoopBreaker] [GblId[StrictWorker([~, !])], Arity=4, Str=<L><SP(A,SC(S,L),A)><1L><L>, - Unf=OtherCon []] + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [0 90 60 0] 91 70}] T23398.$wbar = \ (@a) (@b) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1077867aa7ee380599145d4634198b1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1077867aa7ee380599145d4634198b1… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/apk/unfold-dicts] Tweak inlining discout for unary class ops.
by Andreas Klebinger (＠AndreasK) 30 Sep '26

30 Sep '26

Andreas Klebinger pushed to branch wip/apk/unfold-dicts at Glasgow Haskell Compiler / GHC Commits: f84c3214 by Andreas Klebinger at 2026-09-30T15:49:21+00:00 Tweak inlining discout for unary class ops. Correctly account for arguments applied to the result of the class op application when computing rhs size for unary classes. I also fixed handling of casts/ticks while in the area. Fixes #27802 Fixes #27818 ------------------------- Metric Decrease: CoOpt_Singletons T13056 Metric Increase: T12234 T21839c T21839r T16473 T5321FD T5321Fun hard_hole_fits T18223 ------------------------- - - - - - 14 changed files: - + changelog.d/T27802-classop-arg-size - + changelog.d/T27818-unfolding-size-casts-ticks - compiler/GHC/Core/Unfold.hs - testsuite/tests/arityanal/should_compile/Arity01.stderr - testsuite/tests/arityanal/should_compile/Arity05.stderr - testsuite/tests/arityanal/should_compile/Arity08.stderr - testsuite/tests/arityanal/should_compile/Arity11.stderr - testsuite/tests/arityanal/should_compile/Arity14.stderr - testsuite/tests/deSugar/should_compile/T16615.stderr - testsuite/tests/dmdanal/should_compile/T23398.stderr - testsuite/tests/ghci.debugger/scripts/break021.stdout - testsuite/tests/perf/compiler/T25723.hs - testsuite/tests/simplCore/should_compile/T15205.stderr - testsuite/tests/simplCore/should_compile/T26117.stderr Changes: ===================================== changelog.d/T27802-classop-arg-size ===================================== @@ -0,0 +1,11 @@ +section: compiler +issues: #27802 +mrs: !16675 +synopsis: + Account for arguments applied to unary class methods when computing unfolding size. +description: { + Due to a bug we considered the application of arguments to a unary class method free + during expression size calculation. We now accurately calculate the discount again. + + This might make some functions heavy on single-class method use no longer inline. +} ===================================== changelog.d/T27818-unfolding-size-casts-ticks ===================================== @@ -0,0 +1,5 @@ +section: compiler +issues: #27818 +mrs: !16675 +synopsis: + Fixed a bug that caused newtypes and cost centres to affect inlining decisions. ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -335,6 +335,10 @@ isValFun :: CoreExpr -> Bool -- one top-level value lambda isValFun (Lam b e) | isRuntimeVar b = True | otherwise = isValFun e +-- A tick can be code which *can* change the runtime semantics here. +-- But we want to ignore it anyway. See Note [Ticks and Cast should not impact unfolding guidance] +isValFun (Tick _t e) = isValFun e +isValFun (Cast e _co) = isValFun e isValFun _ = False calcUnfoldingGuidance @@ -669,6 +673,11 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr is_inline_scrut (Var v) = isUnliftedType (idType v) -- isUnliftedType is OK here: scrutinees have a fixed RuntimeRep (search for FRRCase) + -- Even if this makes the check technically wrong we want to + -- look through ticks here. + -- See Note [Ticks and Cast should not impact unfolding guidance] + is_inline_scrut (Tick _t e) = is_inline_scrut e + is_inline_scrut (Cast e _co) = is_inline_scrut e is_inline_scrut scrut | (Var f, _) <- collectArgs scrut = case idDetails f of @@ -709,7 +718,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr FCallId _ -> sizeN (callSize (length val_args) voids) DataConWorkId dc -> conSize dc (length val_args) PrimOpId op _ -> primOpSize op (length val_args) - ClassOpId cls _ -> classOpSize opts cls top_args val_args + ClassOpId cls _ -> classOpSize opts cls top_args val_args voids _ | fun `hasKey` buildIdKey -> buildSize | fun `hasKey` augmentIdKey -> augmentSize | otherwise -> funSize opts top_args fun (length val_args) voids @@ -761,9 +770,11 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr -- and typePrimRep will crash isZeroBitId id = not (isJoinId id) && isZeroBitTy (idType id) - isZeroBitExpr (Var id) = isZeroBitId id - isZeroBitExpr (Tick _ e) = isZeroBitExpr e - isZeroBitExpr _ = False + -- [Ticks and Cast should not impact unfolding guidance] + isZeroBitExpr (Var id) = isZeroBitId id + isZeroBitExpr (Tick _t e) = isZeroBitExpr e + isZeroBitExpr (Cast e _co) = isZeroBitExpr e + isZeroBitExpr _ = False -- | Finds a nominal size of a string literal. litSize :: Literal -> Int @@ -777,21 +788,31 @@ litSize _other = 0 -- Must match size of nullary constructors -- Key point: if x |-> 4, then x must inline unconditionally -- (eg via case binding) -classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize +classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> Int -> ExprSize -- See (IA1) in Note [Interesting arguments] in GHC.Core.Opt.Simplify.Utils -classOpSize _opts _cls _top_args [] +classOpSize _opts _cls _top_args [] _voids = sizeZero -- A non-applied classop -classOpSize opts cls top_args (dict_arg:other_val_args) - = SizeIs size (arg_discount dict_arg) 0 +classOpSize opts cls top_args (dict_arg:other_val_args) voids + = SizeIs size dict_arg_discount 0 where - size | isUnaryClass cls = 0 -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon - | otherwise = 20 + (10 * length other_val_args) + -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon + op_app_size = if isUnaryClass cls then 0 else 20 + + -- Size penalty for applying the extracted class method to it's + -- arguments. + method_app_size + | null other_val_args = 0 -- we don't actually apply the result + | otherwise = callSize (length other_val_args) voids + + size = op_app_size + method_app_size -- If the class op is scrutinising a lambda bound dictionary then -- give it a discount, to encourage the inlining of this function - arg_discount (Cast arg _co) = arg_discount arg - arg_discount (Var dict) | dict `elem` top_args = unitBag (dict, dict_discount) - arg_discount _ = emptyBag + dict_arg_discount = case getIdFromTrivialExpr_maybe dict_arg of + Nothing -> emptyBag + Just var + | var `elem` top_args -> unitBag (var, dict_discount) + | otherwise -> emptyBag -- If we have (class-op d arg1 .. argn) then it's super-good to inline -- to expose `d`; not only can we do the dictionary selection @@ -1051,6 +1072,23 @@ In a function application (f a b) get a saturated application) Code for manipulating sizes + +Note [Ticks and Cast should not impact unfolding guidance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to ignore ticks and casts when +computing unfolding guidance. The reason is simple: + +We want inlining to be robust if a user changes a type alias +to a newtype, if the code is otherwise the same. + +Similarly we want inlining to behave the same for a core expression +(<tick> e) as it does for `e`. +This is **independent** of the kind of tick we are dealing with. +Even for ticks that represent code at runtime we generally want +to inline as-if no tick is present. This way profiled code will +be closer to non-profiled code, which leads to more accurate profiles. + +So we take care to look through Cast/Ticks wherever possible. -} -- | The size of a candidate expression for unfolding ===================================== testsuite/tests/arityanal/should_compile/Arity01.stderr ===================================== @@ -45,7 +45,7 @@ F1.s1 = GHC.Internal.Bignum.Integer.IS 3# -- RHS size: {terms: 8, types: 7, coercions: 0, joins: 0/0} s :: forall {t1} {t2}. Num t1 => (t1 -> t2) -> t2 -[GblId, Arity=2, Str=<MP(A,A,A,A,A,A,1C(1,L))><1C(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 60] 50 0}] +[GblId, Arity=2, Str=<MP(A,A,A,A,A,A,1C(1,L))><1C(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 60] 60 0}] s = \ (@t) (@t1) ($dNum :: Num t) (f :: t -> t1) -> f (fromInteger @t $dNum F1.s1) -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} ===================================== testsuite/tests/arityanal/should_compile/Arity05.stderr ===================================== @@ -9,12 +9,12 @@ F5.f5g1 = GHC.Internal.Bignum.Integer.IS 1# -- RHS size: {terms: 12, types: 9, coercions: 0, joins: 0/0} f5g :: forall {a} {t}. Num a => (t -> a) -> t -> a -[GblId, Arity=3, Str=<SP(1C(1,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 60 0] 90 0}] +[GblId, Arity=3, Str=<SP(1C(1,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 60 0] 110 0}] f5g = \ (@a) (@t) ($dNum :: Num a) (h :: t -> a) (z :: t) -> + @a $dNum (h z) (fromInteger @a $dNum F5.f5g1) -- RHS size: {terms: 17, types: 12, coercions: 0, joins: 0/0} f5h :: forall {a} {t}. Num a => (t -> a) -> t -> (t -> a) -> a -[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L><MC(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 60 0 60] 150 0}] +[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A,A,A,A,A,MC(1,L))><MC(1,L)><L><MC(1,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 60 0 60] 180 0}] f5h = \ (@a) (@t) ($dNum :: Num a) (f :: t -> a) (x :: t) (g :: t -> a) -> + @a $dNum (f x) (+ @a $dNum (g x) (fromInteger @a $dNum F5.f5g1)) -- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0} ===================================== testsuite/tests/arityanal/should_compile/Arity08.stderr ===================================== @@ -3,12 +3,12 @@ Result size of Tidy Core = {terms: 24, types: 18, coercions: 0, joins: 0/0} -- RHS size: {terms: 20, types: 10, coercions: 0, joins: 0/0} -f8f :: forall {p}. Num p => Bool -> p -> p -> p -[GblId, Arity=4, Str=<LP(SC(S,C(1,L)),A,MC(1,C(1,L)),A,A,A,A)><1L><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 30 0 0] 140 0}] +f8f :: forall {a}. Num a => Bool -> a -> a -> a +[GblId, Arity=4, Str=<LP(SC(S,C(1,L)),A,MC(1,C(1,L)),A,A,A,A)><1L><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [270 30 0 0] 170 0}] f8f - = \ (@p) ($dNum :: Num p) (b :: Bool) (x :: p) (y :: p) -> + = \ (@a) ($dNum :: Num a) (b :: Bool) (x :: a) (y :: a) -> case b of { - False -> + @p $dNum (+ @p $dNum x y) (* @p $dNum x x); + False -> + @a $dNum (+ @a $dNum x y) (* @a $dNum x x); True -> y } ===================================== testsuite/tests/arityanal/should_compile/Arity11.stderr ===================================== @@ -19,7 +19,7 @@ F11.fib1 = GHC.Internal.Bignum.Integer.IS 0# -- RHS size: {terms: 54, types: 27, coercions: 0, joins: 0/5} fib :: forall {t1} {t2}. (Eq t1, Num t1, Num t2) => t1 -> t2 -[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A)><LP(A,LC(L,C(1,L)),A,A,A,A,L)><LP(LC(S,C(1,L)),A,A,A,A,A,MC(1,L))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 450 180 0] 480 0}] +[GblId, Arity=4, Str=<SP(SC(S,C(1,L)),A)><LP(A,LC(L,C(1,L)),A,A,A,A,L)><LP(LC(S,C(1,L)),A,A,A,A,A,MC(1,L))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [180 450 180 0] 570 0}] fib = \ (@t) (@t1) ($dEq :: Eq t) ($dNum :: Num t) ($dNum1 :: Num t1) (eta :: t) -> let { @@ -105,7 +105,7 @@ F11.f11f1 = \ (y :: Integer) -> GHC.Internal.Bignum.Integer.integerAdd F11.f11_x -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} f11f :: forall {p}. p -> Integer -> Integer [GblId, Arity=2, Str=<A><SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)}] -f11f = \ (@p) _ [Occ=Dead] -> F11.f11f1 +f11f = \ (@p) (z [Occ=Dead] :: p) -> F11.f11f1 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} F11.f5 :: Integer ===================================== testsuite/tests/arityanal/should_compile/Arity14.stderr ===================================== @@ -14,7 +14,7 @@ F14.f2 = GHC.Internal.Bignum.Integer.IS 1# -- RHS size: {terms: 36, types: 23, coercions: 0, joins: 0/3} f14 :: forall {t}. (Ord t, Num t) => t -> t -> t -> t -[GblId, Arity=4, Str=<SP(A,A,SC(S,C(1,L)),A,A,A,A,A)><LP(LC(L,C(1,L)),A,A,A,A,A,MC(1,L))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 270 0 0] 310 0}] +[GblId, Arity=4, Str=<SP(A,A,SC(S,C(1,L)),A,A,A,A,A)><LP(LC(L,C(1,L)),A,A,A,A,A,MC(1,L))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 270 0 0] 350 0}] f14 = \ (@t) ($dOrd :: Ord t) ($dNum :: Num t) (eta :: t) (eta1 :: t) -> let { ===================================== testsuite/tests/deSugar/should_compile/T16615.stderr ===================================== @@ -9,7 +9,7 @@ g :: Int -> Bool [LclIdX, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [0] 120 10}] + Guidance=IF_ARGS [0] 140 10}] g = \ (i :: Int) -> case == @Int GHC.Internal.Classes.$fEqInt i (GHC.Internal.Types.I# 0#) @@ -23,7 +23,7 @@ f [Occ=LoopBreaker] :: Int -> Bool [LclIdX, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [0] 120 10}] + Guidance=IF_ARGS [0] 140 10}] f = \ (i :: Int) -> case == @Int GHC.Internal.Classes.$fEqInt i (GHC.Internal.Types.I# 0#) ===================================== testsuite/tests/dmdanal/should_compile/T23398.stderr ===================================== @@ -10,7 +10,7 @@ foo :: forall a. PairDict a => a -> a -> String Str=<SP(SP(1C(1,C(1,L)),A),SP(A,1C(1,L),A))><L><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [90 0 0] 180 0}] + Guidance=IF_ARGS [90 0 0] 210 0}] foo = \ (@a) ($dCTuple2 :: PairDict a) (eta :: a) (eta1 :: a) -> case == ===================================== testsuite/tests/ghci.debugger/scripts/break021.stdout ===================================== @@ -41,7 +41,7 @@ _result :: IO () = _ ^^^^^^^^^^^^^^^^^ 13 in_another_module 0 Stopped in Main.in_another_decl, break020.hs:(6,21)-(7,30) -_result :: IO () = _ +_result :: m () = _ 5 vv 6 in_another_decl _ = do line1 0 @@ -49,25 +49,25 @@ _result :: IO () = _ ^^ 8 Stopped in Main.in_another_decl, break020.hs:6:24-30 -_result :: IO () = _ +_result :: m () = _ 5 6 in_another_decl _ = do line1 0 ^^^^^^^ 7 line2 0 Stopped in Main.line1, break020.hs:3:11-19 -_result :: IO () = _ +_result :: m () = _ 2 3 line1 _ = return () ^^^^^^^^^ 4 line2 _ = return () Stopped in Main.in_another_decl, break020.hs:7:24-30 -_result :: IO () = _ +_result :: m () = _ 6 in_another_decl _ = do line1 0 7 line2 0 ^^^^^^^ 8 Stopped in Main.line2, break020.hs:4:11-19 -_result :: IO () = _ +_result :: m () = _ 3 line1 _ = return () 4 line2 _ = return () ^^^^^^^^^ ===================================== testsuite/tests/perf/compiler/T25723.hs ===================================== @@ -9,6 +9,12 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -flate-specialise -O2 #-} +-- The purpose of this test it to ensure we get a nice recursive loop inside main. +-- Where otherwise we would allocate a intermediate tuple if we fail to inline a join +-- point (#25723). +-- As unfolding guidance changed the join point never materialized so we use a +-- different threshold to ensure we still test the expect behaviour. +{-# OPTIONS_GHC -funfolding-use-threshold=120 #-} module Main (main) where ===================================== testsuite/tests/simplCore/should_compile/T15205.stderr ===================================== @@ -10,7 +10,7 @@ f :: forall a b. C a b => a -> b Str=<1P(A,1C(1,C(1,L)))><L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [90 0] 40 0}] + Guidance=IF_ARGS [90 0] 50 0}] f = \ (@a) (@b) ($dC :: C a b) (eta :: a) -> op @a @b $dC eta eta ===================================== testsuite/tests/simplCore/should_compile/T26117.stderr ===================================== @@ -6,83 +6,7 @@ T26117.hs:17:10: warning: [GHC-06201] [-Wmissing-methods (in -Wdefault)] ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 196, types: 296, coercions: 2, joins: 0/0} - --- RHS size: {terms: 7, types: 18, coercions: 0, joins: 0/0} -op1 [InlPrag=[~]] :: forall a b. C a b => F a -> a -> b -> Int -[GblId[ClassOp], - Arity=1, - Str=<S!P(SL,A)>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: C a b) -> - case v of { T26117.C:C v2 [Occ=Once1] _ [Occ=Dead] -> v2 }}] -op1 - = \ (@a) (@b) (v :: C a b) -> - case v of v1 { T26117.C:C v2 v3 -> v2 } - --- RHS size: {terms: 7, types: 18, coercions: 0, joins: 0/0} -op2 [InlPrag=[~]] :: forall a b. C a b => F a -> a -> b -> Int -[GblId[ClassOp], - Arity=1, - Str=<S!P(A,SL)>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: C a b) -> - case v of { T26117.C:C _ [Occ=Dead] v3 [Occ=Once1] -> v3 }}] -op2 - = \ (@a) (@b) (v :: C a b) -> - case v of v1 { T26117.C:C v2 v3 -> v3 } - --- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} -T26117.$p1D [InlPrag=[~]] :: forall a b. D a b => Eq (F a) -[GblId[ClassOp], - Arity=1, - Str=<S!P(SL,A,A)>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> - case v of { T26117.C:D v2 [Occ=Once1] _ [Occ=Dead] _ [Occ=Dead] -> - v2 - }}] -T26117.$p1D - = \ (@a) (@b) (v :: D a b) -> - case v of v1 { T26117.C:D v2 v3 v4 -> v2 } - --- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} -dop1 [InlPrag=[~]] :: forall a b. D a b => a -> b -> b -[GblId[ClassOp], - Arity=1, - Str=<S!P(A,SL,A)>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> - case v of { T26117.C:D _ [Occ=Dead] v3 [Occ=Once1] _ [Occ=Dead] -> - v3 - }}] -dop1 - = \ (@a) (@b) (v :: D a b) -> - case v of v1 { T26117.C:D v2 v3 v4 -> v3 } - --- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} -dop2 [InlPrag=[~]] :: forall a b. D a b => a -> b -> b -[GblId[ClassOp], - Arity=1, - Str=<S!P(A,A,SL)>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) - Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> - case v of { T26117.C:D _ [Occ=Dead] _ [Occ=Dead] v4 [Occ=Once1] -> - v4 - }}] -dop2 - = \ (@a) (@b) (v :: D a b) -> - case v of v1 { T26117.C:D v2 v3 v4 -> v4 } + = {terms: 153, types: 148, coercions: 2, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T26117.$fCaList1 :: GHC.Internal.Prim.Addr# @@ -92,28 +16,6 @@ T26117.$fCaList1 :: GHC.Internal.Prim.Addr# Guidance=IF_ARGS [] 70 0}] T26117.$fCaList1 = "T26117.hs:17:10-37|\CANop2\EM"# --- RHS size: {terms: 6, types: 15, coercions: 0, joins: 0/0} -T26117.$fCaList_$cop2 [InlPrag=[2]] - :: forall a b. (Eq (F a), D a b) => F a -> a -> [b] -> Int -[GblId, - Arity=2, - Str=<B><B>b, - Cpr=b, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True) - Tmpl= \ (@a) (@b) _ [Occ=Dead] _ [Occ=Dead] -> - GHC.Internal.Control.Exception.Base.noMethodBindingError - @GHC.Internal.Types.LiftedRep - @(F a -> a -> [b] -> Int) - T26117.$fCaList1}] -T26117.$fCaList_$cop2 - = \ (@a) (@b) _ [Occ=Dead] _ [Occ=Dead] -> - GHC.Internal.Control.Exception.Base.noMethodBindingError - @GHC.Internal.Types.LiftedRep - @(F a -> a -> [b] -> Int) - T26117.$fCaList1 - -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T26117.$fCaList3 :: Int [GblId, @@ -130,11 +32,48 @@ T26117.$fCaList2 :: Int Guidance=IF_ARGS [] 10 10}] T26117.$fCaList2 = GHC.Internal.Types.I# 3# +-- RHS size: {terms: 16, types: 16, coercions: 0, joins: 0/0} +T26117.$fCaList_$cop1 + :: forall a b. (Eq (F a), D a b) => F a -> a -> [b] -> Int +[GblId, + Arity=5, + Str=<1P(1C(1,C(1,L)),A)><A><L><A><A>, + Cpr=1, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=5,unsat_ok=True,boring_ok=False) + Tmpl= \ (@a) + (@b) + ($dEq [Occ=Once1] :: Eq (F a)) + ($dD [Occ=Dead] :: D a b) + (x :: F a) + (ds [Occ=Dead] :: a) + (ds1 [Occ=Dead] :: [b]) -> + case == @(F a) $dEq x x of { + False -> T26117.$fCaList3; + True -> T26117.$fCaList2 + }}] +T26117.$fCaList_$cop1 + = \ (@a) + (@b) + ($dEq :: Eq (F a)) + ($dD [Occ=Dead, OS=OneShot] :: D a b) + (x :: F a) + (ds [Occ=Dead] :: a) + (ds1 [Occ=Dead] :: [b]) -> + case == @(F a) $dEq x x of { + False -> T26117.$fCaList3; + True -> T26117.$fCaList2 + } + -- RHS size: {terms: 8, types: 7, coercions: 2, joins: 0/0} lvl :: forall b. F Int -> Int -> [b] -> Int -[GblId, Arity=3, Str=<1A><A><A>, Cpr=1, Unf=OtherCon []] +[GblId, Arity=3, Str=<SL><A><A>, Cpr=1, Unf=OtherCon []] lvl - = \ (@b) (x :: F Int) _ [Occ=Dead] _ [Occ=Dead] -> + = \ (@b) + (x :: F Int) + (ds [Occ=Dead] :: Int) + (ds1 [Occ=Dead] :: [b]) -> case x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool) of lwild { __DEFAULT -> T26117.$fCaList2 @@ -164,7 +103,7 @@ T26117.$fCaList_$s$fCaList [InlPrag=CONLIKE] Unf=DFun: \ (@b) ($dD :: D Int b) -> T26117.C:C TYPE: Int TYPE: [b] - \ (x :: F Int) _ [Occ=Dead] _ [Occ=Dead] -> + \ (x :: F Int) (ds [Occ=Dead] :: Int) (ds1 [Occ=Dead] :: [b]) -> case GHC.Internal.Prim.dataToTagSmall# @GHC.Internal.Types.Lifted @Bool @@ -187,19 +126,10 @@ T26117.$fCaList_$s$fCaList [InlPrag=CONLIKE] @GHC.Internal.Types.LiftedRep @(F Int -> Int -> [b] -> Int) "T26117.hs:17:10-37|\CANop2\EM"#] -T26117.$fCaList_$s$fCaList = \ (@b) _ [Occ=Dead] -> lvl2 @b - --- RHS size: {terms: 4, types: 9, coercions: 0, joins: 0/0} -lvl3 :: forall b a. F a -> a -> [b] -> Int -[GblId, Str=b, Cpr=b] -lvl3 - = \ (@b) (@a) -> - GHC.Internal.Control.Exception.Base.noMethodBindingError - @GHC.Internal.Types.LiftedRep - @(F a -> a -> [b] -> Int) - T26117.$fCaList1 +T26117.$fCaList_$s$fCaList + = \ (@b) ($dD [Occ=Dead] :: D Int b) -> lvl2 @b --- RHS size: {terms: 18, types: 21, coercions: 0, joins: 0/0} +-- RHS size: {terms: 10, types: 20, coercions: 0, joins: 0/0} T26117.$fCaList [InlPrag=CONLIKE] :: forall a b. (Eq (F a), D a b) => C a [b] [GblId[DFunId], @@ -208,225 +138,203 @@ T26117.$fCaList [InlPrag=CONLIKE] Unf=DFun: \ (@a) (@b) (v :: Eq (F a)) (v1 :: D a b) -> T26117.C:C TYPE: a TYPE: [b] - \ (x :: F a) _ [Occ=Dead] _ [Occ=Dead] -> - case == @(F a) v x x of { - False -> T26117.$fCaList3; - True -> T26117.$fCaList2 - } - T26117.$fCaList_$cop2 @a @b v v1] + T26117.$fCaList_$cop1 @a @b v v1 + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F a -> a -> [b] -> Int) + T26117.$fCaList1] T26117.$fCaList - = \ (@a) (@b) ($dEq :: Eq (F a)) _ [Occ=Dead] -> + = \ (@a) (@b) ($dEq :: Eq (F a)) ($dD :: D a b) -> T26117.C:C @a @[b] - (\ (x :: F a) _ [Occ=Dead] _ [Occ=Dead] -> - case == @(F a) $dEq x x of { - False -> T26117.$fCaList3; - True -> T26117.$fCaList2 - }) - (lvl3 @b @a) + (T26117.$fCaList_$cop1 @a @b $dEq $dD) + (GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F a -> a -> [b] -> Int) + T26117.$fCaList1) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T26117.$trModule4 :: GHC.Internal.Prim.Addr# -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 20 0}] -T26117.$trModule4 = "main"# +$trModule1 :: GHC.Internal.Prim.Addr# +[GblId, Unf=OtherCon []] +$trModule1 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T26117.$trModule3 :: GHC.Internal.Types.TrName -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$trModule3 = GHC.Internal.Types.TrNameS T26117.$trModule4 +$trModule2 :: GHC.Internal.Types.TrName +[GblId, Unf=OtherCon []] +$trModule2 = GHC.Internal.Types.TrNameS $trModule1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T26117.$trModule2 :: GHC.Internal.Prim.Addr# -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 30 0}] -T26117.$trModule2 = "T26117"# +$trModule3 :: GHC.Internal.Prim.Addr# +[GblId, Unf=OtherCon []] +$trModule3 = "T26117"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T26117.$trModule1 :: GHC.Internal.Types.TrName -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$trModule1 = GHC.Internal.Types.TrNameS T26117.$trModule2 +$trModule4 :: GHC.Internal.Types.TrName +[GblId, Unf=OtherCon []] +$trModule4 = GHC.Internal.Types.TrNameS $trModule3 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T26117.$trModule :: GHC.Internal.Types.Module -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$trModule - = GHC.Internal.Types.Module T26117.$trModule3 T26117.$trModule1 +T26117.$trModule [InlPrag=[~]] :: GHC.Internal.Types.Module +[GblId, Unf=OtherCon []] +T26117.$trModule = GHC.Internal.Types.Module $trModule2 $trModule4 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} $krep :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] $krep = GHC.Internal.Types.KindRepFun - GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint + GHC.Internal.Types.KindRepType GHC.Internal.Types.KindRepConstraint -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T26117.$tcC1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep +$krep1 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -T26117.$tcC1 - = GHC.Internal.Types.KindRepFun GHC.Internal.Types.krep$* $krep +$krep1 + = GHC.Internal.Types.KindRepFun + GHC.Internal.Types.KindRepType $krep -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$krep1 :: GHC.Internal.Types.KindRep +$krep2 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep1 = GHC.Internal.Types.KindRepVar 1# +$krep2 = GHC.Internal.Types.KindRepVar 1# -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep2 :: GHC.Internal.Types.KindRep +$krep3 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep2 = GHC.Internal.Types.KindRepFun $krep1 $krep1 +$krep3 = GHC.Internal.Types.KindRepFun $krep2 $krep2 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$krep3 :: GHC.Internal.Types.KindRep +$krep4 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep3 = GHC.Internal.Types.KindRepVar 0# +$krep4 = GHC.Internal.Types.KindRepVar 0# -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep4 :: GHC.Internal.Types.KindRep +$krep5 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep4 = GHC.Internal.Types.KindRepFun $krep3 $krep2 +$krep5 = GHC.Internal.Types.KindRepFun $krep4 $krep3 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T26117.$tcD2 :: GHC.Internal.Prim.Addr# -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 20 0}] -T26117.$tcD2 = "D"# +$tcD1 :: GHC.Internal.Prim.Addr# +[GblId, Unf=OtherCon []] +$tcD1 = "D"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T26117.$tcD1 :: GHC.Internal.Types.TrName -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$tcD1 = GHC.Internal.Types.TrNameS T26117.$tcD2 +$tcD2 :: GHC.Internal.Types.TrName +[GblId, Unf=OtherCon []] +$tcD2 = GHC.Internal.Types.TrNameS $tcD1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T26117.$tcD :: GHC.Internal.Types.TyCon -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] +T26117.$tcD [InlPrag=[~]] :: GHC.Internal.Types.TyCon +[GblId, Unf=OtherCon []] T26117.$tcD = GHC.Internal.Types.TyCon 18427868686024955676#Word64 4087453451394481638#Word64 T26117.$trModule - T26117.$tcD1 + $tcD2 0# - T26117.$tcC1 + $krep1 -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} -$krep5 :: [GHC.Internal.Types.KindRep] +$krep6 :: [GHC.Internal.Types.KindRep] [GblId, Unf=OtherCon []] -$krep5 +$krep6 = GHC.Internal.Types.: @GHC.Internal.Types.KindRep - $krep1 + $krep2 (GHC.Internal.Types.[] @GHC.Internal.Types.KindRep) -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} -$krep6 :: [GHC.Internal.Types.KindRep] +$krep7 :: [GHC.Internal.Types.KindRep] [GblId, Unf=OtherCon []] -$krep6 - = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep3 $krep5 +$krep7 + = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep4 $krep6 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep7 :: GHC.Internal.Types.KindRep +$krep8 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep7 = GHC.Internal.Types.KindRepTyConApp T26117.$tcD $krep6 +$krep8 = GHC.Internal.Types.KindRepTyConApp T26117.$tcD $krep7 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -$krep8 :: GHC.Internal.Types.KindRep +$krep9 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -$krep8 = GHC.Internal.Types.KindRepFun $krep4 $krep7 +$krep9 = GHC.Internal.Types.KindRepFun $krep5 $krep8 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} -T26117.$tc'C:D1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep +$krep10 :: GHC.Internal.Types.KindRep [GblId, Unf=OtherCon []] -T26117.$tc'C:D1 = GHC.Internal.Types.KindRepFun $krep4 $krep8 +$krep10 = GHC.Internal.Types.KindRepFun $krep5 $krep9 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T26117.$tc'C:D3 :: GHC.Internal.Prim.Addr# -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 20 0}] -T26117.$tc'C:D3 = "'C:D"# +$tc'C:D1 :: GHC.Internal.Prim.Addr# +[GblId, Unf=OtherCon []] +$tc'C:D1 = "'C:D"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T26117.$tc'C:D2 :: GHC.Internal.Types.TrName -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$tc'C:D2 = GHC.Internal.Types.TrNameS T26117.$tc'C:D3 +$tc'C:D2 :: GHC.Internal.Types.TrName +[GblId, Unf=OtherCon []] +$tc'C:D2 = GHC.Internal.Types.TrNameS $tc'C:D1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T26117.$tc'C:D :: GHC.Internal.Types.TyCon -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] +T26117.$tc'C:D [InlPrag=[~]] :: GHC.Internal.Types.TyCon +[GblId, Unf=OtherCon []] T26117.$tc'C:D = GHC.Internal.Types.TyCon 14714477993590114477#Word64 17388374250742016296#Word64 T26117.$trModule - T26117.$tc'C:D2 + $tc'C:D2 2# - T26117.$tc'C:D1 + $krep10 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T26117.$tcC3 :: GHC.Internal.Prim.Addr# -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 20 0}] -T26117.$tcC3 = "C"# +$tcC1 :: GHC.Internal.Prim.Addr# +[GblId, Unf=OtherCon []] +$tcC1 = "C"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T26117.$tcC2 :: GHC.Internal.Types.TrName -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] -T26117.$tcC2 = GHC.Internal.Types.TrNameS T26117.$tcC3 +$tcC2 :: GHC.Internal.Types.TrName +[GblId, Unf=OtherCon []] +$tcC2 = GHC.Internal.Types.TrNameS $tcC1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} -T26117.$tcC :: GHC.Internal.Types.TyCon -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [] 10 10}] +T26117.$tcC [InlPrag=[~]] :: GHC.Internal.Types.TyCon +[GblId, Unf=OtherCon []] T26117.$tcC = GHC.Internal.Types.TyCon 6116531860557468422#Word64 17953227584944457497#Word64 T26117.$trModule - T26117.$tcC2 + $tcC2 0# - T26117.$tcC1 + $krep1 ------ Local rules for imported ids -------- +"USPEC $cop1 @Int @_" + forall (@b) ($dEq [Occ=Dead] :: Eq (F Int)) ($dD :: D Int b). + T26117.$fCaList_$cop1 @Int @b $dEq $dD + = \ (x :: F Int) (ds [Occ=Dead] :: Int) (ds1 [Occ=Dead] :: [b]) -> + case GHC.Internal.Prim.dataToTagSmall# + @GHC.Internal.Types.Lifted + @Bool + (x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool)) + of a# [Occ=Once1] + { __DEFAULT -> + case GHC.Internal.Prim.dataToTagSmall# + @GHC.Internal.Types.Lifted + @Bool + (x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool)) + of b# [Occ=Once1] + { __DEFAULT -> + case GHC.Internal.Prim.==# a# b# of { + __DEFAULT -> GHC.Internal.Types.I# 4#; + 1# -> GHC.Internal.Types.I# 3# + } + } + } "USPEC $fCaList @Int @_" - forall (@b) ($dD :: D Int b) ($dEq :: Eq (F Int)). + forall (@b) ($dEq [Occ=Dead] :: Eq (F Int)) ($dD :: D Int b). T26117.$fCaList @Int @b $dEq $dD = T26117.$fCaList_$s$fCaList @b $dD View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f84c3214bbd23fbb9d46ad678285654… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f84c3214bbd23fbb9d46ad678285654… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/T27844] Refactor and simplify solver's unification code
by Simon Peyton Jones (＠simonpj) 30 Sep '26

30 Sep '26

Simon Peyton Jones pushed to branch wip/T27844 at Glasgow Haskell Compiler / GHC Commits: ba80e8ee by Simon Peyton Jones at 2026-09-30T16:34:45+01:00 Refactor and simplify solver's unification code Ticket #27844 showed that GHC's constraint solver could miss an occurs check, and thereby build an infinite type. This patch significantly simplifes the code in GHC.Tc.Solver.Equality.canEqCanLHSFinish_try_unification GHC.Tc.Solver.Equality.canEqCanLHSFinish_no_unification It is now significantly simpler, and requires much less subtle reasoning to understand. Main changes * If `canEqCanLHSFinish_try_unification` fails to unify, it now /always/ calls `canEqCanLHSFinish_no_unification` rather than trying to finish the job itself. * `GHC.Tc.Solver.Monad.checkTypeEq` is moved from Monad into Equality, and renamed to `GHC.Tc.Solver.Equality.checkTypeEqNoUnification`. * `canEqCanLHSFinish_no_unification` calls `checkTypeEqNoUnification` to test the invariants for an inert equality. Before this MR there was a special case for `do_not_prevent_rewriting`, but that has gone; instead it's just a consequence of the flags passed to `checkTyEqRhs`, documented in the `PuOK` case of `canEqCanLHSFinish_no_unification`. * There is only one bit of "swap back" code, in `finish_no_unify` in `canEqCanLHSFinish_try_unification. Previously this code was duplicated. * `kickOutAfterFillingCoercionHole` should account for equalities with a TyFamLHS. See (KOC5) in Note [Kick out after filling a coercion hole] * No need to gather coercion holes in the `PuOK` case of `canEqCanLHSFinish_no_unification`. See documentation with that code. - - - - - 12 changed files: - + changelog.d/T27844 - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/Unify.hs - testsuite/tests/indexed-types/should_fail/T9662.stderr - + testsuite/tests/typecheck/should_fail/T27844.hs - + testsuite/tests/typecheck/should_fail/T27844.stderr - testsuite/tests/typecheck/should_fail/all.T Changes: ===================================== changelog.d/T27844 ===================================== @@ -0,0 +1,9 @@ +section: compiler +issues: #27844 +mrs: !16723 +synopsis: + Reinstate a missing occurs check in the constraint solver +description: + Simplifies code in GHC's type-constraint solver, thereby fixing an outright + compiler loop (via a missing occurs check). + ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -630,7 +630,7 @@ be sigmas and not taus. ~~~~~~~~~~~~~~~~~~~~~~ In the GHCi debugger we use unification variables whose MetaInfo is RuntimeUnkTv. The special property of a RuntimeUnkTv is that it can -unify with a polytype (see GHC.Tc.Utils.Unify.checkTypeEq). +unify with a polytype (see GHC.Tc.Solver.Equality.checkTypeEqNoUnification). If we don't do this `:print <term>` will fail if the type of <term> has nested `forall`s or `=>`s. ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -478,6 +478,7 @@ mkErrorItem ct -- For this `suppress` stuff see -- Note [Wanteds rewrite Wanteds: rewriter-sets] in GHC.Tc.Types.Constraint + -- especiallly (WRW8) (suppress, m_evdest) = case ctEvidence ct of CtGiven {} -> (False, Nothing) CtWanted (WantedCt { ctev_rewriters = rws, ctev_dest = dest }) ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -21,6 +21,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Origin +import GHC.Tc.Types( TcM ) import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcType import GHC.Tc.Instance.Family ( tcUnwrapNewtype_maybe ) @@ -36,8 +37,8 @@ import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Core -import GHC.Types.Var +import GHC.Types.Var import GHC.Types.Basic import GHC.Types.Name.Reader import GHC.Types.Var.Env @@ -49,6 +50,8 @@ import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Data.Pair +import GHC.Data.Bag + import Control.Monad import Data.Maybe ( isJust, isNothing ) import Data.List ( zip4 ) @@ -406,11 +409,13 @@ canonicaliseEquality -- hold. canonicaliseEquality ev eq_rel ty1 ty2 - = Stage $ do { traceTcS "canonicaliseEquality" $ + = Stage $ do { traceTcS "canonicaliseEquality {" $ vcat [ ppr ev, ppr eq_rel, ppr ty1, ppr ty2 ] ; rdr_env <- getGlobalRdrEnvTcS ; fam_insts <- getFamInstEnvs - ; can_eq_nc initCanEqState rdr_env fam_insts ev eq_rel ty1 ty1 ty2 ty2 } + ; res <- can_eq_nc initCanEqState rdr_env fam_insts ev eq_rel ty1 ty1 ty2 ty2 + ; traceTcS "canonicaliseEquality }" (ppr res) + ; return res } -- | Main worker function for 'canonicaliseEquality'. -- @@ -1822,7 +1827,7 @@ Ticket #10009, a very nasty example: g :: forall a. (UnF (F a) ~ a) => a -> () g _ = f (undefined :: F a) -For g we get [G] g1 : UnF (F a) ~ a +For g we get [G] g1 : UnF (F a) ~ a [W] w1 : UnF (F beta) ~ beta [W] w2 : F a ~ F beta @@ -2205,63 +2210,45 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs , TyVarLHS lhs_tv <- lhs = do { given_eq_lvl <- getInnermostGivenEqLevel ; case simpleUnifyCheck UC_Solver given_eq_lvl lhs_tv rhs of - SUC_CanUnify -> - unify lhs_tv (mkReflRedn Nominal rhs) - SUC_CannotUnify - | Just can_rhs <- canTyFamEqLHS_maybe rhs - -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS] - | otherwise - -> finish_no_unify - SUC_NotSure -> + SUC_CannotUnify -> finish_no_unify + SUC_CanUnify -> do_unification lhs_tv (mkReflRedn Nominal rhs) + SUC_NotSure -> -- We have a touchable unification variable on the left, -- and the top-shape check succeeded. These are both guaranteed -- by the fact that simpleUnifyCheck did not return SUC_CannotUnify. + -- + -- Next, do a fully `checkTyEqRhs` check to see if we can unify + -- See Note [checkTyEqRhs] in GHC.Tc.Utils.Unify do { let flags = unifyingLHSMetaTyVar_TEFTask ev lhs_tv ; check_result <- wrapTcS (checkTyEqRhs flags rhs) + ; traceTcS "canEqCanLHSFinish_try_unification" $ + vcat [ text "lhs" <+> ppr lhs + , text "rhs" <+> ppr rhs + , text "check_result" <+> ppr check_result ] ; case check_result of - PuOK cts rhs_redn -> - do { emitWork cts - ; unify lhs_tv rhs_redn } - PuFail reason - | Just can_rhs <- canTyFamEqLHS_maybe rhs - -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS] - | reason `cterHasOnlyProblems` do_not_prevent_rewriting - -> - -- ContinueWith, to allow using this constraint for - -- rewriting (e.g. alpha[2] ~ beta[3]). - do { new_ev <- rewriteEqEvidenceSwapOnly ev eq_rel swapped lhs rhs - ; continueWith $ Right $ - EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel - , eq_lhs = lhs , eq_rhs = rhs } - } - | otherwise - -> try_irred reason - } + PuFail {} -> finish_no_unify + PuOK cts rhs_redn -> do { emitWork cts + ; do_unification lhs_tv rhs_redn } } } -- Otherwise unification is off the table | otherwise = finish_no_unify where - -- We can't unify, but this equality can go in the inert set - -- and be used to rewrite other constraints. - finish_no_unify = - canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs - - -- We can't unify, and this equality should not be used to rewrite - -- other constraints (e.g. because it has an occurs check). - -- So add it to the inert Irreds. - try_irred reason = - tryIrredInstead reason ev eq_rel swapped lhs rhs - - -- We can't unify as-is, and want to flip the equality around. - -- Example: alpha ~ F tys, flip it around to become the canonical - -- equality f tys ~ alpha. - swap_and_finish tv can_rhs = - swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs - - -- Phew! Finally! We can unify; go ahead and do so. - unify tv rhs_redn = + -- finish_no_unify: abandon the attempt to unify, and instead hand off to + -- canEqCanLHSFinish_no_unification + -- First, though, if we have (tv ~ F tys) + -- swap it over so we get (F tys ~ tv), with `F tys` on the LHS + -- See Note [Orienting TyVarLHS/TyFamLHS] + finish_no_unify + | TyVarLHS lhs_tv <- lhs + , Just can_rhs <- canTyFamEqLHS_maybe rhs + = canEqCanLHSFinish_no_unification ev eq_rel (flipSwap swapped) can_rhs (mkTyVarTy lhs_tv) + | otherwise + = canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs + + -- do_unification: Phew! Finally! We can unify; go ahead and do so. + do_unification tv rhs_redn = do { -- In the common case where rhs_redn is Refl, we don't need to rewrite -- the evidence, even if swapped=IsSwapped. Suppose the original was -- [W] co : Int ~ alpha @@ -2273,7 +2260,8 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs else rewriteEqEvidence ev swapped (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn emptyCoHoleSet - -- emptyCoHoleSet: rhs_redn has no CoercionHoles + -- emptyCoHoleSet: we are about to /solve/ this + -- constraint, so its CoHoleSet doesn't matter ; let tv_ty = mkTyVarTy tv final_rhs = reductionReducedType rhs_redn @@ -2297,45 +2285,44 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs ; return (Stop new_ev (text "Solved by unification")) } --------------------------- --- Unification is off the table canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs - = do { -- Do checkTypeEq to guarantee (TyEq:OC), (TyEq:F) + -- We can't unify, but we can see if this equality can go in the inert set + -- and be used to rewrite other constraints. + -- See Note [Equalities where unification fails] + = do { -- Do checkTypeEqNoUnfication to guarantee (TyEq:OC), (TyEq:F) -- Must do the occurs check even on tyvar/tyvar equalities, -- in case have x ~ (y :: ..x...); this is #12593. - ; check_result <- checkTypeEq ev eq_rel lhs rhs - - ; let lhs_ty = canEqLHSType lhs + ; check_result <- checkTypeEqNoUnification ev eq_rel lhs rhs ; case check_result of PuFail reason - - -- If we had F a ~ G (F a), which gives an occurs check, - -- then swap it to G (F a) ~ F a, which does not - -- However `swap_for_size` above will orient it with (G (F a)) on - -- the left anwyway. `swap_for_rewriting` "wins", but that doesn't - -- matter: in the occurs check case swap_for_rewriting will be moot. - -- TL;DR: the next four lines of code are redundant - -- I'm leaving them here in case they become relevant again --- | TyFamLHS {} <- lhs --- , Just can_rhs <- canTyFamEqLHS_maybe rhs --- , reason `cterHasOnlyProblem` cteSolubleOccurs --- -> swapAndFinish ev eq_rel swapped lhs_ty can_rhs --- | otherwise - - | reason `cterHasOnlyProblems` do_not_prevent_rewriting - -> do { new_ev <- rewriteEqEvidenceSwapOnly ev eq_rel swapped lhs rhs - ; continueWith $ Right $ - EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel - , eq_lhs = lhs , eq_rhs = rhs } - } - - | otherwise - -> tryIrredInstead reason ev eq_rel swapped lhs rhs + -> -- We can't unify, and this equality should not be used to rewrite + -- other constraints (e.g. because it has an occurs check). + -- So add it to the inert Irreds. + do { new_ev <- rewriteEqEvidenceSwapOnly ev eq_rel swapped lhs rhs + ; finishCanWithIrred (NonCanonicalReason reason) new_ev } PuOK new_eqs rhs_redn - -> do { emitWork new_eqs - ; let new_holes = rewriterSetFromCts new_eqs + -> -- Put this constraint into the inert set, so that it will be used + -- to solve or rewrite other constraints. + -- + -- NB: checkTypeEqNoUnification does not check for + -- (b) skolem-escape (tefTyVar_levelCheck = LC_None) + -- (a) concreteness (tefTyVar_concreteCheck = CC_None) + -- So an equality whose only problem is e.g. skolem-escape will + -- return PuOK, will be put in the inert set, will be used for + -- rewriting. That is fine. + -- + -- assertPpr (isEmptyCts new_eqs): + -- checkTypeEqNoUnification does neither promotion nor type-family + -- flattening for Wanteds, and hence creates no equalities to solve + assertPpr (isEmptyCts new_eqs) + (vcat [ text "new_eqs" <+> ppr new_eqs + , text "rhs_redn" <+> ppr rhs_redn + , text "lhs" <+> ppr lhs + , text "rhs" <+> ppr rhs ]) $ + do { let lhs_ty = canEqLHSType lhs lhs_redn = mkReflRedn (eqRelRole eq_rel) lhs_ty - ; new_ev <- rewriteEqEvidence ev swapped lhs_redn rhs_redn new_holes + ; new_ev <- rewriteEqEvidence ev swapped lhs_redn rhs_redn emptyCoHoleSet -- Important: even if the coercion is Refl, -- * new_ev has reductionReducedType on the RHS @@ -2346,45 +2333,56 @@ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs , eq_lhs = lhs , eq_rhs = reductionReducedType rhs_redn } } } --- | Some problems prevent /unification/ but not /rewriting/: --- --- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3] --- we can't unify (skolem-escape); but it /is/ canonical, --- and hence we /can/ use it for rewriting --- --- Concrete-ness: alpha[conc] ~ b[sk] --- We can use it to rewrite; we still have to solve the original -do_not_prevent_rewriting :: CheckTyEqResult -do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<> - cteProblem cteConcrete +checkTypeEqNoUnification :: CtEvidence -> EqRel -> CanEqLHS -> TcType + -> TcS (PuResult Ct Reduction) +-- Used for general CanEqLHSs, when we have decided that we cannot unify +checkTypeEqNoUnification ev eq_rel lhs rhs = + case ev of + CtGiven {} -> + do { traceTcS "checkTypeEqNoUnification (given) {" (vcat [ text "lhs:" <+> ppr lhs + , text "rhs:" <+> ppr rhs ]) + ; check_result <- wrapTcS (checkTyEqRhs given_flags rhs) + ; traceTcS "checkTypeEqNoUnification }" (ppr check_result) + ; case check_result of + PuFail reason -> return (PuFail reason) + PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs + ; emitWork new_givens + ; updInertSet (addCycleBreakerBindings prs) + ; return (pure redn) } } + CtWanted {} -> do { traceTcS "checkTypeEqNoUnification (wanted) {" $ + vcat [ text "lhs:" <+> ppr lhs + , text "rhs:" <+> ppr rhs ] + ; check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs) + ; traceTcS "checkTypeEqNoUnification }" (ppr check_result) + ; return check_result } + where + wanted_flags :: TyEqFlags TcM Ct + wanted_flags = notUnifying_TEFTask occ_prob lhs + -- See Note [Don't cycle-break Wanteds when not unifying] + + given_flags :: TyEqFlags TcM (TcTyVar, TcType) + given_flags = wanted_flags { tef_fam_app = mkTEFA_Break ev eq_rel BreakGiven } + -- TEFA_Break used for: [G] a ~ Maybe (F a) + -- or [G] F a ~ Maybe (F a) + + -- occ_prob: see Note [Occurs check and representational equality] + occ_prob = case eq_rel of + NomEq -> cteInsolubleOccurs + ReprEq -> cteSolubleOccurs + + --------------------------- + mk_new_given :: (TcTyVar, TcType) -> TcS Ct + mk_new_given (new_tv, fam_app) + = mkNonCanonical . CtGiven <$> newGivenEv cb_loc (given_pred, given_term) + where + new_ty = mkTyVarTy new_tv + given_pred = mkNomEqPred fam_app new_ty + given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note ----------------------- -swapAndFinish :: CtEvidence -> EqRel -> SwapFlag - -> TcType -> CanEqLHS -- ty ~ F tys - -> TcS (StopOrContinue (Either unused EqCt)) --- We have an equality alpha ~ F tys, that we can't unify e.g because 'tys' --- mentions alpha, it would not be a canonical constraint as-is. --- We want to flip it to (F tys ~ a), whereupon it is canonical -swapAndFinish ev eq_rel swapped lhs_ty can_rhs - = do { new_ev <- rewriteEqEvidenceSwapOnly ev eq_rel (flipSwap swapped) can_rhs lhs_ty - ; continueWith $ Right $ - EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel - , eq_lhs = can_rhs, eq_rhs = lhs_ty } } + -- See Detail (7) of the Note + cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin ---------------------- -tryIrredInstead :: CheckTyEqResult -> CtEvidence - -> EqRel -> SwapFlag -> CanEqLHS -> TcType - -> TcS (StopOrContinue (Either IrredCt unused)) --- We have a non-canonical equality --- We still swap it if 'swapped' says so, so that it is oriented --- in the direction that the error-reporting machinery --- expects it; e.g. (m ~ t m) rather than (t m ~ m) --- This is not very important, and only affects error reporting. -tryIrredInstead reason ev eq_rel swapped lhs rhs - = do { traceTcS "cantMakeCanonical" (ppr reason $$ ppr lhs $$ ppr rhs) - ; new_ev <- rewriteEqEvidenceSwapOnly ev eq_rel swapped lhs rhs - ; finishCanWithIrred (NonCanonicalReason reason) new_ev } - finishCanWithIrred :: CtIrredReason -> CtEvidence -> TcS (StopOrContinue (Either IrredCt a)) finishCanWithIrred reason ev @@ -2404,8 +2402,63 @@ canEqReflexive ev eq_rel ty = do { setEqIfWanted ev (mkReflCPH eq_rel ty) ; stopWith ev "Solved by reflexivity" } -{- Note [Equalities with heterogeneous kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Equalities where unification fails] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we can't unify, but the equality is canonical, we still want to add it to the +inert set so that it can be used to rewrite other Wanteds. (There are many +reasons by unification might not happen: the LHS is not a touchable unification +variable, it has rewriters, it's a Given etc.) + +* In this case we call `checkTypeEqNoUnification`to see if it is canonical (which + in turn calls `checkTypeEqRhs` with suitable flags). + +* NB: we do /not/ try to take advantage of the case where + `canEqCanLHSFinish_try_unification` has already called `checkTyEqRhs`; doing so + caused #27844. (The first call did fam-app breaking, which concealed a genuine + occurs check.) It's just too clever; better to do the simple thing. + +Note [Don't cycle-break Wanteds when not unifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consdier + [W] a[2] ~ Maybe (F a[2]) + +Should we cycle-break this Wanted, thus? + + [W] a[2] ~ Maybe delta[2] + [W] delta[2] ~ F a[2] + +For a start, this is dodgy because we might just unify delta, thus undoing +what we have done, and getting an infinite loop in the solver. Even if we +somehow prevented ourselves from doing so, is there any merit in the split? +Maybe: perhaps we can use that equality on `a` to unlock other constraints? +Consider + type instance F (Maybe _) = Bool + + [G] g1: a ~ Maybe Bool + [W] w1: a ~ Maybe (F a) + +If we loop-break w1 to get + [W] w1': a ~ Maybe gamma + [W] w3: gamma ~ F a +Now rewrite w3 with w1' + [W] w3': gamma ~ F (Maybe gamma) +Now use the type instance to get + gamma := Bool +Now we are left with + [W] w1': a ~ Maybe Bool +which we can solve from the Given. + +BUT in this situation we could have rewritten the +/original/ Wanted from the Given, like this: + [W] w1': Maybe Bool ~ Maybe (F (Maybe Bool)) +and that is readily soluble. + +In short: loop-breaking Wanteds, when we aren't unifying, +seems of no merit. Hence TEFA_Recurse, rather than TEFA_Break, +in `wanted_flags` in `checkTypeEqNoUnification`. + +Note [Equalities with heterogeneous kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What do we do when we have an equality (tv :: k1) ~ (rhs :: k2) @@ -2587,8 +2640,7 @@ The details depend on whether we're working with a Given or a Wanted. Given ----- We emit a new Given, [G] F a ~ cbv, equating the type family application -to our new cbv. This is actually done by `break_given` in -`GHC.Tc.Solver.Monad.checkTypeEq`. +to our new cbv. This is actually done by `break_given` in `checkTypeEqNoUnification`. Note its orientation: The type family ends up on the left; see Note [Orienting TyFamLHS/TyFamLHS]. No special treatment for @@ -3073,11 +3125,10 @@ inertsEqsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w || (empty_rw_w && not (isEmptyCoHoleSet (ctEvRewriters ev_i))) -- Prefer the one that has no rewriters -- See (CE4) in Note [Combining equalities] + -- and (WRW10) in Note Note [Wanteds rewrite Wanteds: rewriter-sets] inertsEqsCanDischarge _ _ = Nothing - - {- Note [Do not unify Givens] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this GADT match @@ -3143,34 +3194,6 @@ Wrinkles: we should kick out `co` so that we can now unify it, which might unlock other stuff. See `kickOutAfterFillingCoercionHole` in GHC.Tc.Solver.Monad. - -Note [Solve by unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we solve - alpha[n] ~ ty -by unification, there are two cases to consider - -* TouchableSameLevel: if the ambient level is 'n', then - we can simply update alpha := ty, and do nothing else - -* TouchableOuterLevel free_metas n: if the ambient level is greater than - 'n' (the level of alpha), in addition to setting alpha := ty we must - do two other things: - - 1. Promote all the free meta-vars of 'ty' to level n. After all, - alpha[n] is at level n, and so if we set, say, - alpha[n] := Maybe beta[m], - we must ensure that when unifying beta we do skolem-escape checks - etc relevant to level n. Simple way to do that: promote beta to - level n. - - 2. Set the Unification Level Flag to record that a level-n unification has - taken place. See Note [WhatUnifications] in GHC.Tc.Utils.Unify - -NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion -would be a no-op, and setting the unification flag unnecessarily would just -make the solver iterate more often. (We don't need to iterate when unifying -at the ambient level because of the kick-out mechanism.) -} ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -22,7 +22,7 @@ module GHC.Tc.Solver.InertSet ( InertEqs, foldTyEqs, delEq, findEq, partitionInertEqs, partitionFunEqs, transformAndPartitionTyVarEqs, - filterInertEqs, filterFunEqs, + filterInertEqs, filterFunEqs, transformAndPartitionFunEqs, foldFunEqs, addEqToCans, -- * Inert Dicts @@ -128,7 +128,7 @@ Further refinements: * Among the equalities we prioritise ones with an empty rewriter set; see Note [Wanteds rewrite Wanteds: rewriter-sets] in GHC.Tc.Types.Constraint, - wrinkle (WRW8). + wrinkle (WRW7). * Among equalities with an empty rewriter set, we prioritise nominal equalities. * They have more rewriting power, so doing them first is better. @@ -983,7 +983,7 @@ How do we establish these conditions? with S(fw,_). * (T3) is guaranteed by an occurs-check on the work item. - This is done during canonicalisation, in checkTypeEq; invariant + This is done during canonicalisation, in checkTyEqRhs; invariant (TyEq:OC) of CEqCan. See also Note [EqCt occurs check] in GHC.Tc.Types.Constraint. * (T4) is established by GHC.Tc.Solver.Monad.kickOutRewritable. If the inert @@ -1422,6 +1422,19 @@ addCanFunEq old_eqs fun_tc fun_args ct foldFunEqs :: (EqCt -> b -> b) -> FunEqMap EqualCtList -> b -> b foldFunEqs k fun_eqs z = foldTcAppMap (\eqs z -> foldr k z eqs) fun_eqs z +transformAndPartitionFunEqs + :: (EqCt -> Either EqCt EqCt) -- Left => chuck out, Right => keep + -> InertFunEqs + -> ([EqCt], InertFunEqs) -- (chuck-out, keep) +transformAndPartitionFunEqs pred orig_inerts + = foldFunEqs folder orig_inerts ([], emptyFunEqs) + where + folder :: EqCt -> ([EqCt], InertFunEqs) -> ([EqCt], InertFunEqs) + folder eq_ct (acc_true, acc_false) + = case pred eq_ct of + Left eq_ct' -> (eq_ct' : acc_true, acc_false) + Right eq_ct' -> (acc_true, addFunEqs eq_ct' acc_false) + partitionFunEqs :: (EqCt -> Bool) -- EqCt will have a TyFamLHS -> InertFunEqs -> ([EqCt], InertFunEqs) ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -117,10 +117,7 @@ module GHC.Tc.Solver.Monad ( getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, matchFam, matchFamTcM, checkWellLevelledDFun, - pprEq, - - -- Enforcing invariants for type equalities - checkTypeEq + pprEq ) where import GHC.Prelude @@ -438,10 +435,12 @@ why solving `kco` might unlock `co`, especially (URW2). Hence `kickOutAfterFillingCoercionHole`. It looks at inert constraints that are * Wanted - * Of the form alpha ~ rhs, where alpha is a unification variable -and kicks out any that will have an empty rewriter set after filling the hole. + * Of the form (alpha ~ rhs), or (F tys ~ alpha) + where alpha is a unification variable +and kicks out any that have an empty rewriter set after filling the hole. Wrinkles: + (KOC1) If co's rewriter-set is {kco, xco}, there is no point in kicking it out, because it still can't be unified. So we only kick out if the co's rewriter-set becomes empty. @@ -455,13 +454,17 @@ Wrinkles: on `kco2` instead of `kco`. Hence the `new_holes` passed to `kickOutAfterFillingCoercionHole` -(KOC3) It's possible that this could just go ahead and unify, but could there - be occurs-check problems? Seems simpler just to kick out. +(KOC3) It's possible that this could just go ahead and unify on the spot, but could + there be occurs-check problems? Seems simpler just to kick out. (KOC4) Kick-out is undesirable, so it'd be better to solve `kco` before `co`. So the solver prioritises equalities with an empty rewriter set, to try to avoid unnecessary kick-out. See GHC.Tc.Types.Constraint Note [Prioritise Wanteds with empty CoHoleSet] esp (PER1) + +(KOC5) We kick out from both `inert_eqs` and `inert_funeqs`. The latter is needed + in case we have (F tys ~ alpha), which might (if it now has an empty rewriter + set) allou unifying alpha. -} kickOutRewritable :: KickOutSpec -> CtFlavourRole -> TcS () @@ -526,23 +529,32 @@ kickOutAfterFillingCoercionHole hole (CPH { cph_holes = new_holes }) ; setInertCans ics' } where kick_out :: InertCans -> ([EqCt], InertCans) - kick_out ics@(IC { inert_eqs = eqs }) - = (eqs_to_kick, ics { inert_eqs = eqs_to_keep }) + kick_out ics@(IC { inert_eqs = eqs, inert_funeqs = funeqs }) + = ( kick_funeqs ++ kick_eqs + , ics { inert_eqs = keep_eqs, inert_funeqs = keep_funeqs }) where - (eqs_to_kick, eqs_to_keep) = transformAndPartitionTyVarEqs kick_out_eq eqs + (kick_eqs, keep_eqs) = transformAndPartitionTyVarEqs kick_out_eq eqs + (kick_funeqs, keep_funeqs) = transformAndPartitionFunEqs kick_out_eq funeqs + -- Kick out from funeqs as well as eqs. + -- See (KOC5) in Note [Kick out after filling a coercion hole] + + is_meta_tv_equality (EqCt { eq_lhs = lhs, eq_rhs = rhs }) + | TyVarLHS tv <- lhs = isMetaTyVar tv + | Just tv <- getTyVar_maybe rhs = isMetaTyVar tv + | otherwise = False kick_out_eq :: EqCt -> Either EqCt EqCt - kick_out_eq eq_ct@(EqCt { eq_ev = ev, eq_lhs = lhs }) + kick_out_eq eq_ct@(EqCt { eq_ev = ev }) | CtWanted (wev@(WantedCt { ctev_rewriters = rewriters })) <- ev - , TyVarLHS tv <- lhs - , isMetaTyVar tv , hole `elemCoHoleSet` rewriters - , let holes' = (rewriters `delCoHoleSet` hole) `mappend` new_holes - -- Adding new_holes and deleting hole: see (KOC2) - eq_ct' = eq_ct { eq_ev = CtWanted (wev { ctev_rewriters = holes' }) } - = if isEmptyCoHoleSet holes' + , is_meta_tv_equality eq_ct + , let rewriters' = (rewriters `delCoHoleSet` hole) `mappend` new_holes + -- Adding new_holes and deleting hole: see (KOC2) + eq_ct' = eq_ct { eq_ev = CtWanted (wev { ctev_rewriters = rewriters' }) } + = if isEmptyCoHoleSet rewriters' then Left eq_ct' -- Kick out, if new rewriter set is empty (KOC1) else Right eq_ct' -- Keep, but with trimmed holes see (KOC2) + | otherwise = Right eq_ct @@ -2302,52 +2314,6 @@ wrapUnifier rws loc role do_unifications ************************************************************************ -} -checkTypeEq :: CtEvidence -> EqRel -> CanEqLHS -> TcType - -> TcS (PuResult Ct Reduction) --- Used for general CanEqLHSs, ones that do --- not have a touchable type variable on the LHS (i.e. not unifying) -checkTypeEq ev eq_rel lhs rhs = - case ev of - CtGiven {} -> - do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs - , text "rhs:" <+> ppr rhs ]) - ; check_result <- wrapTcS (checkTyEqRhs given_flags rhs) - ; traceTcS "checkTypeEq }" (ppr check_result) - ; case check_result of - PuFail reason -> return (PuFail reason) - PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs - ; emitWork new_givens - ; updInertSet (addCycleBreakerBindings prs) - ; return (pure redn) } } - CtWanted {} -> wrapTcS (checkTyEqRhs wanted_flags rhs) - where - wanted_flags :: TyEqFlags TcM Ct - wanted_flags = notUnifying_TEFTask occ_prob lhs - -- checkTypeEq deals only with the non-unifying case - - given_flags :: TyEqFlags TcM (TcTyVar, TcType) - given_flags = wanted_flags { tef_fam_app = mkTEFA_Break ev eq_rel BreakGiven } - -- TEFA_Break used for: [G] a ~ Maybe (F a) - -- or [W] F a ~ Maybe (F a) - - -- occ_prob: see Note [Occurs check and representational equality] - occ_prob = case eq_rel of - NomEq -> cteInsolubleOccurs - ReprEq -> cteSolubleOccurs - - --------------------------- - mk_new_given :: (TcTyVar, TcType) -> TcS Ct - mk_new_given (new_tv, fam_app) - = mkNonCanonical . CtGiven <$> newGivenEv cb_loc (given_pred, given_term) - where - new_ty = mkTyVarTy new_tv - given_pred = mkNomEqPred fam_app new_ty - given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note - - -- See Detail (7) of the Note - cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin - -------------------------- -- | Fill in CycleBreakerTvs with the variables they stand for. -- See Note [Type equality cycles] in GHC.Tc.Solver.Equality restoreTyVarCycles :: InertSet -> TcM () @@ -2363,43 +2329,4 @@ restoreTyVarCycles is (a ~R# b a) is soluble if b later turns out to be Identity So we treat this as a "soluble occurs check". -Note [Don't cycle-break Wanteds when not unifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consdier - [W] a[2] ~ Maybe (F a[2]) - -Should we cycle-break this Wanted, thus? - - [W] a[2] ~ Maybe delta[2] - [W] delta[2] ~ F a[2] - -For a start, this is dodgy because we might just unify delta, thus undoing -what we have done, and getting an infinite loop in the solver. Even if we -somehow prevented ourselves from doing so, is there any merit in the split? -Maybe: perhaps we can use that equality on `a` to unlock other constraints? -Consider - type instance F (Maybe _) = Bool - - [G] g1: a ~ Maybe Bool - [W] w1: a ~ Maybe (F a) - -If we loop-break w1 to get - [W] w1': a ~ Maybe gamma - [W] w3: gamma ~ F a -Now rewrite w3 with w1' - [W] w3': gamma ~ F (Maybe gamma) -Now use the type instance to get - gamma := Bool -Now we are left with - [W] w1': a ~ Maybe Bool -which we can solve from the Given. - -BUT in this situation we could have rewritten the -/original/ Wanted from the Given, like this: - [W] w1': Maybe Bool ~ Maybe (F (Maybe Bool)) -and that is readily soluble. - -In short: loop-breaking Wanteds, when we aren't unifying, -seems of no merit. Hence TEFA_Recurse, rather than TEFA_Break, -in `wanted_flags` in `checkTypeEq`. -} ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -524,7 +524,7 @@ isInsolubleReason (InsolubleFunDepReason {}) = True ------------------------------------------------------------------------------ -- | A /set/ of problems in checking the validity of a type equality. --- See 'checkTypeEq'. +-- See 'GHC.Tc.Utils.Unify.checkTyEqRhs'. newtype CheckTyEqResult = CTER Word8 -- | No problems in checking the validity of a type equality. @@ -2623,19 +2623,24 @@ The rewriter-set plan thereby dropping the reference to `co`. I'm not certain whether this actually happens or not. -(WRW7) In error reporting, we simply suppress any errors that have been rewritten - by /unsolved/ wanteds. This suppression happens in GHC.Tc.Errors.mkErrorItem, +(WRW7) When we fill a coercion hole `h` we kick out any inert Wanted that has `h` + in its rewriter set. See `kickOutAfterFilling CoercionHole`. + See Note [Kick out after filling a coercion hole] in GHC.Tc.Solver.Monad. + + Furthermore, when we select a work item, in `selectNextWorkItem` we zonk the + rewriter set so that it accurately reflects the unsolved coercion holes. That + sets it up ready for the no-rewriter check in (WR5), when we process the equality. + + In `selectNextWorkItem`, we also prioritise equalities with no rewiters. + See Note [Prioritise Wanteds with empty CoHoleSet] in GHC.Tc.Types.Constraint + wrinkle (PER1). + +(WRW8) In error reporting, we suppress any errors that have been rewritten + by /unsolved/ wanteds. This suppression happens in `GHC.Tc.Errors.mkErrorItem`, which uses `GHC.Tc.Zonk.Type.zonkCoHoleSet` to look through any filled coercion holes. The idea is that we wish to report the "root cause" -- the error that rewrote all the others. -(WRW8) In `selectNextWorkItem`, priorities equalities with no rewiters. See - Note [Prioritise Wanteds with empty CoHoleSet] in GHC.Tc.Types.Constraint - wrinkle (PER1). - -(WRW9) In error reporting, we prioritise Wanteds that have an empty CoHoleSet: - see Note [Prioritise Wanteds with empty CoHoleSet]. - Let's continue our first example above: inert: [W] w1 :: a ~ Char @@ -2661,8 +2666,10 @@ Wrinkles: (WRW11) When zonking a constraint (with `zonkCt` and `zonkCtEvidence`) we take the opportunity to zonk its `CoHoleSet`, which eliminates solved ones. - This doesn't guarantee that rewriter sets are always up to date -- c.f. - (WRW10) -- but it helps, and it de-clutters debug output. + This doesn't guarantee that rewriter sets are always up to date (c.f. (WRW10)) + but it helps, and it de-clutters debug output. + + See also (WRW7) which does the crucial just-in-time zonking of the rewriters. Note [Prioritise Wanteds with empty CoHoleSet] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2705,9 +2712,8 @@ in our simplify_loop iteration, we happened to start with co_aym. All would have been well if we'd started with the (not-rewritten) co_ayb and gotten it into the inert set. -With that in mind, we /prioritise/ the work-list to put -constraints with no rewriters first. This prioritisation -is done in `GHC.Tc.Solver.Monad.selectNextWorkItem`. +With that in mind, we /prioritise/ the work-list to put constraints with no rewriters +first. This prioritisation is done in `GHC.Tc.Solver.Monad.selectNextWorkItem`. Wrinkles @@ -2720,8 +2726,8 @@ Wrinkles order to report /some/ error in this case, we simply report all the Wanteds. The user will get a perhaps-confusing error message, but they've written a confusing program! (T22707 and T22793 were close, but they do - not exhibit this behaviour.) So belt and braces: see the `suppress` - stuff in GHC.Tc.Errors.mkErrorItem. + not exhibit this behaviour.) So belt and braces: + see `GHC.Tc.Errors.reportWanteds`. Note [Avoiding rewriting cycles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -3617,15 +3617,20 @@ instance Outputable SimpleUnifyResult where simpleUnifyCheck :: UnifyCheckCaller -> TcLevel -> TcTyVar -> TcType -> SimpleUnifyResult -- ^ A fast check for unification. May return "not sure", in which case -- unification might still be OK, but it'll take more work to do --- (use the full 'checkTypeEq'). +-- (use the full 'checkTyEqRhs'). -- --- * Rejects if lhs_tv occurs in rhs_ty (occurs check) --- * Rejects foralls unless --- lhs_tv is RuntimeUnk (used by GHCi debugger) --- or is a QL instantiation variable --- * Rejects a non-concrete type if lhs_tv is concrete --- * Rejects type families unless fam_ok=True --- * Does a level-check for type variables, to avoid skolem escape +-- It returns SUC_CannotUnify for +-- * Touchability failure +-- * Top level-shape failure +-- +-- It returns SUC_NotSure for +-- * Occurs check: lhs_tv occurs in rhs_ty +-- * Type families unless fam_ok=True +-- * Foralls unless +-- lhs_tv is RuntimeUnk (used by GHCi debugger) +-- or is a QL instantiation variable +-- * Concreteness: lhs_tv is concrete and rhs is a non-concrete type +-- * Skolem-escape: a level-check for type variables, to avoid skolem escape -- -- This function is pretty heavily used, so it's optimised not to allocate simpleUnifyCheck caller given_eq_lvl lhs_tv rhs @@ -4198,7 +4203,7 @@ famAppArgFlags flags = case flags of The key function `checkTyEqRhs ty_eq_flags rhs` is called on the RHS of a type equality lhs ~ rhs -and checks to see if `rhs` satisfies, or can be made to satisfy, +and checks to see if `rhs` satisfies, /or can be made to satisfy/, invariants described by `ty_eq_flags`. It can succeded or fail; in the latter case it returns a `CheckTyEqResult` that describes why it failed. @@ -4219,6 +4224,15 @@ Notably, it can check for things like: * Concreteness error e.g. alpha[conc] ~ r[sk] +Note "or can be made to satisfy the preconditions"! `checkTyEqRhs` may transform +the RHS by + + * Turning a type-family application into a type variable, perhaps to avoid + an occurs check. See Note Note [Family applications in canonical constraints] + + * Promoting any nested unification variables, in order to satisfy the + level invariant. See Note [Promotion and level-checking] + Its specific behaviour is governed by the `TyEqFlags` that are passed to it; see Note [TyEqFlags]. @@ -4275,7 +4289,7 @@ NB: We never see a TyVarLHS here, such as [G] a ~ F tys here because we'd have swapped it to [G] F tys ~ a -in canEqCanLHS2, before getting to checkTypeEq. +in canEqCanLHS2, before getting to checkTyEqRhs. -} check_ty_eq_rhs :: forall m a @@ -4799,7 +4813,6 @@ promote_meta_tyvar info dest_lvl occ_tv touchabilityTest :: TcLevel -> TcTyVar -> Bool -- ^ This is the key test for untouchability: -- See Note [Unification preconditions] in GHC.Tc.Utils.Unify --- and Note [Solve by unification] in GHC.Tc.Solver.Equality -- -- @True@ <=> the variable is touchable touchabilityTest given_eq_lvl tv ===================================== testsuite/tests/indexed-types/should_fail/T9662.stderr ===================================== @@ -1,12 +1,12 @@ T9662.hs:49:8: error: [GHC-25897] - • Couldn't match type ‘n’ with ‘Int’ + • Couldn't match type ‘m’ with ‘Int’ Expected: Exp (((sh :. k) :. m) :. n) -> Exp (((sh :. m) :. n) :. k) Actual: Exp (Tuple (((Atom a0 :. Atom Int) :. Atom Int) :. Atom Int)) -> Exp (Plain (((Unlifted (Atom a0) :. Exp Int) :. Exp Int) :. Exp Int)) - ‘n’ is a rigid type variable bound by + ‘m’ is a rigid type variable bound by the type signature for: test :: forall sh k m n. Shape (((sh :. k) :. m) :. n) -> Shape (((sh :. m) :. n) :. k) ===================================== testsuite/tests/typecheck/should_fail/T27844.hs ===================================== @@ -0,0 +1,14 @@ +-- Repro.hs +-- The call to f forces c ~ (b, F c) inside the scope of the skolem b. +-- Correct behaviour: a type error at the first argument of const +-- (as GHC 9.12.4 reports). + +{-# LANGUAGE RankNTypes, TypeFamilies #-} +module T27844 where + +type family F a + +f :: (forall b. b -> (b, F c)) -> c -> () +f _ _ = () + +g x = f (\_ -> const x (show x)) x ===================================== testsuite/tests/typecheck/should_fail/T27844.stderr ===================================== @@ -0,0 +1,12 @@ +T27844.hs:14:22: error: [GHC-25897] + • Couldn't match expected type ‘(b, F c)’ with actual type ‘c’ + ‘c’ is a rigid type variable bound by + the inferred type of g :: Show c => c -> () + at T27844.hs:14:1-34 + • In the first argument of ‘const’, namely ‘x’ + In the expression: const x (show x) + In the first argument of ‘f’, namely ‘(\ _ -> const x (show x))’ + • Relevant bindings include + x :: c (bound at T27844.hs:14:3) + g :: c -> () (bound at T27844.hs:14:1) + ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -763,3 +763,4 @@ test('T26861', normal, compile_fail, ['']) test('T26862', normal, compile_fail, ['']) test('T27210', normal, compile_fail, ['']) test('T26532', normal, compile_fail, ['']) +test('T27844', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba80e8ee0872218065dfa23ae8e4c52… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba80e8ee0872218065dfa23ae8e4c52… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: RTS: Update flag parsing/handling:
by Marge Bot (＠marge-bot) 30 Sep '26

30 Sep '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 72cd19c2 by Andreas Klebinger at 2026-09-30T09:53:24-04:00 RTS: Update flag parsing/handling: Using 0 as argument to any of these flags now resets the flags setting to default: - ``-n0`` disables nursery chunking. - ``-K0`` (or a bare ``-K``) removes the stack size limit. - ``-M0`` removes the heap size limit. - ``-H0`` resets the suggested heap size, including the nursery scaling set by ``-H``. - ``-AL0`` makes the large object allocation limit follow ``-A`` again. GC Generations are now limited to 64. -n larger than -A now emits a warning and disables chunking. Fixes #27830 #27829 - - - - - 54950323 by Andreas Klebinger at 2026-09-30T09:53:24-04:00 Fix MultiLayerModules timeout multiplier. We accidentally used the compile multiplier for ghci commands which use the run timeout setting to set the timeout. Fixes #26263 and #27796. - - - - - 33b23931 by Andreas Klebinger at 2026-09-30T09:53:24-04:00 testsuite: Include runtime in JUnit report. - - - - - ce88d931 by Alan Zimmerman at 2026-09-30T09:53:25-04:00 EPA: Use EpaLocation in EpVirtualBraces Haddock processing uses EpLayout.EpVirtualBraces to record the current layout column, for allocating haddock comments correctly. For exact printing, we need the line as well as the col, so we know how many lines to skip when the indented code block starts. This commit updates EpLayout.EpVirtualBraces so that it carries an EpaLocation instead of just the Int column, to allow it to be used for both purposes. It is a simple mechanical change, with no other impact, but it allows us to use EpLayout instead of AnnListLayout in AnnList, in the next commit in this series. - - - - - 38 changed files: - + changelog.d/T27830-rts-flag-bounds - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - docs/users_guide/runtime_control.rst - rts/RtsFlags.c - rts/include/rts/Flags.h - rts/include/rts/storage/GC.h - rts/sm/GC.c - rts/sm/Storage.c - testsuite/driver/junit.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/perf/compiler/all.T - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/rts/all.T - testsuite/tests/rts/rtsflags001.stderr-ws-32 - testsuite/tests/rts/rtsflags001.stderr-ws-64 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bbe2fea001b80e95a26d1f5f21e378… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bbe2fea001b80e95a26d1f5f21e378… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/hsmodulename] ttg: HsModuleName in the AST, ModuleName in GHC
by Rodrigo Mesquita (＠alt-romes) 30 Sep '26

30 Sep '26

Rodrigo Mesquita pushed to branch wip/romes/hsmodulename at Glasgow Haskell Compiler / GHC Commits: b57bdb93 by Rodrigo Mesquita at 2026-09-30T14:17:14+01:00 ttg: HsModuleName in the AST, ModuleName in GHC This commit makes the AST fully independent from GHC by parsing a "module name" as an `HsModuleName (= HText)` rather than constructing an `ModuleName (= FastString)` straight away. In the GHC side, everything remains as a `ModuleName`. We turn AST `HsModuleName`s into fast strings with the cheap `mkFastStringShortText` when we process the AST for manipulation within the compiler. There are no performance regressions introduced by this approach. This is the final piece of #21592 Alternative plans were discussed in gitlab.haskell.org/ghc/ghc/-/merge_requests/16546#note_694647, but the Simon suggested one won in simplicity and performance when compared against my attempt at implementing my original plan of having a family `ModuleNameP`. - - - - - 89 changed files: - compiler/GHC.hs - compiler/GHC/Builtin/Modules.hs - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Show.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Opt/CallerCC/Types.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Pipeline.hs-boot - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/Phases.hs - compiler/GHC/Hs/Doc.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Debug.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/String.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/UnresolvedImport.hs - compiler/GHC/Unit/Home.hs - compiler/GHC/Unit/Module.hs - compiler/GHC/Unit/Module/Env.hs - + compiler/GHC/Unit/Module/Name.hs - compiler/GHC/Unit/Parser.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Unit/Types.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Lit.hs - compiler/Language/Haskell/Syntax/Module/Name.hs - compiler/Language/Haskell/Syntax/Text.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - linters/lint-codes/LintCodes/Static.hs - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b57bdb939dfcca427ce2b4694f707fd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b57bdb939dfcca427ce2b4694f707fd… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/io-manager-deadlock-detection] 2 commits: FIXUP: correct the type of timeout_idlegc_delay
by Duncan Coutts (＠dcoutts) 30 Sep '26

30 Sep '26

Duncan Coutts pushed to branch wip/io-manager-deadlock-detection at Glasgow Haskell Compiler / GHC Commits: 3930cb47 by Duncan Coutts at 2026-09-30T12:37:36+01:00 FIXUP: correct the type of timeout_idlegc_delay - - - - - 04c39112 by Duncan Coutts at 2026-09-30T12:37:55+01:00 Remove variable n_haskell_handlers which has become write-only - - - - - 4 changed files: - rts/posix/Poll.c - rts/posix/Select.c - rts/posix/SelectBis.c - rts/posix/Signals.c Changes: ===================================== rts/posix/Poll.c ===================================== @@ -478,7 +478,7 @@ bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) * (see handleIdleGcTimeout below). */ bool any_pending_io = nfds > 0; - int timeout_idlegc_delay; + bool timeout_idlegc_delay; adjustTimeoutForIdleGc(any_pending_io, &timeout, &timeout_idlegc_delay); #endif ===================================== rts/posix/Select.c ===================================== @@ -371,7 +371,7 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait) * (see handleIdleGcTimeout below). */ bool any_pending_io = maxfd > 0; - int timeout_idlegc_delay; + bool timeout_idlegc_delay; adjustTimeoutForIdleGc(any_pending_io, &timeout, &timeout_idlegc_delay); #endif ===================================== rts/posix/SelectBis.c ===================================== @@ -442,7 +442,7 @@ bool awaitCompletedTimeoutsOrIOSelectBis(CapIOManager *iomgr) * (see handleIdleGcTimeout below). */ bool any_pending_io = maxfd >= 0; - int timeout_idlegc_delay; + bool timeout_idlegc_delay; adjustTimeoutForIdleGc(any_pending_io, &timeout, &timeout_idlegc_delay); #endif ===================================== rts/posix/Signals.c ===================================== @@ -55,8 +55,6 @@ HsInt nocldstop = 0; StgInt *signal_handlers = NULL; /* Dynamically grown array of signal handlers */ static StgInt nHandlers = 0; /* Size of handlers array */ -static uint32_t n_haskell_handlers = 0; - static sigset_t userSignals; static sigset_t savedSignals; @@ -83,7 +81,6 @@ freeSignalHandlers(void) { stgFree(signal_handlers); signal_handlers = NULL; nHandlers = 0; - n_haskell_handlers = 0; } #if defined(THREADED_RTS) closeMutex(&sig_mutex); @@ -288,16 +285,10 @@ stg_sig_install(int sig, int spi, void *mask) case STG_SIG_RST: case STG_SIG_HAN: sigaddset(&userSignals, sig); - if (previous_spi != STG_SIG_HAN && previous_spi != STG_SIG_RST) { - n_haskell_handlers++; - } break; default: sigdelset(&userSignals, sig); - if (previous_spi == STG_SIG_HAN || previous_spi == STG_SIG_RST) { - n_haskell_handlers--; - } break; } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/80e2ceee662bbaad131c70e5f747f6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/80e2ceee662bbaad131c70e5f747f6… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/annotation-fixes] 6 commits: base: Preserve exception context in modifyIOError
by Zubin (＠wz1000) 30 Sep '26

30 Sep '26

Zubin pushed to branch wip/annotation-fixes at Glasgow Haskell Compiler / GHC Commits: 5dc3fb3d by Zubin Duggal at 2026-09-30T17:38:52+05:30 base: Preserve exception context in modifyIOError Fixes #27851. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/446 - - - - - 6e10ba2f by Zubin Duggal at 2026-09-30T17:38:52+05:30 base: Preserve exception context in mapException Fixes #27851. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/446 - - - - - 39bedca7 by Zubin Duggal at 2026-09-30T17:38:53+05:30 base: Preserve exception context when rethrowing exceptions in Handle reads Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - 96cb0b55 by Zubin Duggal at 2026-09-30T17:38:53+05:30 base: Preserve exception context when rethrowing exceptions in hClose Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - cb9debbd by Zubin Duggal at 2026-09-30T17:38:53+05:30 base: Preserve exception context when rethrowing exceptions in Windows openFile Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - e9688c44 by Zubin Duggal at 2026-09-30T17:38:53+05:30 base: Preserve exception context when rethrowing exceptions in executablePath Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - 18 changed files: - + changelog.d/clc-446 - + changelog.d/clc-447 - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs - + testsuite/tests/exceptions/T27851.hs - + testsuite/tests/exceptions/T27851.stderr - + testsuite/tests/exceptions/T27851b.hs - + testsuite/tests/exceptions/T27851b.stderr - + testsuite/tests/exceptions/T27851c.hs - + testsuite/tests/exceptions/T27851c.stdout - + testsuite/tests/exceptions/T27851d.hs - + testsuite/tests/exceptions/T27851d.stdout - testsuite/tests/exceptions/all.T Changes: ===================================== changelog.d/clc-446 ===================================== @@ -0,0 +1,7 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in + ``modifyIOError`` and ``mapException``. +issues: #27851 +mrs: !16747 +description: + See `CLC proposal 446 <https://github.com/haskell/core-libraries-committee/issues/446>`_. ===================================== changelog.d/clc-447 ===================================== @@ -0,0 +1,8 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``hGetLine``, + ``hGetContents``, ``hGetContents'``, ``hClose``, ``executablePath``, and on + Windows in ``openFile``, ``openFileBlocking`` and ``openBinaryFile``. +issues: #27875 +mrs: !16747 +description: + See `CLC proposal 447 <https://github.com/haskell/core-libraries-committee/issues/447>`_. ===================================== libraries/base/changelog.md ===================================== @@ -11,6 +11,8 @@ * Add `withEmptyCallStack` to `GHC.Stack`. ([CLC proposal #428](https://github.com/haskell/core-libraries-committee/issues/428)) * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) + * Preserve exception context when rethrowing exceptions in `modifyIOError` and `mapException`. ([CLC proposal #446](https://github.com/haskell/core-libraries-committee/issues/446)) + * Preserve exception context when rethrowing exceptions in `hGetLine`, `hGetContents`, `hGetContents'`, `hClose`, `executablePath`, and on Windows in `openFile`, `openFileBlocking` and `openBinaryFile`. ([CLC proposal #447](https://github.com/haskell/core-libraries-committee/issues/447)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs ===================================== @@ -175,8 +175,8 @@ handleJust p = flip (catchJust p) -- Notice that the usage of 'unsafePerformIO' is safe here. mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a -mapException f v = unsafePerformIO (catch (evaluate v) - (\x -> throwIO (f x))) +mapException f v = unsafePerformIO $ catchNoPropagate (evaluate v) $ + \(ExceptionWithContext ctx x) -> rethrowIO (ExceptionWithContext ctx (f x)) ----------------------------------------------------------------------------- -- 'try' and variations. ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs ===================================== @@ -193,7 +193,7 @@ do_operation fun h act m = do throwTo t e do_operation fun h act m _otherwise -> - throwIO e + rethrowIO (ExceptionWithContext c e) -- Note [async] -- ~~~~~~~~~~~~ @@ -451,7 +451,7 @@ handleFinalizer fp m = do (handle_', mb_exc) <- hClose_help handle_ putMVar m handle_' case mb_exc of - Just exc -> throwIO exc + Just exc -> throwIO (NoBacktrace exc) Nothing -> return () {- @@ -885,8 +885,9 @@ hClose_maybethrow (Just e) h = hClose_rethrow e h hClose_rethrow :: SomeException -> Handle -> IO () hClose_rethrow e h = case fromException e of - Just ioe -> ioError (augmentIOError ioe "hClose" h) - Nothing -> throwIO e + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hClose" h + Nothing -> throwIO (NoBacktrace e) hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) hClose' h m = withHandle' "hClose" h m $ hClose_help ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs ===================================== @@ -52,7 +52,6 @@ import qualified GHC.Internal.IO.Device as RawIO import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Storable -import qualified GHC.Internal.Control.Exception as Exception import GHC.Internal.System.IO.Error import GHC.Internal.Data.Either (Either(..)) import GHC.Internal.Data.Maybe @@ -267,13 +266,14 @@ hGetLineBufferedLoop handle_@Handle__{..} maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) maybeFillReadBuffer handle_ buf - = catchException + = catchNoPropagate (do buf' <- getSomeCharacters handle_ buf return (Just buf') ) - (\e -> do if isEOFError e + (\ec@(ExceptionWithContext _ e) -> + if isEOFError e then return Nothing - else ioError e) + else rethrowIO ec) -- See GHC.Internal.IO.Buffer #define CHARBUF_UTF32 @@ -421,7 +421,7 @@ lazyRead handle = lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyReadBuffered h handle_@Handle__{..} = do buf <- readIORef haCharBuffer - Exception.catch + catchNoPropagate (do buf'@Buffer{..} <- getSomeCharacters handle_ buf lazy_rest <- lazyRead h @@ -432,7 +432,8 @@ lazyReadBuffered h handle_@Handle__{..} = do writeIORef haCharBuffer (bufferAdjustL r buf') return (handle_, s) ) - (\e -> do (handle_', _) <- hClose_help handle_ + (\(ExceptionWithContext ctx e) -> do + (handle_', _) <- hClose_help handle_ debugIO ("hGetContents caught: " ++ show e) -- We might have a \r cached in CRLF mode. So we -- need to check for that and return it: @@ -441,7 +442,8 @@ lazyReadBuffered h handle_@Handle__{..} = do then "\r" else "" else - throw (augmentIOError e "hGetContents" h) + throw $ NoBacktrace $ ExceptionWithContext ctx $ + augmentIOError e "hGetContents" h return (handle_', r) ) @@ -496,7 +498,8 @@ hGetContents' handle = do Right s -> return s Left e -> case fromException e of - Just ioe -> throwIO (augmentIOError ioe "hGetContents'" handle) + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hGetContents'" handle Nothing -> throwIO (NoBacktrace e) strictRead :: Handle -> Handle__ -> IO (Handle__, Either SomeException String) @@ -512,12 +515,13 @@ strictRead h handle_@Handle__{..} = do strictReadLoop :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer] strictReadLoop handle_ cbufs cbuf0 = do - mcbuf <- Exception.catch + mcbuf <- catchNoPropagate (do r <- readTextDevice handle_ cbuf0 return (Just r)) - (\e -> if isEOFError e + (\ec@(ExceptionWithContext _ e) -> + if isEOFError e then return Nothing - else throw e) + else rethrowIO ec) case mcbuf of Nothing -> return (cbuf0 : cbufs) Just cbuf1 -> strictReadLoop' handle_ cbufs cbuf1 ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Internal.Base (String, fmap, otherwise, return, ($)) import qualified GHC.Internal.Base as Rebindable import qualified GHC.Internal.Data.Typeable.Internal as Rebindable import GHC.Internal.MVar +import GHC.Internal.Exception.Type (ExceptionWithContext(..)) import GHC.Internal.IO import GHC.Internal.IO.BufferedIO hiding (flushWriteBuffer) import GHC.Internal.IO.Encoding @@ -114,6 +115,11 @@ addFilePathToIOError :: String -> FilePath -> IOException -> IOException addFilePathToIOError fun fp ioe = ioe{ ioe_location = fun, ioe_filename = Just fp } +catchAndAnnotate :: FilePath -> String -> IO a -> IO a +catchAndAnnotate fp s a = + catchExceptionNoPropagate a $ \(ExceptionWithContext c e) -> + rethrowIO (ExceptionWithContext c (addFilePathToIOError s fp e)) + -- | Computation 'openFile' @file mode@ allocates and returns a new, open -- handle to manage the file @file@. It manages input if @mode@ -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', @@ -142,9 +148,8 @@ addFilePathToIOError fun fp ioe -- be using 'openBinaryFile'. openFile :: FilePath -> IOMode -> IO Handle openFile fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True) - (\e -> ioError (addFilePathToIOError "openFile" fp e)) + catchAndAnnotate fp "openFile" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True -- | Like 'openFile', but opens the file in ordinary blocking mode. -- This can be useful for opening a FIFO for writing: if we open in @@ -154,9 +159,8 @@ openFile fp im = -- @since base-4.4.0.0 openFileBlocking :: FilePath -> IOMode -> IO Handle openFileBlocking fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False) - (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e)) + catchAndAnnotate fp "openFileBlocking" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False -- | Like 'openFile', but open the file in binary mode. -- On Windows, reading a file in text mode (which is the default) @@ -169,9 +173,8 @@ openFileBlocking fp im = openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = - catchException - (openFile' fp m True True) - (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) + catchAndAnnotate fp "openBinaryFile" $ + openFile' fp m True True openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle openFile' filepath iomode binary non_blocking = do ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc ===================================== @@ -44,7 +44,7 @@ executablePath = Nothing import GHC.Internal.Maybe (Maybe(..)) import GHC.Internal.IO (FilePath) #if defined(darwin_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.Real import GHC.Internal.Word @@ -66,7 +66,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Real import GHC.Internal.System.Posix.Internals #elif defined(solaris2_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -75,7 +75,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.System.IO.Error (isDoesNotExistError) import GHC.Internal.System.Posix.Internals #elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -203,10 +203,10 @@ realpath path = getExecutablePath = _NSGetExecutablePath >>= realpath -- realpath(3) fails with ENOENT file does not exist (e.g. was deleted) -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing -------------------------------------------------------------------------------- -- Linux / Solaris / Hurd @@ -242,12 +242,12 @@ executablePath = Just (check <$> getExecutablePath) where # elif defined(solaris2_HOST_OS) getExecutablePath = readSymbolicLink "/proc/self/path/a.out" -executablePath = Just ((Just <$> getExecutablePath) `catch` f) +executablePath = Just (catchJust f (Just <$> getExecutablePath) (\_ -> pure Nothing)) where -- readlink(2) fails with ENOENT when the executable has been deleted, -- even though the symlink itself still exists according to readdir(3). - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing #endif @@ -297,15 +297,15 @@ getExecutablePath = do ] # endif -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where -- The sysctl fails with errno ENOENT when executable has been deleted; -- see https://gitlab.haskell.org/ghc/ghc/-/issues/12377#note_321346. - f e | isDoesNotExistError e = pure Nothing + f e | isDoesNotExistError e = Just () -- As far as I know, ENOENT is the only kind of failure that should be -- expected and handled. Re-throw other errors. - | otherwise = throw e + | otherwise = Nothing -------------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs ===================================== @@ -319,9 +319,10 @@ ioeSetHandle ioe hdl = ioe{ ioe_handle = Just hdl } ioeSetFileName ioe filename = ioe{ ioe_filename = Just filename } -- | Catch any 'IOError' that occurs in the computation and throw a --- modified version. +-- modified version, preserving the original 'ExceptionContext'. modifyIOError :: (IOError -> IOError) -> IO a -> IO a -modifyIOError f io = catch io (\e -> throwIO (NoBacktrace $ f e)) +modifyIOError f io = catchNoPropagate io $ \(ExceptionWithContext ctx e) -> + rethrowIO (ExceptionWithContext ctx (f e)) -- ----------------------------------------------------------------------------- -- annotating an IOError ===================================== testsuite/tests/exceptions/T27851.hs ===================================== @@ -0,0 +1,7 @@ +import System.IO.Error + +main :: IO () +main = + modifyIOError (`ioeSetLocation` "outer") $ + modifyIOError (`ioeSetLocation` "inner") $ + ioError (mkIOError doesNotExistErrorType "origin" Nothing (Just "file")) ===================================== testsuite/tests/exceptions/T27851.stderr ===================================== @@ -0,0 +1,7 @@ +T27851: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.IOException: + +file: outer: does not exist + +HasCallStack backtrace: + ioError, called at T27851.hs:7:3 in main:Main + ===================================== testsuite/tests/exceptions/T27851b.hs ===================================== @@ -0,0 +1,7 @@ +import Control.Exception + +newtype Wrapped = Wrapped String deriving Show +instance Exception Wrapped + +main :: IO () +main = print (mapException (\(ErrorCall s) -> Wrapped s) (error "boom" :: Int)) ===================================== testsuite/tests/exceptions/T27851b.stderr ===================================== @@ -0,0 +1,7 @@ +T27851b: Uncaught exception main:Main.Wrapped: + +Wrapped "boom" + +HasCallStack backtrace: + error, called at T27851b.hs:7:59 in main:Main + ===================================== testsuite/tests/exceptions/T27851c.hs ===================================== @@ -0,0 +1,22 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + withBinaryFile "T27851c.txt" WriteMode $ \h -> hPutStr h "\xff\n" + run "hGetLine" hGetLine + run "hGetContents'" hGetContents' + run "hGetContents" $ \h -> do + s <- hGetContents h + length s `seq` pure s + +run :: String -> (Handle -> IO String) -> IO () +run name act = do + r <- try $ withFile "T27851c.txt" ReadMode $ \h -> do + hSetEncoding h utf8 + act h + case r of + Left e -> do + putStrLn ("-- " ++ name) + putStrLn (displayExceptionWithInfo e) + Right s -> print s ===================================== testsuite/tests/exceptions/T27851c.stdout ===================================== @@ -0,0 +1,24 @@ +-- hGetLine +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetLine: invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + +-- hGetContents' +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetContents': invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + +-- hGetContents +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetContents: invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + ===================================== testsuite/tests/exceptions/T27851d.hs ===================================== @@ -0,0 +1,11 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + h <- openFile "/dev/full" WriteMode + hPutStr h "x" + r <- try (hClose h) + case r of + Left e -> putStrLn (displayExceptionWithInfo e) + Right () -> putStrLn "no exception" ===================================== testsuite/tests/exceptions/T27851d.stdout ===================================== @@ -0,0 +1,7 @@ +ghc-internal:GHC.Internal.IO.Exception.IOException: + +/dev/full: hClose: resource exhausted (No space left on device) + +HasCallStack backtrace: + ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:293:5 in ghc-internal:GHC.Internal.Foreign.C.Error + ===================================== testsuite/tests/exceptions/all.T ===================================== @@ -1,3 +1,7 @@ test('T25052', normal, compile_and_run, ['']) test('T26759', exit_code(1), compile_and_run, ['']) test('T26759a', exit_code(1), compile_and_run, ['']) +test('T27851', exit_code(1), compile_and_run, ['']) +test('T27851b', exit_code(1), compile_and_run, ['']) +test('T27851c', normal, compile_and_run, ['']) +test('T27851d', unless(opsys('linux'), skip), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/56e6d5db93d172964cb5faaaf1d707… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/56e6d5db93d172964cb5faaaf1d707… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/annotation-fixes] 6 commits: base: Preserve exception context in modifyIOError
by Zubin (＠wz1000) 30 Sep '26

30 Sep '26

Zubin pushed to branch wip/annotation-fixes at Glasgow Haskell Compiler / GHC Commits: e77fa849 by Zubin Duggal at 2026-09-30T17:35:30+05:30 base: Preserve exception context in modifyIOError Fixes #27851. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/446 - - - - - a1ccd107 by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context in mapException Fixes #27851. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/446 - - - - - 3f5763ba by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in Handle reads Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - e73d713e by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in hClose Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - a8fe1e4c by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in Windows openFile Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - 56e6d5db by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in executablePath Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - 18 changed files: - + changelog.d/clc-446 - + changelog.d/clc-447 - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs - + testsuite/tests/exceptions/T27851.hs - + testsuite/tests/exceptions/T27851.stderr - + testsuite/tests/exceptions/T27851b.hs - + testsuite/tests/exceptions/T27851b.stderr - + testsuite/tests/exceptions/T27851c.hs - + testsuite/tests/exceptions/T27851c.stdout - + testsuite/tests/exceptions/T27851d.hs - + testsuite/tests/exceptions/T27851d.stdout - testsuite/tests/exceptions/all.T Changes: ===================================== changelog.d/clc-446 ===================================== @@ -0,0 +1,7 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in + ``modifyIOError`` and ``mapException``. +issues: #27851 +mrs: !16747 +description: + See `CLC proposal 446 <https://github.com/haskell/core-libraries-committee/issues/446>`_. ===================================== changelog.d/clc-447 ===================================== @@ -0,0 +1,8 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``hGetLine``, + ``hGetContents``, ``hGetContents'``, ``hClose``, ``executablePath``, and on + Windows in ``openFile``, ``openFileBlocking`` and ``openBinaryFile``. +issues: #27875 +mrs: !16747 +description: + See `CLC proposal 447 <https://github.com/haskell/core-libraries-committee/issues/447>`_. ===================================== libraries/base/changelog.md ===================================== @@ -11,6 +11,8 @@ * Add `withEmptyCallStack` to `GHC.Stack`. ([CLC proposal #428](https://github.com/haskell/core-libraries-committee/issues/428)) * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) + * `modifyIOError` now preserves the original `ExceptionContext` instead of annotating the rethrown exception with `WhileHandling`. ([GHC #27851](https://gitlab.haskell.org/ghc/ghc/-/issues/27851)) + * `mapException` now preserves the original `ExceptionContext` instead of annotating the mapped exception with `WhileHandling`. ([GHC #27851](https://gitlab.haskell.org/ghc/ghc/-/issues/27851)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs ===================================== @@ -175,8 +175,8 @@ handleJust p = flip (catchJust p) -- Notice that the usage of 'unsafePerformIO' is safe here. mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a -mapException f v = unsafePerformIO (catch (evaluate v) - (\x -> throwIO (f x))) +mapException f v = unsafePerformIO $ catchNoPropagate (evaluate v) $ + \(ExceptionWithContext ctx x) -> rethrowIO (ExceptionWithContext ctx (f x)) ----------------------------------------------------------------------------- -- 'try' and variations. ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs ===================================== @@ -193,7 +193,7 @@ do_operation fun h act m = do throwTo t e do_operation fun h act m _otherwise -> - throwIO e + rethrowIO (ExceptionWithContext c e) -- Note [async] -- ~~~~~~~~~~~~ @@ -451,7 +451,7 @@ handleFinalizer fp m = do (handle_', mb_exc) <- hClose_help handle_ putMVar m handle_' case mb_exc of - Just exc -> throwIO exc + Just exc -> throwIO (NoBacktrace exc) Nothing -> return () {- @@ -885,8 +885,9 @@ hClose_maybethrow (Just e) h = hClose_rethrow e h hClose_rethrow :: SomeException -> Handle -> IO () hClose_rethrow e h = case fromException e of - Just ioe -> ioError (augmentIOError ioe "hClose" h) - Nothing -> throwIO e + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hClose" h + Nothing -> throwIO (NoBacktrace e) hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) hClose' h m = withHandle' "hClose" h m $ hClose_help ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs ===================================== @@ -52,7 +52,6 @@ import qualified GHC.Internal.IO.Device as RawIO import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Storable -import qualified GHC.Internal.Control.Exception as Exception import GHC.Internal.System.IO.Error import GHC.Internal.Data.Either (Either(..)) import GHC.Internal.Data.Maybe @@ -267,13 +266,14 @@ hGetLineBufferedLoop handle_@Handle__{..} maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) maybeFillReadBuffer handle_ buf - = catchException + = catchNoPropagate (do buf' <- getSomeCharacters handle_ buf return (Just buf') ) - (\e -> do if isEOFError e + (\ec@(ExceptionWithContext _ e) -> + if isEOFError e then return Nothing - else ioError e) + else rethrowIO ec) -- See GHC.Internal.IO.Buffer #define CHARBUF_UTF32 @@ -421,7 +421,7 @@ lazyRead handle = lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyReadBuffered h handle_@Handle__{..} = do buf <- readIORef haCharBuffer - Exception.catch + catchNoPropagate (do buf'@Buffer{..} <- getSomeCharacters handle_ buf lazy_rest <- lazyRead h @@ -432,7 +432,8 @@ lazyReadBuffered h handle_@Handle__{..} = do writeIORef haCharBuffer (bufferAdjustL r buf') return (handle_, s) ) - (\e -> do (handle_', _) <- hClose_help handle_ + (\(ExceptionWithContext ctx e) -> do + (handle_', _) <- hClose_help handle_ debugIO ("hGetContents caught: " ++ show e) -- We might have a \r cached in CRLF mode. So we -- need to check for that and return it: @@ -441,7 +442,8 @@ lazyReadBuffered h handle_@Handle__{..} = do then "\r" else "" else - throw (augmentIOError e "hGetContents" h) + throw $ NoBacktrace $ ExceptionWithContext ctx $ + augmentIOError e "hGetContents" h return (handle_', r) ) @@ -496,7 +498,8 @@ hGetContents' handle = do Right s -> return s Left e -> case fromException e of - Just ioe -> throwIO (augmentIOError ioe "hGetContents'" handle) + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hGetContents'" handle Nothing -> throwIO (NoBacktrace e) strictRead :: Handle -> Handle__ -> IO (Handle__, Either SomeException String) @@ -512,12 +515,13 @@ strictRead h handle_@Handle__{..} = do strictReadLoop :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer] strictReadLoop handle_ cbufs cbuf0 = do - mcbuf <- Exception.catch + mcbuf <- catchNoPropagate (do r <- readTextDevice handle_ cbuf0 return (Just r)) - (\e -> if isEOFError e + (\ec@(ExceptionWithContext _ e) -> + if isEOFError e then return Nothing - else throw e) + else rethrowIO ec) case mcbuf of Nothing -> return (cbuf0 : cbufs) Just cbuf1 -> strictReadLoop' handle_ cbufs cbuf1 ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Internal.Base (String, fmap, otherwise, return, ($)) import qualified GHC.Internal.Base as Rebindable import qualified GHC.Internal.Data.Typeable.Internal as Rebindable import GHC.Internal.MVar +import GHC.Internal.Exception.Type (ExceptionWithContext(..)) import GHC.Internal.IO import GHC.Internal.IO.BufferedIO hiding (flushWriteBuffer) import GHC.Internal.IO.Encoding @@ -114,6 +115,11 @@ addFilePathToIOError :: String -> FilePath -> IOException -> IOException addFilePathToIOError fun fp ioe = ioe{ ioe_location = fun, ioe_filename = Just fp } +catchAndAnnotate :: FilePath -> String -> IO a -> IO a +catchAndAnnotate fp s a = + catchExceptionNoPropagate a $ \(ExceptionWithContext c e) -> + rethrowIO (ExceptionWithContext c (addFilePathToIOError s fp e)) + -- | Computation 'openFile' @file mode@ allocates and returns a new, open -- handle to manage the file @file@. It manages input if @mode@ -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', @@ -142,9 +148,8 @@ addFilePathToIOError fun fp ioe -- be using 'openBinaryFile'. openFile :: FilePath -> IOMode -> IO Handle openFile fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True) - (\e -> ioError (addFilePathToIOError "openFile" fp e)) + catchAndAnnotate fp "openFile" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True -- | Like 'openFile', but opens the file in ordinary blocking mode. -- This can be useful for opening a FIFO for writing: if we open in @@ -154,9 +159,8 @@ openFile fp im = -- @since base-4.4.0.0 openFileBlocking :: FilePath -> IOMode -> IO Handle openFileBlocking fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False) - (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e)) + catchAndAnnotate fp "openFileBlocking" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False -- | Like 'openFile', but open the file in binary mode. -- On Windows, reading a file in text mode (which is the default) @@ -169,9 +173,8 @@ openFileBlocking fp im = openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = - catchException - (openFile' fp m True True) - (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) + catchAndAnnotate fp "openBinaryFile" $ + openFile' fp m True True openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle openFile' filepath iomode binary non_blocking = do ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc ===================================== @@ -44,7 +44,7 @@ executablePath = Nothing import GHC.Internal.Maybe (Maybe(..)) import GHC.Internal.IO (FilePath) #if defined(darwin_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.Real import GHC.Internal.Word @@ -66,7 +66,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Real import GHC.Internal.System.Posix.Internals #elif defined(solaris2_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -75,7 +75,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.System.IO.Error (isDoesNotExistError) import GHC.Internal.System.Posix.Internals #elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -203,10 +203,10 @@ realpath path = getExecutablePath = _NSGetExecutablePath >>= realpath -- realpath(3) fails with ENOENT file does not exist (e.g. was deleted) -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing -------------------------------------------------------------------------------- -- Linux / Solaris / Hurd @@ -242,12 +242,12 @@ executablePath = Just (check <$> getExecutablePath) where # elif defined(solaris2_HOST_OS) getExecutablePath = readSymbolicLink "/proc/self/path/a.out" -executablePath = Just ((Just <$> getExecutablePath) `catch` f) +executablePath = Just (catchJust f (Just <$> getExecutablePath) (\_ -> pure Nothing)) where -- readlink(2) fails with ENOENT when the executable has been deleted, -- even though the symlink itself still exists according to readdir(3). - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing #endif @@ -297,15 +297,15 @@ getExecutablePath = do ] # endif -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where -- The sysctl fails with errno ENOENT when executable has been deleted; -- see https://gitlab.haskell.org/ghc/ghc/-/issues/12377#note_321346. - f e | isDoesNotExistError e = pure Nothing + f e | isDoesNotExistError e = Just () -- As far as I know, ENOENT is the only kind of failure that should be -- expected and handled. Re-throw other errors. - | otherwise = throw e + | otherwise = Nothing -------------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs ===================================== @@ -319,9 +319,10 @@ ioeSetHandle ioe hdl = ioe{ ioe_handle = Just hdl } ioeSetFileName ioe filename = ioe{ ioe_filename = Just filename } -- | Catch any 'IOError' that occurs in the computation and throw a --- modified version. +-- modified version, preserving the original 'ExceptionContext'. modifyIOError :: (IOError -> IOError) -> IO a -> IO a -modifyIOError f io = catch io (\e -> throwIO (NoBacktrace $ f e)) +modifyIOError f io = catchNoPropagate io $ \(ExceptionWithContext ctx e) -> + rethrowIO (ExceptionWithContext ctx (f e)) -- ----------------------------------------------------------------------------- -- annotating an IOError ===================================== testsuite/tests/exceptions/T27851.hs ===================================== @@ -0,0 +1,7 @@ +import System.IO.Error + +main :: IO () +main = + modifyIOError (`ioeSetLocation` "outer") $ + modifyIOError (`ioeSetLocation` "inner") $ + ioError (mkIOError doesNotExistErrorType "origin" Nothing (Just "file")) ===================================== testsuite/tests/exceptions/T27851.stderr ===================================== @@ -0,0 +1,7 @@ +T27851: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.IOException: + +file: outer: does not exist + +HasCallStack backtrace: + ioError, called at T27851.hs:7:3 in main:Main + ===================================== testsuite/tests/exceptions/T27851b.hs ===================================== @@ -0,0 +1,7 @@ +import Control.Exception + +newtype Wrapped = Wrapped String deriving Show +instance Exception Wrapped + +main :: IO () +main = print (mapException (\(ErrorCall s) -> Wrapped s) (error "boom" :: Int)) ===================================== testsuite/tests/exceptions/T27851b.stderr ===================================== @@ -0,0 +1,7 @@ +T27851b: Uncaught exception main:Main.Wrapped: + +Wrapped "boom" + +HasCallStack backtrace: + error, called at T27851b.hs:7:59 in main:Main + ===================================== testsuite/tests/exceptions/T27851c.hs ===================================== @@ -0,0 +1,22 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + withBinaryFile "T27851c.txt" WriteMode $ \h -> hPutStr h "\xff\n" + run "hGetLine" hGetLine + run "hGetContents'" hGetContents' + run "hGetContents" $ \h -> do + s <- hGetContents h + length s `seq` pure s + +run :: String -> (Handle -> IO String) -> IO () +run name act = do + r <- try $ withFile "T27851c.txt" ReadMode $ \h -> do + hSetEncoding h utf8 + act h + case r of + Left e -> do + putStrLn ("-- " ++ name) + putStrLn (displayExceptionWithInfo e) + Right s -> print s ===================================== testsuite/tests/exceptions/T27851c.stdout ===================================== @@ -0,0 +1,24 @@ +-- hGetLine +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetLine: invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + +-- hGetContents' +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetContents': invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + +-- hGetContents +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetContents: invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + ===================================== testsuite/tests/exceptions/T27851d.hs ===================================== @@ -0,0 +1,11 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + h <- openFile "/dev/full" WriteMode + hPutStr h "x" + r <- try (hClose h) + case r of + Left e -> putStrLn (displayExceptionWithInfo e) + Right () -> putStrLn "no exception" ===================================== testsuite/tests/exceptions/T27851d.stdout ===================================== @@ -0,0 +1,7 @@ +ghc-internal:GHC.Internal.IO.Exception.IOException: + +/dev/full: hClose: resource exhausted (No space left on device) + +HasCallStack backtrace: + ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:293:5 in ghc-internal:GHC.Internal.Foreign.C.Error + ===================================== testsuite/tests/exceptions/all.T ===================================== @@ -1,3 +1,7 @@ test('T25052', normal, compile_and_run, ['']) test('T26759', exit_code(1), compile_and_run, ['']) test('T26759a', exit_code(1), compile_and_run, ['']) +test('T27851', exit_code(1), compile_and_run, ['']) +test('T27851b', exit_code(1), compile_and_run, ['']) +test('T27851c', normal, compile_and_run, ['']) +test('T27851d', unless(opsys('linux'), skip), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b6d5865a17628f8248282a378b2ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b6d5865a17628f8248282a378b2ee… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/annotation-fixes] 6 commits: base: Preserve exception context in modifyIOError
by Zubin (＠wz1000) 30 Sep '26

30 Sep '26

Zubin pushed to branch wip/annotation-fixes at Glasgow Haskell Compiler / GHC Commits: e77fa849 by Zubin Duggal at 2026-09-30T17:35:30+05:30 base: Preserve exception context in modifyIOError Fixes #27851. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/446 - - - - - a1ccd107 by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context in mapException Fixes #27851. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/446 - - - - - 3f5763ba by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in Handle reads Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - e73d713e by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in hClose Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - a8fe1e4c by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in Windows openFile Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - 56e6d5db by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in executablePath Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - 18 changed files: - + changelog.d/clc-446 - + changelog.d/clc-447 - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs - + testsuite/tests/exceptions/T27851.hs - + testsuite/tests/exceptions/T27851.stderr - + testsuite/tests/exceptions/T27851b.hs - + testsuite/tests/exceptions/T27851b.stderr - + testsuite/tests/exceptions/T27851c.hs - + testsuite/tests/exceptions/T27851c.stdout - + testsuite/tests/exceptions/T27851d.hs - + testsuite/tests/exceptions/T27851d.stdout - testsuite/tests/exceptions/all.T Changes: ===================================== changelog.d/clc-446 ===================================== @@ -0,0 +1,7 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in + ``modifyIOError`` and ``mapException``. +issues: #27851 +mrs: !16747 +description: + See `CLC proposal 446 <https://github.com/haskell/core-libraries-committee/issues/446>`_. ===================================== changelog.d/clc-447 ===================================== @@ -0,0 +1,8 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``hGetLine``, + ``hGetContents``, ``hGetContents'``, ``hClose``, ``executablePath``, and on + Windows in ``openFile``, ``openFileBlocking`` and ``openBinaryFile``. +issues: #27875 +mrs: !16747 +description: + See `CLC proposal 447 <https://github.com/haskell/core-libraries-committee/issues/447>`_. ===================================== libraries/base/changelog.md ===================================== @@ -11,6 +11,8 @@ * Add `withEmptyCallStack` to `GHC.Stack`. ([CLC proposal #428](https://github.com/haskell/core-libraries-committee/issues/428)) * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) + * `modifyIOError` now preserves the original `ExceptionContext` instead of annotating the rethrown exception with `WhileHandling`. ([GHC #27851](https://gitlab.haskell.org/ghc/ghc/-/issues/27851)) + * `mapException` now preserves the original `ExceptionContext` instead of annotating the mapped exception with `WhileHandling`. ([GHC #27851](https://gitlab.haskell.org/ghc/ghc/-/issues/27851)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs ===================================== @@ -175,8 +175,8 @@ handleJust p = flip (catchJust p) -- Notice that the usage of 'unsafePerformIO' is safe here. mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a -mapException f v = unsafePerformIO (catch (evaluate v) - (\x -> throwIO (f x))) +mapException f v = unsafePerformIO $ catchNoPropagate (evaluate v) $ + \(ExceptionWithContext ctx x) -> rethrowIO (ExceptionWithContext ctx (f x)) ----------------------------------------------------------------------------- -- 'try' and variations. ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs ===================================== @@ -193,7 +193,7 @@ do_operation fun h act m = do throwTo t e do_operation fun h act m _otherwise -> - throwIO e + rethrowIO (ExceptionWithContext c e) -- Note [async] -- ~~~~~~~~~~~~ @@ -451,7 +451,7 @@ handleFinalizer fp m = do (handle_', mb_exc) <- hClose_help handle_ putMVar m handle_' case mb_exc of - Just exc -> throwIO exc + Just exc -> throwIO (NoBacktrace exc) Nothing -> return () {- @@ -885,8 +885,9 @@ hClose_maybethrow (Just e) h = hClose_rethrow e h hClose_rethrow :: SomeException -> Handle -> IO () hClose_rethrow e h = case fromException e of - Just ioe -> ioError (augmentIOError ioe "hClose" h) - Nothing -> throwIO e + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hClose" h + Nothing -> throwIO (NoBacktrace e) hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) hClose' h m = withHandle' "hClose" h m $ hClose_help ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs ===================================== @@ -52,7 +52,6 @@ import qualified GHC.Internal.IO.Device as RawIO import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Storable -import qualified GHC.Internal.Control.Exception as Exception import GHC.Internal.System.IO.Error import GHC.Internal.Data.Either (Either(..)) import GHC.Internal.Data.Maybe @@ -267,13 +266,14 @@ hGetLineBufferedLoop handle_@Handle__{..} maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) maybeFillReadBuffer handle_ buf - = catchException + = catchNoPropagate (do buf' <- getSomeCharacters handle_ buf return (Just buf') ) - (\e -> do if isEOFError e + (\ec@(ExceptionWithContext _ e) -> + if isEOFError e then return Nothing - else ioError e) + else rethrowIO ec) -- See GHC.Internal.IO.Buffer #define CHARBUF_UTF32 @@ -421,7 +421,7 @@ lazyRead handle = lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyReadBuffered h handle_@Handle__{..} = do buf <- readIORef haCharBuffer - Exception.catch + catchNoPropagate (do buf'@Buffer{..} <- getSomeCharacters handle_ buf lazy_rest <- lazyRead h @@ -432,7 +432,8 @@ lazyReadBuffered h handle_@Handle__{..} = do writeIORef haCharBuffer (bufferAdjustL r buf') return (handle_, s) ) - (\e -> do (handle_', _) <- hClose_help handle_ + (\(ExceptionWithContext ctx e) -> do + (handle_', _) <- hClose_help handle_ debugIO ("hGetContents caught: " ++ show e) -- We might have a \r cached in CRLF mode. So we -- need to check for that and return it: @@ -441,7 +442,8 @@ lazyReadBuffered h handle_@Handle__{..} = do then "\r" else "" else - throw (augmentIOError e "hGetContents" h) + throw $ NoBacktrace $ ExceptionWithContext ctx $ + augmentIOError e "hGetContents" h return (handle_', r) ) @@ -496,7 +498,8 @@ hGetContents' handle = do Right s -> return s Left e -> case fromException e of - Just ioe -> throwIO (augmentIOError ioe "hGetContents'" handle) + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hGetContents'" handle Nothing -> throwIO (NoBacktrace e) strictRead :: Handle -> Handle__ -> IO (Handle__, Either SomeException String) @@ -512,12 +515,13 @@ strictRead h handle_@Handle__{..} = do strictReadLoop :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer] strictReadLoop handle_ cbufs cbuf0 = do - mcbuf <- Exception.catch + mcbuf <- catchNoPropagate (do r <- readTextDevice handle_ cbuf0 return (Just r)) - (\e -> if isEOFError e + (\ec@(ExceptionWithContext _ e) -> + if isEOFError e then return Nothing - else throw e) + else rethrowIO ec) case mcbuf of Nothing -> return (cbuf0 : cbufs) Just cbuf1 -> strictReadLoop' handle_ cbufs cbuf1 ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Internal.Base (String, fmap, otherwise, return, ($)) import qualified GHC.Internal.Base as Rebindable import qualified GHC.Internal.Data.Typeable.Internal as Rebindable import GHC.Internal.MVar +import GHC.Internal.Exception.Type (ExceptionWithContext(..)) import GHC.Internal.IO import GHC.Internal.IO.BufferedIO hiding (flushWriteBuffer) import GHC.Internal.IO.Encoding @@ -114,6 +115,11 @@ addFilePathToIOError :: String -> FilePath -> IOException -> IOException addFilePathToIOError fun fp ioe = ioe{ ioe_location = fun, ioe_filename = Just fp } +catchAndAnnotate :: FilePath -> String -> IO a -> IO a +catchAndAnnotate fp s a = + catchExceptionNoPropagate a $ \(ExceptionWithContext c e) -> + rethrowIO (ExceptionWithContext c (addFilePathToIOError s fp e)) + -- | Computation 'openFile' @file mode@ allocates and returns a new, open -- handle to manage the file @file@. It manages input if @mode@ -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', @@ -142,9 +148,8 @@ addFilePathToIOError fun fp ioe -- be using 'openBinaryFile'. openFile :: FilePath -> IOMode -> IO Handle openFile fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True) - (\e -> ioError (addFilePathToIOError "openFile" fp e)) + catchAndAnnotate fp "openFile" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True -- | Like 'openFile', but opens the file in ordinary blocking mode. -- This can be useful for opening a FIFO for writing: if we open in @@ -154,9 +159,8 @@ openFile fp im = -- @since base-4.4.0.0 openFileBlocking :: FilePath -> IOMode -> IO Handle openFileBlocking fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False) - (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e)) + catchAndAnnotate fp "openFileBlocking" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False -- | Like 'openFile', but open the file in binary mode. -- On Windows, reading a file in text mode (which is the default) @@ -169,9 +173,8 @@ openFileBlocking fp im = openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = - catchException - (openFile' fp m True True) - (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) + catchAndAnnotate fp "openBinaryFile" $ + openFile' fp m True True openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle openFile' filepath iomode binary non_blocking = do ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc ===================================== @@ -44,7 +44,7 @@ executablePath = Nothing import GHC.Internal.Maybe (Maybe(..)) import GHC.Internal.IO (FilePath) #if defined(darwin_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.Real import GHC.Internal.Word @@ -66,7 +66,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Real import GHC.Internal.System.Posix.Internals #elif defined(solaris2_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -75,7 +75,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.System.IO.Error (isDoesNotExistError) import GHC.Internal.System.Posix.Internals #elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -203,10 +203,10 @@ realpath path = getExecutablePath = _NSGetExecutablePath >>= realpath -- realpath(3) fails with ENOENT file does not exist (e.g. was deleted) -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing -------------------------------------------------------------------------------- -- Linux / Solaris / Hurd @@ -242,12 +242,12 @@ executablePath = Just (check <$> getExecutablePath) where # elif defined(solaris2_HOST_OS) getExecutablePath = readSymbolicLink "/proc/self/path/a.out" -executablePath = Just ((Just <$> getExecutablePath) `catch` f) +executablePath = Just (catchJust f (Just <$> getExecutablePath) (\_ -> pure Nothing)) where -- readlink(2) fails with ENOENT when the executable has been deleted, -- even though the symlink itself still exists according to readdir(3). - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing #endif @@ -297,15 +297,15 @@ getExecutablePath = do ] # endif -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where -- The sysctl fails with errno ENOENT when executable has been deleted; -- see https://gitlab.haskell.org/ghc/ghc/-/issues/12377#note_321346. - f e | isDoesNotExistError e = pure Nothing + f e | isDoesNotExistError e = Just () -- As far as I know, ENOENT is the only kind of failure that should be -- expected and handled. Re-throw other errors. - | otherwise = throw e + | otherwise = Nothing -------------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs ===================================== @@ -319,9 +319,10 @@ ioeSetHandle ioe hdl = ioe{ ioe_handle = Just hdl } ioeSetFileName ioe filename = ioe{ ioe_filename = Just filename } -- | Catch any 'IOError' that occurs in the computation and throw a --- modified version. +-- modified version, preserving the original 'ExceptionContext'. modifyIOError :: (IOError -> IOError) -> IO a -> IO a -modifyIOError f io = catch io (\e -> throwIO (NoBacktrace $ f e)) +modifyIOError f io = catchNoPropagate io $ \(ExceptionWithContext ctx e) -> + rethrowIO (ExceptionWithContext ctx (f e)) -- ----------------------------------------------------------------------------- -- annotating an IOError ===================================== testsuite/tests/exceptions/T27851.hs ===================================== @@ -0,0 +1,7 @@ +import System.IO.Error + +main :: IO () +main = + modifyIOError (`ioeSetLocation` "outer") $ + modifyIOError (`ioeSetLocation` "inner") $ + ioError (mkIOError doesNotExistErrorType "origin" Nothing (Just "file")) ===================================== testsuite/tests/exceptions/T27851.stderr ===================================== @@ -0,0 +1,7 @@ +T27851: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.IOException: + +file: outer: does not exist + +HasCallStack backtrace: + ioError, called at T27851.hs:7:3 in main:Main + ===================================== testsuite/tests/exceptions/T27851b.hs ===================================== @@ -0,0 +1,7 @@ +import Control.Exception + +newtype Wrapped = Wrapped String deriving Show +instance Exception Wrapped + +main :: IO () +main = print (mapException (\(ErrorCall s) -> Wrapped s) (error "boom" :: Int)) ===================================== testsuite/tests/exceptions/T27851b.stderr ===================================== @@ -0,0 +1,7 @@ +T27851b: Uncaught exception main:Main.Wrapped: + +Wrapped "boom" + +HasCallStack backtrace: + error, called at T27851b.hs:7:59 in main:Main + ===================================== testsuite/tests/exceptions/T27851c.hs ===================================== @@ -0,0 +1,22 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + withBinaryFile "T27851c.txt" WriteMode $ \h -> hPutStr h "\xff\n" + run "hGetLine" hGetLine + run "hGetContents'" hGetContents' + run "hGetContents" $ \h -> do + s <- hGetContents h + length s `seq` pure s + +run :: String -> (Handle -> IO String) -> IO () +run name act = do + r <- try $ withFile "T27851c.txt" ReadMode $ \h -> do + hSetEncoding h utf8 + act h + case r of + Left e -> do + putStrLn ("-- " ++ name) + putStrLn (displayExceptionWithInfo e) + Right s -> print s ===================================== testsuite/tests/exceptions/T27851c.stdout ===================================== @@ -0,0 +1,24 @@ +-- hGetLine +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetLine: invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + +-- hGetContents' +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetContents': invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + +-- hGetContents +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetContents: invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + ===================================== testsuite/tests/exceptions/T27851d.hs ===================================== @@ -0,0 +1,11 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + h <- openFile "/dev/full" WriteMode + hPutStr h "x" + r <- try (hClose h) + case r of + Left e -> putStrLn (displayExceptionWithInfo e) + Right () -> putStrLn "no exception" ===================================== testsuite/tests/exceptions/T27851d.stdout ===================================== @@ -0,0 +1,7 @@ +ghc-internal:GHC.Internal.IO.Exception.IOException: + +/dev/full: hClose: resource exhausted (No space left on device) + +HasCallStack backtrace: + ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:293:5 in ghc-internal:GHC.Internal.Foreign.C.Error + ===================================== testsuite/tests/exceptions/all.T ===================================== @@ -1,3 +1,7 @@ test('T25052', normal, compile_and_run, ['']) test('T26759', exit_code(1), compile_and_run, ['']) test('T26759a', exit_code(1), compile_and_run, ['']) +test('T27851', exit_code(1), compile_and_run, ['']) +test('T27851b', exit_code(1), compile_and_run, ['']) +test('T27851c', normal, compile_and_run, ['']) +test('T27851d', unless(opsys('linux'), skip), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b6d5865a17628f8248282a378b2ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b6d5865a17628f8248282a378b2ee… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/annotation-fixes] 7 commits: ghci: Drop GHCi's exception context when rethrowing in ghc -e
by Zubin (＠wz1000) 30 Sep '26

30 Sep '26

Zubin pushed to branch wip/annotation-fixes at Glasgow Haskell Compiler / GHC Commits: 27b0f716 by Zubin Duggal at 2026-09-30T17:28:08+05:30 ghci: Drop GHCi's exception context when rethrowing in ghc -e Fixes #27847. - - - - - f0705262 by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context in modifyIOError Fixes #27851. - - - - - 3b92dfeb by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context in mapException See #27851. - - - - - 1725738f by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context when rethrowing exceptions in Handle reads See #27851. - - - - - 1a22ec0b by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context when rethrowing exceptions in hClose See #27851. - - - - - 8c1d30db by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context when rethrowing exceptions in Windows openFile See #27851. - - - - - 2b6d5865 by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context when rethrowing exceptions in executablePath See #27851. - - - - - 26 changed files: - + changelog.d/T27847 - + changelog.d/T27851 - + changelog.d/T27851b - + changelog.d/T27851c - + changelog.d/T27851d - + changelog.d/T27851e - + changelog.d/T27851f - ghc/GHCi/UI/Monad.hs - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs - + testsuite/tests/exceptions/T27851.hs - + testsuite/tests/exceptions/T27851.stderr - + testsuite/tests/exceptions/T27851b.hs - + testsuite/tests/exceptions/T27851b.stderr - + testsuite/tests/exceptions/T27851c.hs - + testsuite/tests/exceptions/T27851c.stdout - + testsuite/tests/exceptions/T27851d.hs - + testsuite/tests/exceptions/T27851d.stdout - testsuite/tests/exceptions/all.T - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/ghc-e/should_run/ghc-e005.stderr Changes: ===================================== changelog.d/T27847 ===================================== @@ -0,0 +1,5 @@ +section: ghci +synopsis: Drop GHCi's own exception context when rethrowing exceptions in + ``ghc -e`` and ``runghc``. +issues: #27847 +mrs: !16747 ===================================== changelog.d/T27851 ===================================== @@ -0,0 +1,4 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``modifyIOError``. +issues: #27851 +mrs: !16747 ===================================== changelog.d/T27851b ===================================== @@ -0,0 +1,4 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``mapException``. +issues: #27851 +mrs: !16747 ===================================== changelog.d/T27851c ===================================== @@ -0,0 +1,5 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``hGetLine``, + ``hGetContents`` and ``hGetContents'``. +issues: #27851 +mrs: !16747 ===================================== changelog.d/T27851d ===================================== @@ -0,0 +1,4 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``hClose``. +issues: #27851 +mrs: !16747 ===================================== changelog.d/T27851e ===================================== @@ -0,0 +1,5 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``openFile``, + ``openFileBlocking`` and ``openBinaryFile`` on Windows. +issues: #27851 +mrs: !16747 ===================================== changelog.d/T27851f ===================================== @@ -0,0 +1,4 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``executablePath``. +issues: #27851 +mrs: !16747 ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -211,7 +211,7 @@ data CommandResult deriving Show cmdSuccess :: MonadThrow m => CommandResult -> m (Maybe Bool) -cmdSuccess CommandComplete{ cmdResult = Left e } = +cmdSuccess CommandComplete{ cmdResult = Left (SomeException e) } = {- Don't add a backtrace from ghci/ghc to the exception from the user program! -} #if MIN_VERSION_base(4,21,0) throwM (NoBacktrace e) ===================================== libraries/base/changelog.md ===================================== @@ -11,6 +11,8 @@ * Add `withEmptyCallStack` to `GHC.Stack`. ([CLC proposal #428](https://github.com/haskell/core-libraries-committee/issues/428)) * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) + * `modifyIOError` now preserves the original `ExceptionContext` instead of annotating the rethrown exception with `WhileHandling`. ([GHC #27851](https://gitlab.haskell.org/ghc/ghc/-/issues/27851)) + * `mapException` now preserves the original `ExceptionContext` instead of annotating the mapped exception with `WhileHandling`. ([GHC #27851](https://gitlab.haskell.org/ghc/ghc/-/issues/27851)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs ===================================== @@ -175,8 +175,8 @@ handleJust p = flip (catchJust p) -- Notice that the usage of 'unsafePerformIO' is safe here. mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a -mapException f v = unsafePerformIO (catch (evaluate v) - (\x -> throwIO (f x))) +mapException f v = unsafePerformIO $ catchNoPropagate (evaluate v) $ + \(ExceptionWithContext ctx x) -> rethrowIO (ExceptionWithContext ctx (f x)) ----------------------------------------------------------------------------- -- 'try' and variations. ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs ===================================== @@ -193,7 +193,7 @@ do_operation fun h act m = do throwTo t e do_operation fun h act m _otherwise -> - throwIO e + rethrowIO (ExceptionWithContext c e) -- Note [async] -- ~~~~~~~~~~~~ @@ -451,7 +451,7 @@ handleFinalizer fp m = do (handle_', mb_exc) <- hClose_help handle_ putMVar m handle_' case mb_exc of - Just exc -> throwIO exc + Just exc -> throwIO (NoBacktrace exc) Nothing -> return () {- @@ -885,8 +885,9 @@ hClose_maybethrow (Just e) h = hClose_rethrow e h hClose_rethrow :: SomeException -> Handle -> IO () hClose_rethrow e h = case fromException e of - Just ioe -> ioError (augmentIOError ioe "hClose" h) - Nothing -> throwIO e + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hClose" h + Nothing -> throwIO (NoBacktrace e) hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) hClose' h m = withHandle' "hClose" h m $ hClose_help ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs ===================================== @@ -52,7 +52,6 @@ import qualified GHC.Internal.IO.Device as RawIO import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Storable -import qualified GHC.Internal.Control.Exception as Exception import GHC.Internal.System.IO.Error import GHC.Internal.Data.Either (Either(..)) import GHC.Internal.Data.Maybe @@ -267,13 +266,14 @@ hGetLineBufferedLoop handle_@Handle__{..} maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) maybeFillReadBuffer handle_ buf - = catchException + = catchNoPropagate (do buf' <- getSomeCharacters handle_ buf return (Just buf') ) - (\e -> do if isEOFError e + (\ec@(ExceptionWithContext _ e) -> + if isEOFError e then return Nothing - else ioError e) + else rethrowIO ec) -- See GHC.Internal.IO.Buffer #define CHARBUF_UTF32 @@ -421,7 +421,7 @@ lazyRead handle = lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyReadBuffered h handle_@Handle__{..} = do buf <- readIORef haCharBuffer - Exception.catch + catchNoPropagate (do buf'@Buffer{..} <- getSomeCharacters handle_ buf lazy_rest <- lazyRead h @@ -432,7 +432,8 @@ lazyReadBuffered h handle_@Handle__{..} = do writeIORef haCharBuffer (bufferAdjustL r buf') return (handle_, s) ) - (\e -> do (handle_', _) <- hClose_help handle_ + (\(ExceptionWithContext ctx e) -> do + (handle_', _) <- hClose_help handle_ debugIO ("hGetContents caught: " ++ show e) -- We might have a \r cached in CRLF mode. So we -- need to check for that and return it: @@ -441,7 +442,8 @@ lazyReadBuffered h handle_@Handle__{..} = do then "\r" else "" else - throw (augmentIOError e "hGetContents" h) + throw $ NoBacktrace $ ExceptionWithContext ctx $ + augmentIOError e "hGetContents" h return (handle_', r) ) @@ -496,7 +498,8 @@ hGetContents' handle = do Right s -> return s Left e -> case fromException e of - Just ioe -> throwIO (augmentIOError ioe "hGetContents'" handle) + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hGetContents'" handle Nothing -> throwIO (NoBacktrace e) strictRead :: Handle -> Handle__ -> IO (Handle__, Either SomeException String) @@ -512,12 +515,13 @@ strictRead h handle_@Handle__{..} = do strictReadLoop :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer] strictReadLoop handle_ cbufs cbuf0 = do - mcbuf <- Exception.catch + mcbuf <- catchNoPropagate (do r <- readTextDevice handle_ cbuf0 return (Just r)) - (\e -> if isEOFError e + (\ec@(ExceptionWithContext _ e) -> + if isEOFError e then return Nothing - else throw e) + else rethrowIO ec) case mcbuf of Nothing -> return (cbuf0 : cbufs) Just cbuf1 -> strictReadLoop' handle_ cbufs cbuf1 ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Internal.Base (String, fmap, otherwise, return, ($)) import qualified GHC.Internal.Base as Rebindable import qualified GHC.Internal.Data.Typeable.Internal as Rebindable import GHC.Internal.MVar +import GHC.Internal.Exception.Type (ExceptionWithContext(..)) import GHC.Internal.IO import GHC.Internal.IO.BufferedIO hiding (flushWriteBuffer) import GHC.Internal.IO.Encoding @@ -114,6 +115,11 @@ addFilePathToIOError :: String -> FilePath -> IOException -> IOException addFilePathToIOError fun fp ioe = ioe{ ioe_location = fun, ioe_filename = Just fp } +catchAndAnnotate :: FilePath -> String -> IO a -> IO a +catchAndAnnotate fp s a = + catchExceptionNoPropagate a $ \(ExceptionWithContext c e) -> + rethrowIO (ExceptionWithContext c (addFilePathToIOError s fp e)) + -- | Computation 'openFile' @file mode@ allocates and returns a new, open -- handle to manage the file @file@. It manages input if @mode@ -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', @@ -142,9 +148,8 @@ addFilePathToIOError fun fp ioe -- be using 'openBinaryFile'. openFile :: FilePath -> IOMode -> IO Handle openFile fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True) - (\e -> ioError (addFilePathToIOError "openFile" fp e)) + catchAndAnnotate fp "openFile" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True -- | Like 'openFile', but opens the file in ordinary blocking mode. -- This can be useful for opening a FIFO for writing: if we open in @@ -154,9 +159,8 @@ openFile fp im = -- @since base-4.4.0.0 openFileBlocking :: FilePath -> IOMode -> IO Handle openFileBlocking fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False) - (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e)) + catchAndAnnotate fp "openFileBlocking" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False -- | Like 'openFile', but open the file in binary mode. -- On Windows, reading a file in text mode (which is the default) @@ -169,9 +173,8 @@ openFileBlocking fp im = openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = - catchException - (openFile' fp m True True) - (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) + catchAndAnnotate fp "openBinaryFile" $ + openFile' fp m True True openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle openFile' filepath iomode binary non_blocking = do ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc ===================================== @@ -44,7 +44,7 @@ executablePath = Nothing import GHC.Internal.Maybe (Maybe(..)) import GHC.Internal.IO (FilePath) #if defined(darwin_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.Real import GHC.Internal.Word @@ -66,7 +66,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Real import GHC.Internal.System.Posix.Internals #elif defined(solaris2_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -75,7 +75,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.System.IO.Error (isDoesNotExistError) import GHC.Internal.System.Posix.Internals #elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -203,10 +203,10 @@ realpath path = getExecutablePath = _NSGetExecutablePath >>= realpath -- realpath(3) fails with ENOENT file does not exist (e.g. was deleted) -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing -------------------------------------------------------------------------------- -- Linux / Solaris / Hurd @@ -242,12 +242,12 @@ executablePath = Just (check <$> getExecutablePath) where # elif defined(solaris2_HOST_OS) getExecutablePath = readSymbolicLink "/proc/self/path/a.out" -executablePath = Just ((Just <$> getExecutablePath) `catch` f) +executablePath = Just (catchJust f (Just <$> getExecutablePath) (\_ -> pure Nothing)) where -- readlink(2) fails with ENOENT when the executable has been deleted, -- even though the symlink itself still exists according to readdir(3). - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing #endif @@ -297,15 +297,15 @@ getExecutablePath = do ] # endif -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where -- The sysctl fails with errno ENOENT when executable has been deleted; -- see https://gitlab.haskell.org/ghc/ghc/-/issues/12377#note_321346. - f e | isDoesNotExistError e = pure Nothing + f e | isDoesNotExistError e = Just () -- As far as I know, ENOENT is the only kind of failure that should be -- expected and handled. Re-throw other errors. - | otherwise = throw e + | otherwise = Nothing -------------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs ===================================== @@ -319,9 +319,10 @@ ioeSetHandle ioe hdl = ioe{ ioe_handle = Just hdl } ioeSetFileName ioe filename = ioe{ ioe_filename = Just filename } -- | Catch any 'IOError' that occurs in the computation and throw a --- modified version. +-- modified version, preserving the original 'ExceptionContext'. modifyIOError :: (IOError -> IOError) -> IO a -> IO a -modifyIOError f io = catch io (\e -> throwIO (NoBacktrace $ f e)) +modifyIOError f io = catchNoPropagate io $ \(ExceptionWithContext ctx e) -> + rethrowIO (ExceptionWithContext ctx (f e)) -- ----------------------------------------------------------------------------- -- annotating an IOError ===================================== testsuite/tests/exceptions/T27851.hs ===================================== @@ -0,0 +1,7 @@ +import System.IO.Error + +main :: IO () +main = + modifyIOError (`ioeSetLocation` "outer") $ + modifyIOError (`ioeSetLocation` "inner") $ + ioError (mkIOError doesNotExistErrorType "origin" Nothing (Just "file")) ===================================== testsuite/tests/exceptions/T27851.stderr ===================================== @@ -0,0 +1,7 @@ +T27851: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.IOException: + +file: outer: does not exist + +HasCallStack backtrace: + ioError, called at T27851.hs:7:3 in main:Main + ===================================== testsuite/tests/exceptions/T27851b.hs ===================================== @@ -0,0 +1,7 @@ +import Control.Exception + +newtype Wrapped = Wrapped String deriving Show +instance Exception Wrapped + +main :: IO () +main = print (mapException (\(ErrorCall s) -> Wrapped s) (error "boom" :: Int)) ===================================== testsuite/tests/exceptions/T27851b.stderr ===================================== @@ -0,0 +1,7 @@ +T27851b: Uncaught exception main:Main.Wrapped: + +Wrapped "boom" + +HasCallStack backtrace: + error, called at T27851b.hs:7:59 in main:Main + ===================================== testsuite/tests/exceptions/T27851c.hs ===================================== @@ -0,0 +1,22 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + withBinaryFile "T27851c.txt" WriteMode $ \h -> hPutStr h "\xff\n" + run "hGetLine" hGetLine + run "hGetContents'" hGetContents' + run "hGetContents" $ \h -> do + s <- hGetContents h + length s `seq` pure s + +run :: String -> (Handle -> IO String) -> IO () +run name act = do + r <- try $ withFile "T27851c.txt" ReadMode $ \h -> do + hSetEncoding h utf8 + act h + case r of + Left e -> do + putStrLn ("-- " ++ name) + putStrLn (displayExceptionWithInfo e) + Right s -> print s ===================================== testsuite/tests/exceptions/T27851c.stdout ===================================== @@ -0,0 +1,24 @@ +-- hGetLine +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetLine: invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + +-- hGetContents' +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetContents': invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + +-- hGetContents +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetContents: invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + ===================================== testsuite/tests/exceptions/T27851d.hs ===================================== @@ -0,0 +1,11 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + h <- openFile "/dev/full" WriteMode + hPutStr h "x" + r <- try (hClose h) + case r of + Left e -> putStrLn (displayExceptionWithInfo e) + Right () -> putStrLn "no exception" ===================================== testsuite/tests/exceptions/T27851d.stdout ===================================== @@ -0,0 +1,7 @@ +ghc-internal:GHC.Internal.IO.Exception.IOException: + +/dev/full: hClose: resource exhausted (No space left on device) + +HasCallStack backtrace: + ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:293:5 in ghc-internal:GHC.Internal.Foreign.C.Error + ===================================== testsuite/tests/exceptions/all.T ===================================== @@ -1,3 +1,7 @@ test('T25052', normal, compile_and_run, ['']) test('T26759', exit_code(1), compile_and_run, ['']) test('T26759a', exit_code(1), compile_and_run, ['']) +test('T27851', exit_code(1), compile_and_run, ['']) +test('T27851b', exit_code(1), compile_and_run, ['']) +test('T27851c', normal, compile_and_run, ['']) +test('T27851d', unless(opsys('linux'), skip), compile_and_run, ['']) ===================================== testsuite/tests/ghc-e/should_fail/T18441fail7.stderr ===================================== @@ -5,10 +5,6 @@ IO error: "Abcde" does not exist While handling ghc-10.1-inplace:GHC.Utils.Panic.GhcException: | | IO error: "Abcde" does not exist - | - | HasCallStack backtrace: - | throw, called at compiler/GHC/Utils/Panic.hs:180:21 in ghc-10.1-inplace:GHC.Utils.Panic - | throwGhcException, called at ghc/GHCi/UI.hs:2851:21 in ghc-bin-10.1.20260801-inplace:GHCi.UI HasCallStack backtrace: throwIO, called at compiler/GHC/Utils/Error.hs:513:19 in ghc-10.1-inplace:GHC.Utils.Error ===================================== testsuite/tests/ghc-e/should_run/ghc-e005.stderr ===================================== @@ -4,8 +4,3 @@ foo HasCallStack backtrace: error, called at ghc-e005.hs:12:10 in main:Main - - -HasCallStack backtrace: - throwIO, called at ghc\GHCi\UI.hs:1655:31 in ghc-bin-10.1.20260629-inplace:GHCi.UI - View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e6b8a645b484e1833839d8fa882370… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e6b8a645b484e1833839d8fa882370… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0