[Git][ghc/ghc][wip/mangoiv/bp-16719] rts: move stack check to the start of the stg_unpack_cstring thunks

30 Oct 2026


      Magnus pushed to branch wip/mangoiv/bp-16719 at Glasgow Haskell Compiler / GHC


Commits:
3abf67a0 by Luite Stegeman at 2026-10-30T15:28:21+01:00
rts: move stack check to the start of the stg_unpack_cstring thunks

fixes a deadlock

see #27272

(cherry picked from commit ff6d941afc5f113f7e8d7487e809584973281c60)

- - - - -


5 changed files:

- + changelog.d/caf-deadlock-27272
- rts/StgStdThunks.cmm
- + testsuite/tests/rts/T27272.hs
- + testsuite/tests/rts/T27272_gen.py
- testsuite/tests/rts/all.T


Changes:

=====================================
changelog.d/caf-deadlock-27272
=====================================
@@ -0,0 +1,5 @@
+section: rts
+synopsis: Fix a deadlock where threads could block forever on a string literal
+  if entering the string literal triggered a stack overflow.
+mrs: !16849
+issues: #27272


=====================================
rts/StgStdThunks.cmm
=====================================
@@ -342,18 +342,11 @@ INFO_TABLE(stg_ap_7_upd,7,0,THUNK,"stg_ap_7_upd_info","stg_ap_7_upd_info")
  *
  */
 
-stg_do_unpack_cstring(P_ node, P_ newCAF_ret) {
-    STK_CHK_PP(WDS(SIZEOF_StgUpdateFrame), stg_do_unpack_cstring, node, newCAF_ret);
-    W_ str;
-    str = StgThunk_payload(node, 2);
-    push (UPDATE_FRAME_FIELDS(,,stg_bh_upd_frame_info, CCCS, 0, newCAF_ret)) {
-        jump %ENTRY_CODE(HsIface_unpackCStringzh_info(W_[ghc_hs_iface]))(node, str);
-    }
-}
-
 INFO_TABLE(stg_unpack_cstring, 0, 0, THUNK_STATIC, "stg_unpack_cstring", "stg_unpack_cstring")
     (P_ node)
 {
+    // The stack check needs to come before newCAF: see #27272
+    STK_CHK_NP(node);
     W_ newCAF_ret;
     (newCAF_ret) = ccall newCAF(BaseReg "ptr", node "ptr");
 
@@ -362,22 +355,19 @@ INFO_TABLE(stg_unpack_cstring, 0, 0, THUNK_STATIC, "stg_unpack_cstring", "stg_un
         // `node` should now be an indirection.
         ENTER(node);
     } else {
-        jump stg_do_unpack_cstring(node, newCAF_ret);
-    }
-}
-
-stg_do_unpack_cstring_utf8(P_ node, P_ newCAF_ret) {
-    STK_CHK_PP(WDS(SIZEOF_StgUpdateFrame), stg_do_unpack_cstring_utf8, node, newCAF_ret);
-    W_ str;
-    str = StgThunk_payload(node, 2);
-    push (UPDATE_FRAME_FIELDS(,,stg_bh_upd_frame_info, CCCS, 0, newCAF_ret)) {
-        jump %ENTRY_CODE(HsIface_unpackCStringUtf8zh_info(W_[ghc_hs_iface]))(node, str);
+        W_ str;
+        str = StgThunk_payload(node, 2);
+        push (UPDATE_FRAME_FIELDS(,,stg_bh_upd_frame_info, CCCS, 0, newCAF_ret)) {
+            jump %ENTRY_CODE(HsIface_unpackCStringzh_info(W_[ghc_hs_iface]))(node, str);
+        }
     }
 }
 
 INFO_TABLE(stg_unpack_cstring_utf8, 0, 0, THUNK_STATIC, "stg_unpack_cstring_utf8", "stg_unpack_cstring_utf8")
     (P_ node)
 {
+    // The stack check needs to come before newCAF: see #27272
+    STK_CHK_NP(node);
     W_ newCAF_ret;
     (newCAF_ret) = ccall newCAF(BaseReg "ptr", node "ptr");
 
@@ -386,6 +376,10 @@ INFO_TABLE(stg_unpack_cstring_utf8, 0, 0, THUNK_STATIC, "stg_unpack_cstring_utf8
         // `node` should now be an indirection.
         ENTER(node);
     } else {
-        jump stg_do_unpack_cstring_utf8(node, newCAF_ret);
+        W_ str;
+        str = StgThunk_payload(node, 2);
+        push (UPDATE_FRAME_FIELDS(,,stg_bh_upd_frame_info, CCCS, 0, newCAF_ret)) {
+            jump %ENTRY_CODE(HsIface_unpackCStringUtf8zh_info(W_[ghc_hs_iface]))(node, str);
+        }
     }
 }


=====================================
testsuite/tests/rts/T27272.hs
=====================================
@@ -0,0 +1,146 @@
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+-- Test for deadlocks related to string literal CAFs
+--
+-- Thread A enters a shared thunk X, and from X a string literal whose stack
+-- check fails while another thread B owns X. threadPaused then suspends A's
+-- work on X. If A still owns the literal, B blocks on it forever (#27272).
+module Main (main) where
+
+import T27272_Lits (asciiLits, utf8Lits)
+
+import Control.Concurrent
+import Control.Exception (evaluate)
+import Control.Monad
+import Data.Char (ord)
+import Data.IORef
+import GHC.Conc (BlockReason (..), ThreadStatus (..), threadStatus)
+import GHC.Exts
+import GHC.IO (IO (..))
+import System.Exit
+import System.Timeout
+#if defined(SELF_CHECK)
+import GHC.Exts.Heap
+  (ClosureType (..), GenClosure (..), StgInfoTable (..), getClosureData)
+#endif
+
+-- | Per literal: the gate (0 until A is in X, 1 once it is, 2 once B is in X
+-- too, 3 once B has claimed X), A's thread id, and for the self check whether
+-- A was suspended at the literal's stack check.
+data Gate = Gate (MutableByteArray# RealWorld) (MVar ThreadId) (IORef Bool)
+
+newGate :: IO Gate
+newGate = do
+  aVar <- newEmptyMVar
+  suspended <- newIORef False
+  IO $ \s -> case newByteArray# 8# s of
+    (# s1, g #) -> case writeIntArray# g 0# 0# s1 of
+      s2 -> (# s2, Gate g aVar suspended #)
+
+readGate :: Gate -> IO Int
+readGate (Gate g _ _) = IO $ \s -> case atomicReadIntArray# g 0# s of
+  (# s', n #) -> (# s', I# n #)
+
+data Box = Box String
+
+-- | Force the boxed string under @n@ one-word return frames. 'lazy' hides
+-- the strictness in @s@, otherwise the string is evaluated before the call.
+-- The frames are only one word with -O (see all.T).
+deepFrames :: Int -> Box -> Int
+deepFrames 0 (Box s) = case lazy s of
+  c : _ -> ord c
+  []    -> -1
+deepFrames n b = 1 + deepFrames (n - 1) b
+{-# NOINLINE deepFrames #-}
+
+-- | Build the shared thunk X for a literal and return it unevaluated.
+-- A's path through X only uses inline primops and does not allocate: any
+-- return to the scheduler would claim X for A. The spin is bounded because it
+-- holds up GC syncs.
+mkShared :: Gate -> String -> IO String
+mkShared gate@(Gate g _ _) lit = return x
+  where
+    x = runRW# (\s0 -> case fetchAddIntArray# g 0# 1# s0 of
+      (# s1, 0# #) -> case spin 100000000# s1 of (# _, () #) -> lit
+      (# s1, _ #) -> case claimX gate lit of
+        IO m -> case m s1 of (# _, r #) -> r)
+    spin :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
+    spin 0# s = (# s, () #)
+    spin n s = case atomicReadIntArray# g 0# s of
+      (# s', 3# #) -> (# s', () #)
+      (# s', _ #) -> spin (n -# 1#) s'
+{-# NOINLINE mkShared #-}
+
+-- | B's part of the gate. The yield calls threadPaused, which claims X for B,
+-- and B only enters the literal once A is blocked (suspended) or done.
+-- It is OPAQUE and returns the literal, so X saves nothing across the call:
+-- X's stack check stays small enough for the literal's check to fail.
+claimX :: Gate -> String -> IO String
+claimX (Gate g aVar suspended) lit = do
+  yield
+  IO $ \s -> (# atomicWriteIntArray# g 0# 3# s, () #)
+  a <- readMVar aVar
+  let waitA = do
+        st <- threadStatus a
+        case st of
+          ThreadRunning -> yield >> waitA
+          ThreadBlocked BlockedOnBlackHole ->
+            writeIORef suspended =<< suspendedAtCheck lit
+          _ -> return ()
+  waitA
+  return lit
+{-# OPAQUE claimX #-}
+
+-- Self check of the test, enabled with -DSELF_CHECK -package ghc-heap: fail
+-- if no literal entry was suspended at the literal's own stack check, i.e. if
+-- the test did not exercise the bug. The literal is then still unevaluated.
+suspendedAtCheck :: String -> IO Bool
+selfCheck :: [Bool] -> IO ()
+#if defined(SELF_CHECK)
+suspendedAtCheck lit = do
+  c <- getClosureData lit
+  return $ case c of
+    ThunkClosure { info = i } -> tipe i == THUNK_STATIC
+    _ -> False
+selfCheck results =
+  unless (or results) $ failWith "no literal entry was suspended"
+#else
+suspendedAtCheck _ = return False
+selfCheck _ = return ()
+#endif
+
+failWith :: String -> IO a
+failWith msg = putStrLn msg >> exitFailure
+
+main :: IO ()
+main = do
+  let expect c fmt = [ (c, c : shows i fmt) | i <- [0 :: Int ..] ]
+      lits = zip3 [0 ..] asciiLits (expect 'A' "-ABCDEFGHIJKLMNOPQRSTUVWXYZ") ++
+             zip3 [0 ..] utf8Lits (expect 'U' "-λμν-ÄÖÜ-€")
+  -- Literal d is entered under d frames. With the stack sizes from all.T this
+  -- crosses stack chunk ends, so the literal's stack check fails for some d.
+  results <- forM lits $ \(d, lit, (c, e)) -> do
+    gate@(Gate _ aVar suspended) <- newGate
+    x <- mkShared gate lit
+    doneA <- newEmptyMVar
+    doneB <- newEmptyMVar
+    -- New threads for each literal, so that A's stack only depends on d. A and
+    -- B have their own capabilities (-N3), so that B runs while A spins.
+    a <- forkOn 1 $ do
+      v <- evaluate (deepFrames d (Box x))
+      putMVar doneA (v == d + ord c && x == e)
+    putMVar aVar a
+    _ <- forkOn 2 $ do
+      -- B must only enter X once A is in it
+      let waitA = do
+            n <- readGate gate
+            when (n == 0) (yield >> waitA)
+      waitA
+      _ <- evaluate x
+      putMVar doneB ()
+    -- With the bug, A blocks on X and B on the literal: the timeout catches it
+    r <- timeout 10000000 (takeMVar doneA <* takeMVar doneB)
+    case r of
+      Just True -> readIORef suspended
+      Just False -> failWith ("wrong result at depth " ++ show d)
+      Nothing -> failWith ("deadlock at depth " ++ show d)
+  selfCheck results


=====================================
testsuite/tests/rts/T27272_gen.py
=====================================
@@ -0,0 +1,22 @@
+#!/usr/bin/env python3
+# usage: T27272_gen.py N > T27272_Lits.hs
+import sys
+
+n = int(sys.argv[1])
+out = sys.stdout
+out.reconfigure(encoding="utf-8")
+
+kinds = [
+    ("a", "asciiLits", "A{}-ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
+    ("u", "utf8Lits", "U{}-λμν-ÄÖÜ-€"),
+]
+
+out.write("module T27272_Lits (asciiLits, utf8Lits) where\n")
+for prefix, list_name, fmt in kinds:
+    out.write("\n")
+    for i in range(n):
+        out.write(f'{prefix}{i} :: String\n{prefix}{i} = "{fmt.format(i)}"\n')
+    out.write(f"\n{list_name} :: [String]\n{list_name} =\n  [ {prefix}0\n")
+    for i in range(1, n):
+        out.write(f"  , {prefix}{i}\n")
+    out.write("  ]\n")


=====================================
testsuite/tests/rts/all.T
=====================================
@@ -647,3 +647,12 @@ test('T27477',
      , only_ways(['threaded1', 'threaded2'])
      ],
      compile_and_run, ['-O2'])
+
+test('T27272',
+     [ req_target_smp
+     , omit_ghci
+     , omit_ways(['hpc'])
+     , pre_cmd('$PYTHON T27272_gen.py 200 > T27272_Lits.hs')
+     , extra_run_opts('+RTS -N3 -ki512 -kc1k -kb128 -RTS')
+     ],
+     multimod_compile_and_run, ['T27272', '-O -threaded -fno-prof-auto'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3abf67a062b6c175f7deb7a765b967f9...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3abf67a062b6c175f7deb7a765b967f9...
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

    

Magnus (＠MangoIV)

tags

participants (1)