+INFO_TABLE_RET ( stg_block_async, RET_SMALL, W_ info_ptr, W_ len, W_ errCode )

+    return (len, errCode);

+    W_ eintr;

+    (eintr) = ccall rts_EINTR();

+    // Fill the stack frame with values that indicate that the operation

+    // has been interrupted. The IO manager will overwrite these with the

+    // actual results if the async operation completes.

+    Sp_adj(-3);

+    Sp(0) = stg_block_async_info;

+    Sp(1) = -1;                    // len:     -1 indicates error

+    Sp(2) = eintr;                 // errCode: interrupted

+             * BlockedOn{Read,Write,DoProc} uses block_info.async_reqID

+             * which is a plain integer, so nothing to scavenge.

+bool syncIOWaitReady(Capability   *cap,

+            return true;

+            abandonWorkRequest(tso->block_info.async_reqID);

+bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay)

+            return true;

+            tso->block_info.async_reqID = addDelayRequest(us_delay);

+            return true;

+ *

+ * These are called from CMM primops. The ones returing int can perform heap

+ * allocation, which might fail. They return 0 on success, or n > 0 on heap

+ * allocation failure, needing n words. The CMM primops should invoke the

+ * GC to free up at least n words and then retry the operation.

+/* Result is true on success, or false on allocation failure. */

+bool syncIOWaitReady(Capability *cap, StgTSO *tso, IOReadOrWrite rw, HsInt fd);

+/* Result is true on success, or false on allocation failure. */

+bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay);

+    else if((StgPtr)Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) {

+                } else if ((StgPtr)Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) {

+    CBool ok; /* Ok, or heap alloc failure. */

+

+    (ok) = ccall syncIOWaitReady(MyCapability() "ptr", CurrentTSO "ptr",

+                                 /* IORead */ 0::I32, fd);

+    if (ok != 0::CBool) (likely: True) {

+        jump stg_block_noregs();

+    } else {

+        jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure);

+    }

+    CBool ok; /* Ok, or heap alloc failure. */

+

+    (ok) = ccall syncIOWaitReady(MyCapability() "ptr", CurrentTSO "ptr",

+                                 /* IOWrite */ 1::I32, fd);

+    if (ok != 0::CBool) (likely: True) {

+        jump stg_block_noregs();

+    } else {

+        jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure);

+    }

+    CBool ok; /* Ok, or heap alloc failure. */

+    (ok) = ccall syncDelay(MyCapability() "ptr", CurrentTSO "ptr", us_delay);

+

+    if (ok != 0::CBool) (likely: True) {

+        jump stg_block_noregs();

+    } else {

+        jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure);

+    }

+    StgTSO_block_info(CurrentTSO) = reqID;

+    StgTSO_block_info(CurrentTSO) = reqID;

+    StgTSO_block_info(CurrentTSO) = reqID;

+#include "win32/AsyncMIO.h"

+      SymI_HasProto(rts_EINTR)                           \

+    debugBelch("is blocked on proc (request: %" FMT_Word ")", tso->block_info.async_reqID);

+NO_WARN(-Warray-bounds,

+)

+  StgWord async_reqID;

+#include <errno.h>

+#include "win32/AsyncMIO.h"

+

+#if !defined(THREADED_RTS)

+

+                    if (tso->block_info.async_reqID == rID) {

+                        HsInt len     = completedTable[i].len;

+                        HsInt errCode = completedTable[i].errCode;

+                        // For stg_block_async frames (read/write/doProc),

+                        // write len and errCode directly to the stack.

+                        // For stg_block_noregs frames (delay), nothing

+                        // to write.

+                        if (tso->stackobj->sp[0] == (W_)&stg_block_async_info) {

+                            tso->stackobj->sp[1] = (W_)len;

+                            tso->stackobj->sp[2] = (W_)errCode;

+                        }

+

+HsInt rts_EINTR(void)

+{

+    return EINTR;

+}

+extern HsInt rts_EINTR(void);

+{-# OPTIONS_GHC -O -fno-full-laziness #-}

+

+import Control.Concurrent (threadDelay, myThreadId, forkIO, killThread)

+import System.IO.Unsafe (unsafePerformIO)

+import Control.Exception

+import GHC.Exts

+

+compute :: Int

+compute = noinline unsafePerformIO $ do

+    mainThreadID <- myThreadId

+    _ <- forkIO $ do

+        threadDelay 500000

+        killThread mainThreadID

+    threadDelay 1000000

+    return 0

+

+main = do

+    catch (print compute) (\(e :: AsyncException) -> print $ "1:" ++ show e)

+    catch (print compute) (\(e :: AsyncException) -> print $ "2:" ++ show e)

+    print "done"

+"1:thread killed"

+0

+"done"

+-- Test that re-evaluating an AP_STACK from an interrupted async I/O call

+-- does not crash. On Windows non-threaded RTS, re-entry returns EINTR

+-- which readRawBufferPtr converts to IOException Interrupted. On the

+-- threaded RTS (any platform), the blocking read is re-attempted and

+-- succeeds because we write a byte to the pipe between evaluations.

+--

+-- Before the fix for #26341, re-evaluation on Windows would crash or read

+-- uninitialized memory from a freed StgAsyncIOResult.

+{-# OPTIONS_GHC -O -fno-full-laziness #-}

+

+import Control.Concurrent (threadDelay, myThreadId, forkIO, killThread, rtsSupportsBoundThreads)

+import Control.Exception

+import Data.IORef

+import Foreign

+import Foreign.C

+import GHC.Exts

+import GHC.IO.Exception (IOErrorType(..), IOException(..))

+import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr)

+import System.Info (os)

+import System.IO.Unsafe (unsafePerformIO)

+import System.Process (createPipeFd)

+

+-- Store the write fd so main can feed data into the pipe between

+-- evaluations.  On Unix this unblocks the re-entered read; on Windows

+-- stg_block_async returns EINTR regardless.

+{-# NOINLINE writeFdRef #-}

+writeFdRef :: IORef CInt

+writeFdRef = unsafePerformIO $ newIORef (-1)

+

+-- | A thunk whose unsafePerformIO blocks on a pipe read.  A forked

+-- thread kills the main thread after 200ms, which creates an AP_STACK.

+{-# NOINLINE blockedRead #-}

+blockedRead :: ()

+blockedRead = noinline unsafePerformIO $ do

+    (readFd, writeFd) <- createPipeFd

+    writeIORef writeFdRef writeFd

+    buf <- mallocBytes 1

+    mainTid <- myThreadId

+    _ <- forkIO $ do

+        threadDelay 200000  -- 200ms

+        killThread mainTid

+    -- readRawBufferPtr dispatches to asyncReadRawBufferPtr on Windows

+    -- non-threaded RTS; on Unix it uses threadWaitRead + read().

+    _ <- readRawBufferPtr "blockedRead" (FD readFd 0) buf 0 1

+    return ()

+

+main :: IO ()

+main = do

+    -- First evaluation: the thunk blocks on the pipe read, gets killed.

+    catch (evaluate blockedRead)

+          (\(e :: AsyncException) -> putStrLn $ "caught: " ++ show e)

+

+    -- Write a byte so the re-entered read can complete on Unix.

+    wfd <- readIORef writeFdRef

+    buf <- mallocBytes 1

+    poke buf 0

+    _ <- writeRawBufferPtr "unblock" (FD wfd 0) buf 0 1

+

+    -- Second evaluation: AP_STACK re-enters.

+    -- Non-threaded Windows: asyncRead returns (-1, EINTR) → IOException

+    -- Threaded / Unix:      read succeeds → returns normally

+    let expectEINTR = os == "mingw32" && not rtsSupportsBoundThreads

+    result <- try (evaluate blockedRead)

+    case result of

+        Left e

+            | Just ioe <- fromException e

+            , ioe_type (ioe :: IOException) == Interrupted

+            -> putStrLn "re-evaluated ok"

+            | otherwise

+            -> putStrLn $ "unexpected: " ++ show e

+        Right ()

+            | expectEINTR -> putStrLn "unexpected: expected EINTR"

+            | otherwise   -> putStrLn "re-evaluated ok"

+

+    putStrLn "done"

+caught: thread killed

+re-evaluated ok

+done

+-- Stress test for #26341: repeatedly interrupt async-blocked threads and

+-- re-enter their AP_STACKs. Before the fix, re-entering a thunk whose

+-- unsafePerformIO was blocked on an async I/O call (Windows non-threaded

+-- RTS) would read uninitialized memory or free a dangling pointer,

+-- because stg_block_async reserved a stack slot for a heap-allocated

+-- StgAsyncIOResult that became invalid after an async exception.

+--

+-- This test spawns many concurrent workers, each of which:

+--   1. Creates a pipe.

+--   2. Builds a thunk that blocks on a pipe read via unsafePerformIO.

+--   3. Evaluates the thunk and kills it with an async exception.

+--   4. Re-evaluates the thunk (AP_STACK re-entry).

+--   5. Repeats many times.

+--

+-- On threaded RTS / Unix the re-entered read succeeds (we write a byte

+-- first). On Windows non-threaded RTS the re-entered async call returns

+-- EINTR. Both paths exercise the fixed stack-frame layout.

+{-# OPTIONS_GHC -O -fno-full-laziness #-}

+

+import Control.Concurrent

+import Control.Exception

+import Foreign

+import Foreign.C

+import GHC.Exts

+import GHC.IO.Exception (IOErrorType(..), IOException(..))

+import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr)

+import System.IO (hFlush, stdout)

+import System.IO.Unsafe (unsafePerformIO)

+import System.Posix.Internals (c_close)

+import System.Process (createPipeFd)

+

+iterations :: Int

+iterations = 200

+

+workers :: Int

+workers = 4

+

+-- Each worker independently performs `iterations` rounds of:

+-- block on pipe read → interrupt → re-evaluate the AP_STACK.

+worker :: Int -> MVar () -> IO ()

+worker wid done = do

+    buf <- mallocBytes 1

+    let go 0 = return ()

+        go n = do

+            (readFd, writeFd) <- createPipeFd

+

+            -- Build a fresh thunk each iteration so we get a new AP_STACK.

+            let {-# NOINLINE blockedThunk #-}

+                blockedThunk :: ()

+                blockedThunk = noinline unsafePerformIO $ do

+                    tid <- myThreadId

+                    _ <- forkIO $ do

+                        threadDelay 1000  -- 1ms: tight window

+                        killThread tid

+                    _ <- readRawBufferPtr "stress" (FD readFd 0) buf 0 1

+                    return ()

+

+            -- First evaluation: block and get killed.

+            catch (evaluate blockedThunk)

+                  (\(_ :: SomeException) -> return ())

+

+            -- Write a byte so the re-entered read can complete on

+            -- threaded RTS / Unix.

+            poke buf 0

+            _ <- writeRawBufferPtr "unblock" (FD writeFd 0) buf 0 1

+

+            -- Second evaluation: AP_STACK re-entry.

+            result <- try (evaluate blockedThunk)

+            case result of

+                Left e

+                    | Just ioe <- fromException e

+                    , ioe_type (ioe :: IOException) == Interrupted

+                    -> return ()  -- expected on Windows non-threaded

+                    | otherwise

+                    -> throwIO (userError $

+                         "worker " ++ show wid ++ " iteration " ++ show n ++

+                         ": unexpected exception: " ++ show e)

+                Right () -> return ()  -- expected on threaded / Unix

+

+            -- Close the pipe fds.

+            _ <- c_close readFd

+            _ <- c_close writeFd

+

+            go (n - 1)

+

+    go iterations

+    putMVar done ()

+

+main :: IO ()

+main = do

+    dones <- mapM (\wid -> do

+        done <- newEmptyMVar

+        _ <- forkIO (worker wid done)

+        return done

+        ) [1..workers]

+

+    -- Wait for all workers to finish.

+    mapM_ takeMVar dones

+

+    putStrLn "stress test passed"

+    hFlush stdout

+stress test passed

+

+test('T26341', normal, compile_and_run, [''])

+

+# Test EINTR for async I/O interrupted by an exception (#26341)

+test('T26341a'

+    # test uses pipe operations which are not supported by the JS/wasm backends

+    , when(arch('wasm32') or arch('javascript'), skip)

+    , compile_and_run, ['-package process'])

+

+# Stress test: many threads repeatedly interrupt and re-enter async-blocked

+# thunks (#26341). Before the fix, this would crash due to dangling

+# StgAsyncIOResult pointers on the stack.

+test('T26341b'

+    # test uses pipe operations which are not supported by the JS/wasm backends

+    , when(arch('wasm32') or arch('javascript'), skip)

+    , compile_and_run, ['-package process'])

+          ,[]