[Git][ghc/ghc][wip/9.6.4-backports] 5 commits: Don’t store the async exception masking state in CATCH frames

Zubin (@wz1000) gitlab at gitlab.haskell.org
Thu Dec 14 09:55:03 UTC 2023



Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC


Commits:
ac7978ae by Alexis King at 2023-12-14T15:24:49+05:30
Don’t store the async exception masking state in CATCH frames

(cherry picked from commit 8b61dfd6dfc78bfa6bb9449dac9a336e5d668b5e)
(cherry picked from commit e538003c33251c5c843cac1e30b36f88bb859778)

- - - - -
9b3ae2a6 by Zubin Duggal at 2023-12-14T15:24:49+05:30
Bump array submodule to 0.5.6.0

- - - - -
812a8693 by Matthew Pickering at 2023-12-14T15:24:49+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)

- - - - -
6e841b31 by Matthew Pickering at 2023-12-14T15:24:49+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)

- - - - -
821bddbb by Zubin Duggal at 2023-12-14T15:24:49+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)

- - - - -


15 changed files:

- 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/rts/continuations/T23513.hs
- + testsuite/tests/rts/continuations/T23513.stdout
- testsuite/tests/rts/continuations/all.T
- utils/deriveConstants/Main.hs


Changes:

=====================================
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/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/540c96eb7af7cbca4673a51b9a19498247a2e6ed...821bddbb307829dbc72e145c88af1874cb80d373

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/540c96eb7af7cbca4673a51b9a19498247a2e6ed...821bddbb307829dbc72e145c88af1874cb80d373
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/f96001ac/attachment-0001.html>


More information about the ghc-commits mailing list