+section: rts

+synopsis: Fix a crash when capturing or resuming a delimited continuation that adjusts the async exception masking state

+issues: #27651

+mrs: !16484

+

+description: {

+Capturing a continuation with ``control0#`` from inside ``mask`` or

+``uninterruptibleMask`` left an uninitialised word on the stack while

+restoring the masking state. When the thread had a pending asynchronous

+exception (e.g. from ``throwTo``), raising it walked over that word and

+crashed with a segmentation fault. Resuming such a continuation had the

+same defect.

+}

+section: rts

+synopsis: Fix a segfault that could occur when querying the label of an

+  unlabeled thread.

+issues: #27618

+mrs: !16468

+description: {

+  The ``threadLabel#`` primop returned a null pointer in the ``ByteArray#``

+  field of its result for threads that have no label. This could lead to a

+  crash during garbage collection.

+}

+  -- in 'internSB' and needs to be boxed any way.

+-- | Return the interned 'FastString' for the given bytes, creating and

+-- inserting one on a table miss.

+internSB :: ShortByteString -> IO FastString

+internSB sbs = do

+      new_fs <- mkNewFastStringShortByteString sbs n n_zencs

+    -- NB: Might as well use unsafeDupablePerformIO, since internSB is

+        internSB sbs

+  inlinePerformIO $ internSB sbs

+  inlinePerformIO $ internSB sbs

+    internSB sbs

+type instance XDo            GhcPs = DoAnn

+type DoAnn = (Either (EpToken "[", EpToken "]") AnnList, EpaLocation)

+

+type instance XCmdDo      GhcPs = DoAnn

+mkHsDoAnns     :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> DoAnn -> HsExpr GhcPs

+mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> DoAnn

+                                                 (Right $ stmtlistAnns $2, glR $1)

+                                                 (stmtlistStmts $2) }

+                                              (mkHsDoAnns (MDoExpr $ fmap mkModuleNameFS (getMDO $1))

+                                                          (stmtlistStmts $2)

+                                                          (Right $ stmtlistAnns $2, glR $1))) }

+                ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (Left $ (EpTok ao, EpTok ac), noAnn))

+stmtlist :: { forall b. DisambECP b => PV (LocatedA (AnnList, Located [LocatedA (Stmt GhcPs (LocatedA b))])) }

+                                          amsA' (sLL $1 $> (AnnList (Just (spanAsAnchor $ stmtsLoc $2)) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2)

+                                                           , sL1 $2 $ reverse $ snd $ unLoc $2))}

+                                          amsA' (L (stmtsLoc $2) (AnnList (Just (spanAsAnchor $ stmtsLoc $2)) ListNone (fromOL $ fst $ unLoc $2)

+                                                                 , sL1 $2 $ reverse $ snd $ unLoc $2))}

+                                           amsA' (sLL $1 $> $ mkRecStmt (stmtlistAnns $2, epTok $1)

+stmtlistAnns :: LocatedA (AnnList, a) -> AnnList

+  = ListBraces (EpToken "{") (EpToken "}")

+        mkHsDo, mkSpliceDecl,

+    SrcSpan -> DoAnn -> Maybe ModuleName -> LocatedA [LStmt GhcPs (LocatedA b)] ->

+  mkHsDoPV l ann Nothing stmts = do

+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo ann stmts)

+  mkHsDoPV l _ (Just m) _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m

+  mkHsDoPV l ann mod stmts = do

+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo ann (DoExpr mod) stmts)

+  mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat

+  Sp(0) = mask_frame; // Can't be omitted, see #27651

+  Sp(0) = apply_mask_frame; // Can't be omitted, see #27651

+        return (0, stg_DEAD_SLOT_closure);

+/* ----------------------------------------------------------------------------

+   DEAD_SLOT

+

+   A static nullary constructor for dead pointer-typed result slots

+   that must still hold a valid closure for the GC (see #27618).

+   ------------------------------------------------------------------------- */

+

+INFO_TABLE_CONSTR(stg_DEAD_SLOT,0,0,0,CONSTR_NOCAF,"DEAD_SLOT","DEAD_SLOT")

+{ ccall pbarf("DEAD_SLOT object (%p) entered!", R1 "ptr") never returns; }

+

+CLOSURE(stg_DEAD_SLOT_closure,stg_DEAD_SLOT);

+

+RTS_CLOSURE(stg_DEAD_SLOT_closure);

+RTS_ENTRY(stg_DEAD_SLOT);

+                  (Right

+                   (AnnList

+                    (Just

+                     (EpaSpan { DumpParsedAstComments.hs:16:3 }))

+                    (ListNone)

+                    []))

+                  (Right

+                   (AnnList

+                    (Just

+                     (EpaSpan { DumpSemis.hs:(11,3)-(12,3) }))

+                    (ListNone)

+                    []))

+                        (Right

+                         (AnnList

+                          (Just

+                           (EpaSpan { DumpSemis.hs:11:8-13 }))

+                          (ListBraces

+                           (EpTok (EpaSpan { DumpSemis.hs:11:6 }))

+                           (EpTok (EpaSpan { DumpSemis.hs:11:15 })))

+                          [(EpTok

+                            (EpaSpan { DumpSemis.hs:11:8 }))

+                          ,(EpTok

+                            (EpaSpan { DumpSemis.hs:11:9 }))

+                          ,(EpTok

+                            (EpaSpan { DumpSemis.hs:11:10 }))

+                          ,(EpTok

+                            (EpaSpan { DumpSemis.hs:11:11 }))]))

+                  (Right

+                   (AnnList

+                    (Just

+                     (EpaSpan { DumpSemis.hs:(16,5)-(18,5) }))

+                    (ListBraces

+                     (EpTok (EpaSpan { DumpSemis.hs:16:3 }))

+                     (EpTok (EpaSpan { DumpSemis.hs:19:3 })))

+                    [(EpTok

+                      (EpaSpan { DumpSemis.hs:16:5 }))

+                    ,(EpTok

+                      (EpaSpan { DumpSemis.hs:16:8 }))]))

+                  (Right

+                   (AnnList

+                    (Just

+                     (EpaSpan { DumpSemis.hs:22:12-28 }))

+                    (ListBraces

+                     (EpTok (EpaSpan { DumpSemis.hs:22:10 }))

+                     (EpTok (EpaSpan { DumpSemis.hs:22:30 })))

+                    [(EpTok

+                      (EpaSpan { DumpSemis.hs:22:12 }))

+                    ,(EpTok

+                      (EpaSpan { DumpSemis.hs:22:13 }))]))

+                              (Right

+                               (AnnList

+                                (Just

+                                 (EpaSpan { Test20297.hs:11:22-26 }))

+                                (ListNone)

+                                []))

+                              (Right

+                               (AnnList

+                                (Just

+                                 (EpaSpan { Test20297.ppr.hs:9:20-24 }))

+                                (ListNone)

+                                []))

+{-# LANGUAGE NumericUnderscores #-}

+

+-- Test for a major GC segfault triggered by threadLabel# returning NULL in

+-- a GC pointer field on unlabeled threads. Run with -N4 -A32k.

+

+module Main (main) where

+

+import Control.Concurrent

+import Control.Monad

+import Data.IORef

+import GHC.Conc.Sync (threadLabel)

+import System.Mem (performMajorGC)

+

+{-# NOINLINE queryLabel #-}

+queryLabel :: ThreadId -> IO (Maybe String)

+queryLabel = threadLabel

+

+main :: IO ()

+main = do

+  stop <- newIORef False

+  _ <- forkIO $ forever performMajorGC

+  targets <- replicateM 8 $ forkIO $ forever (threadDelay 1_000_000)

+  dones <- forM [1 :: Int .. 8] $ \_ -> do

+    done <- newEmptyMVar

+    _ <- forkIO $ do

+      let loop = do

+            s <- readIORef stop

+            unless s $ do

+              forM_ targets $ \t -> do

+                r <- queryLabel t

+                r `seq` pure ()

+              loop

+      loop

+      putMVar done ()

+    pure done

+  threadDelay 2_000_000

+  writeIORef stop True

+  mapM_ takeMVar dones

+  putStrLn "done"

+done

+test('T27618',

+     [req_target_smp, omit_ghci],

+     compile_and_run, ['-O2 -threaded -with-rtsopts "-N4 -A32k"'])

+

+-- When capturing or resuming a continuation adjusts the async exception

+-- masking state, the RTS trampolines through a mask/unmask frame, and the

+-- stack must be well-formed at that point: with a blocked exception

+-- pending, the eager raise in stg_unmaskAsyncExceptionszh_ret walks the

+-- whole stack. 

+--

+-- Phase 1 exercises the capture side (stg_control0zh_ll): control0# runs

+-- inside uninterruptibleMask_ while another thread has queued an

+-- exception via throwTo, so the capture unmasks with the exception

+-- pending. The frame evaluated between the unmask frame and the prompt

+-- keeps raw Int# payload live so that a stale word on the stack cannot

+-- masquerade as a valid frame by accident.

+--

+-- Phase 2 exercises the resume side (stg_CONTINUATION_apply): the

+-- continuation is captured while unmasked (inside mask/restore), so

+-- resuming it unmasks, and it is applied from a thread that is masked

+-- with an exception pending.

+import Control.Concurrent

+import Control.Exception

+import Control.Monad

+

+import ContIO

+

+data Boom = Boom deriving Show

+instance Exception Boom

+

+{-# NOINLINE useInts #-}

+useInts :: Int -> Int -> Int -> Int -> Int -> Int

+useInts a b c d e = a + b * c + d * e

+

+rounds :: Int

+rounds = 150

+

+phase1 :: Int -> IO ()

+phase1 i = do

+  mv   <- newEmptyMVar

+  done <- newEmptyMVar

+  let !p = i * 7919 + 3    -- raw ints to live in the continuation frame

+      !q = i * 104729 + 7

+      !u = i * 1299709 + 11

+      !v = i * 15485863 + 13

+  a <- forkIO $

+    handle (\Boom -> void (tryPutMVar done (Left Boom))) $ do

+      tag <- newPromptTag

+      r <- prompt tag $ do

+             x <- uninterruptibleMask_ $ do

+                    putMVar mv ()

+                    threadDelay 2000  -- let the thrower queue its exception

+                    control0 tag (\_k -> pure (42 :: Int))

+             -- continuation frame between the unmask frame and the

+             -- prompt frame, carrying raw Int# payload:

+             pure (useInts x p q u v)

+      void (tryPutMVar done (Right r))

+  takeMVar mv

+  _ <- forkIO $ throwTo a Boom

+  void (takeMVar done)

+

+phase2 :: Int -> IO ()

+phase2 i = do

+  mv   <- newEmptyMVar

+  done <- newEmptyMVar

+  kvar <- newEmptyMVar

+  let !p = i * 7919 + 3

+      !q = i * 104729 + 7

+      !u = i * 1299709 + 11

+      !v = i * 15485863 + 13

+  -- Capture a continuation whose resumption unmasks: the capture happens

+  -- inside restore, so its apply_mask_frame is the unmask frame.

+  _ <- forkIO $ do

+    tag <- newPromptTag

+    _ <- prompt tag $ mask $ \restore -> do

+           x <- restore (control0 tag (\k -> putMVar kvar k >> pure 0))

+           pure (useInts x p q u v)

+    pure ()

+  k <- takeMVar kvar

+  a <- forkIO $

+    handle (\Boom -> void (tryPutMVar done (Left Boom))) $ do

+      r <- uninterruptibleMask_ $ do

+             putMVar mv ()

+             threadDelay 2000  -- let the thrower queue its exception

+             k (pure 42)  -- resuming unmasks with the exception pending

+      void (tryPutMVar done (Right r))

+  takeMVar mv

+  _ <- forkIO $ throwTo a Boom

+  void (takeMVar done)

+

+main :: IO ()

+main = do

+  forM_ [1 .. rounds] phase1

+  forM_ [1 .. rounds] phase2

+  putStrLn "ok"

+ok

+test('T27651', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['T27651', ''])

+markAnnListD :: (Monad m, Monoid w)

+  => Either (EpToken "[", EpToken "]") AnnList

+  -> EP w m a

+  -> EP w m (Either (EpToken "[", EpToken "]") AnnList, a)

+markAnnListD (Left (o,c)) action = do

+  o' <- markEpToken o

+  r <- action

+  c' <- markEpToken c

+  return (Left (o',c'), r)

+markAnnListD (Right ann) action = do

+  (ann',r) <- markAnnList' ann action

+  return (Right ann',r)

+

+  exact (HsDo an do_or_list_comp stmts) = do

+    (an',stmts') <- exactDo an do_or_list_comp stmts

+    return (HsDo an' do_or_list_comp stmts')

+        => DoAnn -> HsDoFlavour -> LocatedAn an a

+        -> EP w m (DoAnn, LocatedAn an a)

+  => DoAnn -> LocatedAn an a -> EP w m (DoAnn, LocatedAn an a)

+      (an0,stmts') <- case an of

+        Left (o,c) -> do

+          o' <- markEpToken o

+          r <- markAnnotated stmts

+          c' <- markEpToken c

+          return (Left (o',c'), r)

+        Right an' -> do

+         (an'',r') <- markAnnListA' an' $ \a -> do

+           r <- markAnnotatedWithLayout stmts

+           return (a, r)

+         return (Right an'',r')

+      return ((an0, l), stmts')

+    else return ((an, l), stmts)

+    (an1,es') <- markAnnListD an0 $ do markAnnotated es