[Git][ghc/ghc][wip/9.6.4-backports] 6 commits: Second fix to #24083
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Thu Dec 14 10:02:06 UTC 2023
Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC
Commits:
02e9904d by Simon Peyton Jones at 2023-12-14T15:31:50+05:30
Second fix to #24083
My earlier fix turns out to be too aggressive for data/type families
See wrinkle (DTV1) in Note [Disconnected type variables]
(cherry picked from commit 2776920e642544477a38d0ed9205d4f0b48a782e)
- - - - -
a5e18815 by Alexis King at 2023-12-14T15:31:50+05:30
Don’t store the async exception masking state in CATCH frames
(cherry picked from commit 8b61dfd6dfc78bfa6bb9449dac9a336e5d668b5e)
(cherry picked from commit e538003c33251c5c843cac1e30b36f88bb859778)
- - - - -
23969083 by Zubin Duggal at 2023-12-14T15:31:50+05:30
Bump array submodule to 0.5.6.0
- - - - -
1bc97aaf by Matthew Pickering at 2023-12-14T15:31:50+05:30
libraries: Bump filepath to 1.4.200.1 and unix to 2.8.4.0
Updates filepath submodule
Updates unix submodule
Fixes #24240
(cherry picked from commit 36b9a38cc45a26865c4e45f4949e519a5dede76d)
- - - - -
35433a7b by Matthew Pickering at 2023-12-14T15:31:50+05:30
Submodule linter: Allow references to tags
We modify the submodule linter so that if the bumped commit is a
specific tag then the commit is accepted.
Fixes #24241
(cherry picked from commit 91ff0971df64b04938d011fe1562320c5d90849a)
- - - - -
0b051faf by Zubin Duggal at 2023-12-14T15:31:50+05:30
hadrian: set -Wno-deprecations for directory and Win32
The filepath bump to 1.4.200.1 introduces a deprecation warning.
See https://gitlab.haskell.org/ghc/ghc/-/issues/24240
https://github.com/haskell/filepath/pull/206
(cherry picked from commit 86f652dc9a649e59e643609c287a510a565f5408)
- - - - -
18 changed files:
- compiler/GHC/Tc/Gen/HsType.hs
- hadrian/src/Settings/Warnings.hs
- libraries/array
- libraries/filepath
- libraries/unix
- linters/lint-submodule-refs/Main.hs
- linters/linters-common/Linters/Common.hs
- rts/Continuation.c
- rts/Exception.cmm
- rts/RaiseAsync.c
- rts/Schedule.c
- rts/include/rts/storage/Closures.h
- + testsuite/tests/polykinds/T24083a.hs
- testsuite/tests/polykinds/all.T
- + testsuite/tests/rts/continuations/T23513.hs
- + testsuite/tests/rts/continuations/T23513.stdout
- testsuite/tests/rts/continuations/all.T
- utils/deriveConstants/Main.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -2535,13 +2535,14 @@ kcCheckDeclHeader_sig sig_kind name flav
-- ^^^^^^^^^
-- We do it here because at this point the environment has been
-- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.
- ; ctx_k <- kc_res_ki
+ ; res_kind :: ContextKind <- kc_res_ki
+
-- Work out extra_arity, the number of extra invisible binders from
-- the kind signature that should be part of the TyCon's arity.
-- See Note [Arity inference in kcCheckDeclHeader_sig]
; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs
- invis_arity = case ctx_k of
+ invis_arity = case res_kind of
AnyKind -> n_invis_tcbs -- No kind signature, so make all the invisible binders
-- the signature into part of the arity of the TyCon
OpenKind -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the
@@ -2555,12 +2556,9 @@ kcCheckDeclHeader_sig sig_kind name flav
, ppr invis_arity, ppr invis_tcbs
, ppr n_invis_tcbs ]
- -- Unify res_ki (from the type declaration) with the residual kind from
- -- the kind signature. Don't forget to apply the skolemising 'subst' first.
- ; case ctx_k of
- AnyKind -> return () -- No signature
- _ -> do { res_ki <- newExpectedKind ctx_k
- ; discardResult (unifyKind Nothing sig_res_kind' res_ki) }
+ -- Unify res_ki (from the type declaration) with
+ -- sig_res_kind', the residual kind from the kind signature.
+ ; checkExpectedResKind sig_res_kind' res_kind
-- Add more binders for data/newtype, so the result kind has no arrows
-- See Note [Datatype return kinds]
@@ -2583,7 +2581,7 @@ kcCheckDeclHeader_sig sig_kind name flav
; implicit_tvs <- zonkTcTyVarsToTcTyVars implicit_tvs
; let implicit_prs = implicit_nms `zip` implicit_tvs
; checkForDuplicateScopedTyVars implicit_prs
- ; checkForDisconnectedScopedTyVars all_tcbs implicit_prs
+ ; checkForDisconnectedScopedTyVars flav all_tcbs implicit_prs
-- Swizzle the Names so that the TyCon uses the user-declared implicit names
-- E.g type T :: k -> Type
@@ -2620,6 +2618,27 @@ kcCheckDeclHeader_sig sig_kind name flav
]
; return tc }
+-- | Check the result kind annotation on a type constructor against
+-- the corresponding section of the standalone kind signature.
+-- Drops invisible binders that interfere with unification.
+checkExpectedResKind :: TcKind -- ^ the result kind from the separate kind signature
+ -> ContextKind -- ^ the result kind from the declaration header
+ -> TcM ()
+checkExpectedResKind _ AnyKind
+ = return () -- No signature in the declaration header
+checkExpectedResKind sig_kind res_ki
+ = do { actual_res_ki <- newExpectedKind res_ki
+
+ ; let -- Drop invisible binders from sig_kind until they match up
+ -- with res_ki. By analogy with checkExpectedKind.
+ n_res_invis_bndrs = invisibleTyBndrCount actual_res_ki
+ n_sig_invis_bndrs = invisibleTyBndrCount sig_kind
+ n_to_inst = n_sig_invis_bndrs - n_res_invis_bndrs
+
+ (_, sig_kind') = splitInvisPiTysN n_to_inst sig_kind
+
+ ; discardResult $ unifyKind Nothing sig_kind' actual_res_ki }
+
matchUpSigWithDecl
:: [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature
-> TcKind -- The tail end of the kind signature
@@ -2987,13 +3006,16 @@ expectedKindInCtxt _ = OpenKind
* *
********************************************************************* -}
-checkForDisconnectedScopedTyVars :: [TcTyConBinder] -> [(Name,TcTyVar)] -> TcM ()
+checkForDisconnectedScopedTyVars :: TyConFlavour -> [TcTyConBinder]
+ -> [(Name,TcTyVar)] -> TcM ()
-- See Note [Disconnected type variables]
-- `scoped_prs` is the mapping gotten by unifying
-- - the standalone kind signature for T, with
-- - the header of the type/class declaration for T
-checkForDisconnectedScopedTyVars sig_tcbs scoped_prs
- = mapM_ report_disconnected (filterOut ok scoped_prs)
+checkForDisconnectedScopedTyVars flav sig_tcbs scoped_prs
+ = when (needsEtaExpansion flav) $
+ -- needsEtaExpansion: see wrinkle (DTV1) in Note [Disconnected type variables]
+ mapM_ report_disconnected (filterOut ok scoped_prs)
where
sig_tvs = mkVarSet (binderVars sig_tcbs)
ok (_, tc_tv) = tc_tv `elemVarSet` sig_tvs
@@ -3070,6 +3092,25 @@ phantom synonym that just discards its argument. So our plan is this:
See #24083 for dicussion of alternatives, none satisfactory. Also the fix is
easy: just add an explicit `@kk` parameter to the declaration, to bind `kk`
explicitly, rather than binding it implicitly via unification.
+
+(DTV1) We only want to make this check when there /are/ scoped type variables; and
+ that is determined by needsEtaExpansion. Examples:
+
+ type C :: x -> y -> Constraint
+ class C a :: b -> Constraint where { ... }
+ -- The a,b scope over the "..."
+
+ type D :: forall k. k -> Type
+ data family D :: kk -> Type
+ -- Nothing for `kk` to scope over!
+
+ In the latter data-family case, the match-up stuff in kcCheckDeclHeader_sig will
+ return [] for `extra_tcbs`, and in fact `all_tcbs` will be empty. So if we do
+ the check-for-disconnected-tyvars check we'll complain that `kk` is not bound
+ to one of `all_tcbs` (see #24083, comments about the `singletons` package).
+
+ The scoped-tyvar stuff is needed precisely for data/class/newtype declarations,
+ where needsEtaExpansion is True.
-}
{- *********************************************************************
=====================================
hadrian/src/Settings/Warnings.hs
=====================================
@@ -30,7 +30,9 @@ ghcWarningsArgs = do
, package binary ? pure [ "-Wno-deprecations" ]
, package bytestring ? pure [ "-Wno-inline-rule-shadowing" ]
, package compiler ? pure [ "-Wcpp-undef" ]
- , package directory ? pure [ "-Wno-unused-imports" ]
+ , package directory ? pure [ "-Wno-unused-imports"
+ , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240
+ ]
, package ghc ? pure [ "-Wcpp-undef"
, "-Wincomplete-uni-patterns"
, "-Wincomplete-record-updates"
@@ -53,5 +55,7 @@ ghcWarningsArgs = do
, "-Wno-redundant-constraints"
, "-Wno-orphans" ]
, package unix ? pure [ "-Wno-deprecations" ]
- , package win32 ? pure [ "-Wno-trustworthy-safe" ]
+ , package win32 ? pure [ "-Wno-trustworthy-safe"
+ , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240
+ ]
, package xhtml ? pure [ "-Wno-unused-imports" ] ] ]
=====================================
libraries/array
=====================================
@@ -1 +1 @@
-Subproject commit f487b8de85f2b271a3831c14ab6439b9bc9b8343
+Subproject commit 0daca5dfa33d6c522e9fb8e94a2b66a5ed658c20
=====================================
libraries/filepath
=====================================
@@ -1 +1 @@
-Subproject commit 367f6bffc158ef1a9055fb876e23447636853aa4
+Subproject commit cdb5171f7774569b1a8028a78392cfa79f732b5c
=====================================
libraries/unix
=====================================
@@ -1 +1 @@
-Subproject commit 720debbf5b89366007bac473e8d7fd18e4114f1a
+Subproject commit 0b3dbc9901fdf2d752c4ee7a7cee7b1ed20e76bd
=====================================
linters/lint-submodule-refs/Main.hs
=====================================
@@ -18,12 +18,12 @@ import System.Exit
-- text
import qualified Data.Text as T
import qualified Data.Text.IO as T
- ( putStrLn )
+ ( putStrLn, putStr )
-- linters-common
import Linters.Common
( GitType(..)
- , gitBranchesContain, gitCatCommit, gitDiffTree, gitNormCid
+ , gitBranchesContain, gitIsTagged, gitCatCommit, gitDiffTree, gitNormCid
)
--------------------------------------------------------------------------------
@@ -51,16 +51,18 @@ main = do
exitWith (ExitFailure 1)
bad <- fmap or $ forM smDeltas $ \(smPath,smCid) -> do
- T.putStrLn $ " - " <> smPath <> " => " <> smCid
+ T.putStr $ " - " <> smPath <> " => " <> smCid
let smAbsPath = dir ++ "/" ++ T.unpack smPath
remoteBranches <- gitBranchesContain smAbsPath smCid
+ isTagged <- gitIsTagged smAbsPath smCid
let (wip, nonWip) = partition ("wip/" `T.isPrefixOf`) originBranches
originBranches = mapMaybe isOriginTracking remoteBranches
isOriginTracking = T.stripPrefix "origin/"
- let bad = null nonWip
- when bad $ do
+ case (nonWip ++ isTagged) of
+ [] -> do
+ T.putStrLn " ... BAD"
T.putStrLn $ " *FAIL* commit not found in submodule repo"
T.putStrLn " or not reachable from persistent branches"
T.putStrLn ""
@@ -70,8 +72,15 @@ main = do
commit <- gitNormCid smAbsPath ("origin/" <> branch)
T.putStrLn $ " - " <> branch <> " -> " <> commit
T.putStrLn ""
- pure bad
+ return True
+ (b:bs) -> do
+ let more = case bs of
+ [] -> ")"
+ rest -> " and " <> T.pack (show (length rest)) <> " more)"
+ T.putStrLn $ "... OK (" <> b <> more
+ return False
if bad
then exitWith (ExitFailure 1)
- else T.putStrLn " OK"
+ else T.putStrLn "OK"
+
=====================================
linters/linters-common/Linters/Common.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -105,6 +106,10 @@ gitBranchesContain d ref = do
return $!! map (T.drop 2) tmp
+gitIsTagged :: FilePath -> GitRef -> Sh [Text]
+gitIsTagged d ref =
+ T.lines <$> runGit d "tag" ["--points-at", ref]
+
-- | returns @[(path, (url, key))]@
--
-- may throw exception
=====================================
rts/Continuation.c
=====================================
@@ -374,12 +374,12 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT
// 1. We walk the stack to find the prompt frame to capture up to (if any).
//
// 2. If we successfully find a matching prompt, we proceed with the actual
- // by allocating space for the continuation, performing the necessary
- // copying, and unwinding the stack.
+ // capture by allocating space for the continuation, performing the
+ // necessary copying, and unwinding the stack.
//
// These variables are modified in Phase 1 to keep track of how far we had to
// walk before finding the prompt frame. Afterwards, Phase 2 consults them to
- // determine how to proceed with the actual capture.
+ // determine how to proceed.
StgWord total_words = 0;
bool in_first_chunk = true;
=====================================
rts/Exception.cmm
=====================================
@@ -393,16 +393,14 @@ stg_killMyself
* kind of return to the activation record underneath us on the stack.
*/
-#define CATCH_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,exceptions_blocked,handler) \
+#define CATCH_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,handler) \
w_ info_ptr, \
PROF_HDR_FIELDS(w_,p1,p2) \
- w_ exceptions_blocked, \
p_ handler
INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME,
- CATCH_FRAME_FIELDS(W_,P_,info_ptr, p1, p2,
- exceptions_blocked,handler))
+ CATCH_FRAME_FIELDS(W_,P_,info_ptr, p1, p2,handler))
return (P_ ret)
{
return (ret);
@@ -411,12 +409,7 @@ INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME,
stg_catchzh ( P_ io, /* :: IO a */
P_ handler /* :: Exception -> IO a */ )
{
- W_ exceptions_blocked;
-
STK_CHK_GEN();
-
- exceptions_blocked =
- TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE);
TICK_CATCHF_PUSHED();
/* Apply R1 to the realworld token */
@@ -424,8 +417,7 @@ stg_catchzh ( P_ io, /* :: IO a */
TICK_SLOW_CALL_fast_v();
jump stg_ap_v_fast
- (CATCH_FRAME_FIELDS(,,stg_catch_frame_info, CCCS, 0,
- exceptions_blocked, handler))
+ (CATCH_FRAME_FIELDS(,,stg_catch_frame_info, CCCS, 0, handler))
(io);
}
@@ -599,26 +591,28 @@ retry_pop_stack:
frame = Sp;
if (frame_type == CATCH_FRAME)
{
+ // Note: if this branch is updated, there is a good chance that
+ // corresponding logic in `raiseAsync` must be updated to match!
+ // See Note [Apply the handler directly in raiseAsync] in RaiseAsync.c.
+
Sp = Sp + SIZEOF_StgCatchFrame;
- if ((StgCatchFrame_exceptions_blocked(frame) & TSO_BLOCKEX) == 0) {
+
+ W_ flags;
+ flags = TO_W_(StgTSO_flags(CurrentTSO));
+ if ((flags & TSO_BLOCKEX) == 0) {
Sp_adj(-1);
Sp(0) = stg_unmaskAsyncExceptionszh_ret_info;
}
/* Ensure that async exceptions are masked when running the handler.
- */
- StgTSO_flags(CurrentTSO) = %lobits32(
- TO_W_(StgTSO_flags(CurrentTSO)) | TSO_BLOCKEX | TSO_INTERRUPTIBLE);
-
- /* The interruptible state is inherited from the context of the
+ *
+ * The interruptible state is inherited from the context of the
* catch frame, but note that TSO_INTERRUPTIBLE is only meaningful
* if TSO_BLOCKEX is set. (we got this wrong earlier, and #4988
* was a symptom of the bug).
*/
- if ((StgCatchFrame_exceptions_blocked(frame) &
- (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) == TSO_BLOCKEX) {
- StgTSO_flags(CurrentTSO) = %lobits32(
- TO_W_(StgTSO_flags(CurrentTSO)) & ~TSO_INTERRUPTIBLE);
+ if ((flags & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) != TSO_BLOCKEX) {
+ StgTSO_flags(CurrentTSO) = %lobits32(flags | TSO_BLOCKEX | TSO_INTERRUPTIBLE);
}
}
else /* CATCH_STM_FRAME */
=====================================
rts/RaiseAsync.c
=====================================
@@ -950,44 +950,36 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
case CATCH_FRAME:
// If we find a CATCH_FRAME, and we've got an exception to raise,
- // then build the THUNK raise(exception), and leave it on
- // top of the CATCH_FRAME ready to enter.
- //
+ // then set up the top of the stack to apply the handler;
+ // see Note [Apply the handler directly in raiseAsync].
{
- StgCatchFrame *cf = (StgCatchFrame *)frame;
- StgThunk *raise;
-
if (exception == NULL) break;
- // we've got an exception to raise, so let's pass it to the
- // handler in this frame.
- //
- raise = (StgThunk *)allocate(cap,sizeofW(StgThunk)+1);
- TICK_ALLOC_SE_THK(WDS(1),0);
- SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
- raise->payload[0] = exception;
+ StgClosure *handler = ((StgCatchFrame *)frame)->handler;
- // throw away the stack from Sp up to the CATCH_FRAME.
- //
- sp = frame - 1;
-
- /* Ensure that async exceptions are blocked now, so we don't get
- * a surprise exception before we get around to executing the
- * handler.
- */
- tso->flags |= TSO_BLOCKEX;
- if ((cf->exceptions_blocked & TSO_INTERRUPTIBLE) == 0) {
- tso->flags &= ~TSO_INTERRUPTIBLE;
- } else {
- tso->flags |= TSO_INTERRUPTIBLE;
+ // Throw away the stack from Sp up to and including the CATCH_FRAME.
+ sp = frame + stack_frame_sizeW((StgClosure *)frame);
+
+ // Unmask async exceptions after running the handler, if necessary.
+ if ((tso->flags & TSO_BLOCKEX) == 0) {
+ sp--;
+ sp[0] = (W_)&stg_unmaskAsyncExceptionszh_ret_info;
}
- /* Put the newly-built THUNK on top of the stack, ready to execute
- * when the thread restarts.
- */
- sp[0] = (W_)raise;
- sp[-1] = (W_)&stg_enter_info;
- stack->sp = sp-1;
+ // Ensure that async exceptions are masked while running the handler;
+ // see Note [Apply the handler directly in raiseAsync].
+ if ((tso->flags & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) != TSO_BLOCKEX) {
+ tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+ }
+
+ // Set up the top of the stack to apply the handler.
+ sp -= 4;
+ sp[0] = (W_)&stg_enter_info;
+ sp[1] = (W_)handler;
+ sp[2] = (W_)&stg_ap_pv_info;
+ sp[3] = (W_)exception;
+
+ stack->sp = sp;
RELAXED_STORE(&tso->what_next, ThreadRunGHC);
goto done;
}
@@ -1079,6 +1071,15 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
};
default:
+ // see Note [Update async masking state on unwind] in Schedule.c
+ if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) {
+ tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE);
+ } else if (*frame == (W_)&stg_maskAsyncExceptionszh_ret_info) {
+ tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+ } else if (*frame == (W_)&stg_maskUninterruptiblezh_ret_info) {
+ tso->flags |= TSO_BLOCKEX;
+ tso->flags &= ~TSO_INTERRUPTIBLE;
+ }
break;
}
@@ -1097,3 +1098,26 @@ done:
return tso;
}
+
+/* Note [Apply the handler directly in raiseAsync]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we encounter a `catch#` frame while unwinding the stack due to an
+async exception, we need to set up the stack to resume execution by
+invoking the exception handler. One natural way to do it would be to
+simply place a `raise#` thunk on the top of the stack, ready to be
+entered. This would effectively convert the asynchronous exception to
+a synchronous one at a point where it’s known to be safe to do so.
+
+However, there is a danger to this strategy: if async exceptions are
+currently unmasked, it becomes possible for a second async exception
+to be delivered before we enter the application of `raise#`, which
+would result in the first exception being lost. The easiest way to
+prevent this race from happening is to have `raiseAsync` set up the
+stack to apply the handler directly, effectively emulating the
+behavior of `raise#`, as this allows exceptions to be preemptively
+masked before returning. This means `raiseAsync` must also push a
+frame to unmask async exceptions after the handler returns if
+necessary, just as `raise#` does.
+
+This strategy results in some logical duplication, but it is correct,
+and the duplicated logic is small enough to be acceptable. */
=====================================
rts/Schedule.c
=====================================
@@ -3019,19 +3019,6 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception)
// thunks which are currently under evaluation.
//
- // OLD COMMENT (we don't have MIN_UPD_SIZE now):
- // LDV profiling: stg_raise_info has THUNK as its closure
- // type. Since a THUNK takes at least MIN_UPD_SIZE words in its
- // payload, MIN_UPD_SIZE is more appropriate than 1. It seems that
- // 1 does not cause any problem unless profiling is performed.
- // However, when LDV profiling goes on, we need to linearly scan
- // small object pool, where raise_closure is stored, so we should
- // use MIN_UPD_SIZE.
- //
- // raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate,
- // sizeofW(StgClosure)+1);
- //
-
//
// Walk up the stack, looking for the catch frame. On the way,
// we update any closures pointed to from update frames with the
@@ -3094,12 +3081,52 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception)
}
default:
+ // see Note [Update async masking state on unwind]
+ if (*p == (StgWord)&stg_unmaskAsyncExceptionszh_ret_info) {
+ tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE);
+ } else if (*p == (StgWord)&stg_maskAsyncExceptionszh_ret_info) {
+ tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+ } else if (*p == (StgWord)&stg_maskUninterruptiblezh_ret_info) {
+ tso->flags |= TSO_BLOCKEX;
+ tso->flags &= ~TSO_INTERRUPTIBLE;
+ }
p = next;
continue;
}
}
}
+/* Note [Update async masking state on unwind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we raise an exception or capture a continuation, we unwind the
+stack by searching for an enclosing `catch#` or `prompt#` frame. If we
+unwind past frames intended to restore the async exception masking
+state, we must take care to reproduce their intended effect in order
+to ensure that async exceptions are properly unmasked or remasked.
+
+On paper, this seems as simple as updating `tso->flags` appropriately,
+but in fact there is one additional wrinkle: when async exceptions are
+*unmasked*, we must eagerly check for a pending async exception and
+raise it if necessary. This is not terribly involved, but it’s not
+trivial, either (see the definition of `stg_unmaskAsyncExceptionszh_ret`),
+so we’d prefer to avoid duplicating that logic in several places.
+
+Fortunately, when we’re unwinding the stack due to a raised exception,
+this detail is actually unimportant: `catch#` implicitly masks async
+exceptions while running the handler as we explicitly *don’t* want the
+thread to be interrupted before it has a chance to handle the
+exception. However, when capturing a continuation, we don’t have this
+luxury, so we take two different strategies:
+
+* When unwinding the stack due to a raised exception (synchonrous or
+ asynchronous), we just update `tso->flags` directly and take no
+ further action.
+
+* When unwinding the stack due to a continuation capture, we update
+ the masking state *indirectly* by pushing an appropriate frame onto
+ the stack before we return. This strategy is described at length
+ in Note [Continuations and async exception masking] in Continuation.c. */
+
/* -----------------------------------------------------------------------------
findRetryFrameHelper
=====================================
rts/include/rts/storage/Closures.h
=====================================
@@ -275,7 +275,6 @@ typedef struct {
// Closure types: CATCH_FRAME
typedef struct {
StgHeader header;
- StgWord exceptions_blocked;
StgClosure *handler;
} StgCatchFrame;
=====================================
testsuite/tests/polykinds/T24083a.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}
+
+module T24083a where
+
+type TyCon :: (k1 -> k2) -> unmatchable_fun
+data family TyCon :: (k1 -> k2) -> unmatchable_fun
=====================================
testsuite/tests/polykinds/all.T
=====================================
@@ -243,3 +243,4 @@ test('T22379a', normal, compile, [''])
test('T22379b', normal, compile, [''])
test('T22743', normal, compile_fail, [''])
test('T24083', normal, compile_fail, [''])
+test('T24083a', normal, compile, [''])
=====================================
testsuite/tests/rts/continuations/T23513.hs
=====================================
@@ -0,0 +1,36 @@
+-- This test checks that restoring a continuation that captures a CATCH frame
+-- properly adjusts the async exception masking state.
+
+import Control.Exception
+import Data.IORef
+
+import ContIO
+
+data E = E deriving (Show)
+instance Exception E
+
+printMaskingState :: IO ()
+printMaskingState = print =<< getMaskingState
+
+main :: IO ()
+main = do
+ tag <- newPromptTag
+ ref <- newIORef Nothing
+ mask_ $ prompt tag $
+ catch (control0 tag $ \k ->
+ writeIORef ref (Just k))
+ (\E -> printMaskingState)
+ Just k <- readIORef ref
+
+ let execute_test = do
+ k (printMaskingState *> throwIO E)
+ printMaskingState
+
+ putStrLn "initially unmasked:"
+ execute_test
+
+ putStrLn "\ninitially interruptibly masked:"
+ mask_ execute_test
+
+ putStrLn "\ninitially uninterruptibly masked:"
+ uninterruptibleMask_ execute_test
=====================================
testsuite/tests/rts/continuations/T23513.stdout
=====================================
@@ -0,0 +1,14 @@
+initially unmasked:
+Unmasked
+MaskedInterruptible
+Unmasked
+
+initially interruptibly masked:
+MaskedInterruptible
+MaskedInterruptible
+MaskedInterruptible
+
+initially uninterruptibly masked:
+MaskedUninterruptible
+MaskedUninterruptible
+MaskedUninterruptible
=====================================
testsuite/tests/rts/continuations/all.T
=====================================
@@ -7,3 +7,5 @@ test('cont_exn_masking', [extra_files(['ContIO.hs'])], multimod_compile_and_run,
test('cont_missing_prompt_err', [extra_files(['ContIO.hs']), exit_code(1)], multimod_compile_and_run, ['cont_missing_prompt_err', ''])
test('cont_nondet_handler', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_nondet_handler', ''])
test('cont_stack_overflow', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_stack_overflow', '-with-rtsopts "-ki1k -kc2k -kb256"'])
+
+test('T23513', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['T23513', ''])
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -482,7 +482,6 @@ wanteds os = concat
,closureField Both "StgUpdateFrame" "updatee"
,closureField C "StgCatchFrame" "handler"
- ,closureField C "StgCatchFrame" "exceptions_blocked"
,closureSize C "StgPAP"
,closureField C "StgPAP" "n_args"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/821bddbb307829dbc72e145c88af1874cb80d373...0b051faf233406906e22c290f00a69277cdbb5ef
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/821bddbb307829dbc72e145c88af1874cb80d373...0b051faf233406906e22c290f00a69277cdbb5ef
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231214/df01b9a6/attachment-0001.html>
More information about the ghc-commits
mailing list