GitLab

Duncan Coutts pushed to branch wip/dcoutts/io-manager-io-primop-exceptions at Glasgow Haskell Compiler / GHC

Commits:

06eee015

by Luite Stegeman at 2026-09-08T06:03:06+02:00

rts: Fix missing memory barrier in eval_thunk_selector (#27477)

unchain_thunk_selectors() was missing an ACQUIRE_LOAD for the
indirectee, leading to segfaults and corruption during GC on
weakly-ordered architectures.

Fixes #27477

f8b2bd8f

by Alan Zimmerman at 2026-09-08T09:39:12-04:00

EPA Fix HsCmdDo exact print with comments

Exact printing of HsCmdDo was ignoring the location for the do
statements, and this is an annotation that can have comments in it.

Update it so we print the statements as a unit, including any
comments.

Also add the result of auditing that we capture comments in all needed
places, noting that the remaining Anno SrcSpan instances are benign.

430967ab

by Duncan Coutts at 2026-09-09T11:07:01+01:00

Reorder cmm decls in HeapStackCheck for a better logical grouping

And put more section headers in to deliniate the groups.

We're about to add more here, so better to organise it first.

344080fd

by Duncan Coutts at 2026-09-09T11:07:01+01:00

Add raisePrimIOException and add it to RTS<->ghc-internal API

The raisePrimIOException is a new helper function that I/O primops will
use to help them report I/O errors. This is implemented in Haskell
(since that's a lot easier), but has a calling convention that is
easy(ish) to use from Cmm in the I/O primops.

So we add it to the RTS API struct, and since we'll use it from Cmm we
also need a field accessor macro for cmm (in deriveConstants).

See the Note about how we cannot have nice things due to async
exceptions and thunks preventing us from using catch.

cfdb3399

by Duncan Coutts at 2026-09-09T11:07:01+01:00

Add new blocking functions for I/O primops

See the Note [Thread blocking for new I/O primops],
and the Note [Calling convention for raisePrimIOException].

The point is, it will allow us to report synchronous exceptions from I/O
primops, and do so much more flexibly.

Previously the I/O managers could only report async exceptions and only
nullary exceptions. This was OK historically, but no good as we add
more I/O managers and expand the range of I/O operations we support.

f09c09d8

by Duncan Coutts at 2026-09-09T11:07:01+01:00

Change the encoding of results from the I/O manager to I/O primops

Previously we just had async continue or heap overflow.

We now extend what we can report with synchronous success, and
synchronous failure with an errno.

See Note [Encoding of result of I/O manager operations]

We don't use these two new cases yet, but we will. In particular an
epoll I/O manager needs to be able to report synchronous success or
failure for waitRead#/waitWrite#.

30f074d9

by Duncan Coutts at 2026-09-09T11:07:01+01:00

Switch waitRead/Write# to use new blocking return frames

and update the I/O managers to set the result before resuming the
blocked threads.

This makes it possible for I/O managers to report synchronous exceptions
from the I/O primops, but that will be done in a subsequent commit.

a8786ced

by Duncan Coutts at 2026-09-09T11:07:01+01:00

Switch Poll and Select I/O managers to report sync exceptions

rather than using raiseAsync with blockedOnBadFD_closure.

This uses the new mechanism in the blocking frame return code to report
synchronous exceptions.

7a9df79a

by Duncan Coutts at 2026-09-09T11:07:01+01:00

Remove now-unused blockedOnBadFD

It was previously thrown by the select and poll I/O managers, but now
they use raisePrimIOException (with an EBADF errno).

6b0424e3

by Duncan Coutts at 2026-09-09T11:07:01+01:00

Improve the docs for delay# waitRead# and waitWrite#

Document that the waitRead/Write# can throw exceptions (this was true
before too), and that all of them are async exception cancellation
points.

24 changed files:

+ changelog.d/fix-parallel-gc-selector-race-27477
compiler/GHC/Builtin/primops.txt.pp
compiler/GHC/Hs/Doc.hs
compiler/GHC/Hs/Extension/Pass.hs
libraries/ghc-internal/include/RtsIfaceSymbols.h
libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs
libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs
rts/HeapStackCheck.cmm
rts/IOManager.c
rts/IOManager.h
rts/IOManagerInternals.h
rts/Prelude.h
rts/PrimOps.cmm
rts/include/rts/RtsToHsIface.h
rts/include/stg/MiscClosures.h
rts/posix/Poll.c
rts/posix/Poll.h
rts/posix/Select.c
rts/sm/Evac.c
+ testsuite/tests/rts/T27477.hs
+ testsuite/tests/rts/T27477.stdout
testsuite/tests/rts/all.T
utils/check-exact/ExactPrint.hs
utils/deriveConstants/Main.hs

Changes:

changelog.d/fix-parallel-gc-selector-race-27477

 +section: rts
 +synopsis: Fix a parallel GC race on weakly-ordered architectures (AArch64) that could crash or silently corrupt the heap
 +description:
 +  On weakly-ordered architectures such as AArch64 programs using
 +  could crash during parallel garbage collection (segmentation fault
 +  or ``internal error: eval_thunk_selector: strange selectee <n>``) or
 +  continue running with silently corrupted heap data, due to a missing
 +  memory barrier in the parallel GC.
 +mrs: !16488
 +issues: #27477

compiler/GHC/Builtin/primops.txt.pp

@@ -3305,21 +3305,28 @@ section "Delay/wait operations"
  primop  DelayOp "delay#" GenPrimOp
     Int# -> State# s -> State# s
 -   {Sleep specified number of microseconds.}
 +   {Suspend the calling thread for a specified number of microseconds. This
 +    operation is /interruptible/ by async exceptions.}
     with
     effect = ReadWriteEffect
     out_of_line      = True
  primop  WaitReadOp "waitRead#" GenPrimOp
     Int# -> State# s -> State# s
 -   {Block until input is available on specified file descriptor.}
 +   {Suspend the calling thread until input is available (or an I/O error
 +    occurs) on the given file descriptor. This operation can throw exceptions
 +    of type 'IOException'. The operation is also /interruptible/ by async
 +    exceptions.}
     with
     effect = ReadWriteEffect
     out_of_line      = True
  primop  WaitWriteOp "waitWrite#" GenPrimOp
     Int# -> State# s -> State# s
 -   {Block until output is possible on specified file descriptor.}
 +   {Suspend the calling thread until output is possible (or an I/O error
 +    occurs) on the given file descriptor. This operation can throw exceptions
 +    of type 'IOException'. The operation is also /interruptible/ by async
 +    exceptions.}
     with
     effect = ReadWriteEffect
     out_of_line      = True

compiler/GHC/Hs/Doc.hs

@@ -58,6 +58,7 @@ import Language.Haskell.Syntax.Doc
  import Language.Haskell.Syntax.Extension
  import Language.Haskell.Syntax.Module.Name
 +-- Exact print annotations ignore LHsDoc, so bare SrcSpan is fine
  type instance Anno (WithHsDocIdentifiers (HsDocString (GhcPass pass)) (GhcPass pass)) = SrcSpan
  deriving instance (Data pass, Data (LIdP pass), Data a) => Data (WithHsDocIdentifiers a pass)

compiler/GHC/Hs/Extension/Pass.hs

@@ -46,6 +46,7 @@ type instance XRec (GhcPass p) a = XRecGhc a
  -- but pass-independent, source location
  type XRecGhc a = GenLocated (Anno a) a
 +-- Exact print annotations ignore LHsDoc, so bare SrcSpan is fine
  type instance Anno (HsDocString (GhcPass _))  = SrcSpan
  type instance Anno HsDocStringChunk           = SrcSpan

libraries/ghc-internal/include/RtsIfaceSymbols.h

@@ -23,15 +23,11 @@ CLOSURE(GHCziInternalziIOziException, cannotCompactMutable_closure)
  CLOSURE(GHCziInternalziControlziExceptionziBase, nonTermination_closure)
  CLOSURE(GHCziInternalziControlziExceptionziBase, nestedAtomically_closure)
  CLOSURE(GHCziInternalziControlziExceptionziBase, noMatchingContinuationPrompt_closure)
 -#if defined(mingw32_HOST_OS)
 -UNDEF_CLOSURE(GHCziInternalziEventziThread, blockedOnBadFD_closure)
 -#else
 -CLOSURE(GHCziInternalziEventziThread, blockedOnBadFD_closure)
 -#endif
  CLOSURE(GHCziInternalziConcziSync, runSparks_closure)
  CLOSURE(GHCziInternalziConcziIO, ensureIOManagerIsRunning_closure)
  CLOSURE(GHCziInternalziConcziIO, interruptIOManager_closure)
  CLOSURE(GHCziInternalziConcziIO, ioManagerCapabilitiesChanged_closure)
 +CLOSURE(GHCziInternalziConcziIO, raisePrimIOException_info)
  CLOSURE(GHCziInternalziConcziSignal, runHandlersPtr_closure)
  CLOSURE(GHCziInternalziTopHandler, flushStdHandles_closure)
  CLOSURE(GHCziInternalziTopHandler, runMainIO_closure)

libraries/ghc-internal/src/GHC/Internal/Conc/IO.hs

@@ -56,13 +56,19 @@ module GHC.Internal.Conc.IO
          , win32ConsoleHandler
          , toWin32ConsoleEvent
  #endif
 +        , raisePrimIOException -- exported for use within RTS
          ) where
  import GHC.Internal.Base
  import GHC.Internal.Conc.Sync as Sync
  import GHC.Internal.Err (errorWithoutStackTrace)
 +import GHC.Internal.Exception (SomeException, Exception(toException))
 +import qualified GHC.Internal.Foreign.C.Error as C
 +import GHC.Internal.Foreign.C.Types (CInt)
 +import GHC.Internal.Maybe (Maybe(Nothing))
  import GHC.Internal.STM as STM
 -import GHC.Internal.Prim (delay#, waitRead#, waitWrite#)
 +import GHC.Internal.Prim (Int#, State#, RealWorld,
 +                          delay#, waitRead#, waitWrite#, raiseIO#)
  import GHC.Internal.Real ( fromIntegral )
  import GHC.Internal.System.Posix.Types
@@ -249,3 +255,39 @@ registerDelay _usecs
  #if !defined(javascript_HOST_ARCH)
  foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
  #endif
++
++
 +-- ---------------------------------------------------------------------------
 +-- PrimIOException
++
 +-- FIXME: raisePrimIOException throws an IOException, which is not ideal. It is
 +-- not in a position to fill in most of the information for an IOException.
 +-- Much better would be to have a new PrimIOException exception type, and for
 +-- I/O primops to catch that and rethrow with the proper context. In particular
 +-- we do not have a proper location, since that's fundamantally something from
 +-- a higher level library.
 +--
 +-- Unfortunately, catching and throwing converts async exceptions to sync ones.
 +-- This breaks any thunks that, via unsafePerformIO, use such operations. We
 +-- have tests that check for this, e.g. T26341a T26341b. Catching and rethrowing
 +-- here would break those tests.
 +--
 +-- See issue #2558, #24189 and #26368.
++
 +-- | Internal helper funtion used by the in-RTS I\/O managers for reporting
 +-- exceptions. Do not use directly.
 +--
 +-- Do not change the type signature \/ ABI without updating the Cmm callers!
 +-- There is no signature checking for Cmm to Hs calls.
 +--
 +raisePrimIOException :: Int# -> State# RealWorld -> (# State# RealWorld, a #)
 +raisePrimIOException errno# s =
 +    let exception :: SomeException
 +        exception = toException
 +                      (C.errnoToIOError "threadWaitRead/Write"
 +                                        (toCErrno errno#)
 +                                        Nothing Nothing)
 +     in raiseIO# exception s
 +  where
 +    toCErrno :: Int# -> C.Errno
 +    toCErrno e = C.Errno ((fromIntegral :: Int -> CInt) (I# e))

libraries/ghc-internal/src/GHC/Internal/Event/Thread.hs

@@ -23,14 +23,13 @@ import GHC.Internal.Types ()
      , closeFdWith
      , threadDelay
      , registerDelay
 -    , blockedOnBadFD -- used by RTS
      ) where
  -- TODO: Use new Windows I/O manager
  import qualified GHC.Internal.Stack.Types as Rebindable
  import GHC.Internal.Base
 -import GHC.Internal.Control.Exception (finally, SomeException, toException)
 +import GHC.Internal.Control.Exception (finally)
  import GHC.Internal.Data.Foldable (forM_, mapM_, sequence_)
  import GHC.Internal.Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicWriteIORef)
  import GHC.Internal.Data.Maybe (fromMaybe)
@@ -185,10 +184,6 @@ threadWait evt fd = mask_ $ do
      then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing
      else return ()
 --- used at least by RTS in 'select()' IO manager backend
 -blockedOnBadFD :: SomeException
 -blockedOnBadFD = toException $ errnoToIOError "awaitEvent" eBADF Nothing Nothing
+-
  threadWaitSTM :: Event -> Fd -> IO (STM (), IO ())
  threadWaitSTM evt fd = mask_ $ do
    m <- newTVarIO Nothing

rts/HeapStackCheck.cmm

@@ -20,6 +20,7 @@ import ReleaseSRWLockExclusives;
  #if !defined(UnregisterisedCompiler)
  import CLOSURE g0;
  import CLOSURE large_alloc_lim;
 +import CLOSURE ghc_hs_iface;
  import CLOSURE stg_MSG_THROWTO_info;
  import CLOSURE stg_MVAR_DIRTY_info;
  import CLOSURE stg_WHITEHOLE_info;
@@ -40,6 +41,8 @@ import CLOSURE stg_ret_l_info;
  import CLOSURE stg_ret_n_info;
  import CLOSURE stg_ret_p_info;
  import CLOSURE stg_stack_save_entries;
 +import CLOSURE stg_block_io_unit_info;
 +import CLOSURE stg_block_io_int_info;
  #endif
  /* Stack/Heap Check Failure
@@ -694,6 +697,37 @@ stg_block_putmvar (P_ mvar, P_ val)
+    }
+ }
++
 +/* -----------------------------------------------------------------------------
 +   STM-specific waiting
 +   -------------------------------------------------------------------------- */
++
 +stg_block_stmwait
 +{
 +    // When blocking on an MVar we have to be careful to only release
 +    // the lock on the MVar at the very last moment (using
 +    // BLOCK_BUT_FIRST()), since when we release the lock another
 +    // Capability can wake up the thread, which modifies its stack and
 +    // other state.  This is not a problem for STM, because STM
 +    // wakeups are non-destructive; the waker simply calls
 +    // tryWakeupThread() which sends a message to the owner
 +    // Capability.  So the moment we release this lock we might start
 +    // getting wakeup messages, but that's perfectly harmless.
 +    //
 +    // Furthermore, we *must* release these locks, just in case an
 +    // exception is raised in this thread by
 +    // maybePerformBlockedException() while exiting to the scheduler,
 +    // which will abort the transaction, which needs to obtain a lock
 +    // on all the TVars to remove the thread from the queues.
 +    //
 +    ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
 +    BLOCK_GENERIC;
 +}
++
 +/* -----------------------------------------------------------------------------
 +   Blocks for blackholes and throwto
 +   -------------------------------------------------------------------------- */
++
  stg_block_blackhole (P_ node)
+ {
      Sp_adj(-2);
@@ -730,6 +764,13 @@ stg_block_throwto (P_ tso, P_ exception)
+     }
+ }
 +/* -----------------------------------------------------------------------------
 +   Thread blocking for I/O primops
 +   -------------------------------------------------------------------------- */
++
 +/* Thread blocking for primops used only by the win32-legacy I/O manager:
 + * asyncRead, asyncWrite and asyncDoProc.
 + */
  #if defined(mingw32_HOST_OS)
  INFO_TABLE_RET ( stg_block_async, RET_SMALL, W_ info_ptr, W_ len, W_ errCode )
      return ()
@@ -751,32 +792,171 @@ stg_block_async
      Sp(2) = eintr;                 // errCode: interrupted
      BLOCK_GENERIC;
+ }
+-
  #endif
 +/* Note [Thread blocking for new I/O primops]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -/* -----------------------------------------------------------------------------
 -   STM-specific waiting
 -   -------------------------------------------------------------------------- */
 +The classic I/O primops are:
 -stg_block_stmwait
 +  waitRead#, waitWrite# :: Int# -> State# s -> State# s
++
 +Note that they have no result, with wrapper types returning IO (). Each one
 +simply suspends the calling thread until a condition occurs (I/O or time).
++
 +Despite this external simplicity, internally there is more complexity with a
 +number of cases to handle:
++
 +At submission time:
 + - synchronous failure, e.g. bad fd
 + - synchronous success, e.g. waiting on a regular file, which is always ready
 + - proceed asynchronously: block thread, return to scheduler
++
 +Later, at I/O completion, I/O error, or async exception time:
 + - reported failure, e.g. stale fd
 + - success
++
 +The waitRead/Write# also have non-reported failures, such as I/O errors,
 +but these are treated as the success case since these primops are defined to
 +wait for I/O or an error. We only report failures, via exceptions, for cases
 +where it would be unsafe to proceed with a subsequent I/O operation on the
 +same fd. In particular this includes when the fd was closed while a thread was
 +waiting on the fd (since it's very unsafe to read/write an fd that is closed or
 +worse: has been recycled to refer to a different file).
++
 +The synchronous success and failure cases are handled by the initiating
 +primops. In the blocking case, it relies on one of these stg_block_ functions,
 +stack frames, and stack frame info table entry code. The key bits of the
 +mechanism are:
++
 + - The stg_block_ cmm function sets up the stack frame for the blocked thread.
 + - The stack frame entries can be overwritten by the I/O manager, e.g. upon I/O
 +   completion or error.
 + - The stack frame's info table entry code is invoked when the thread is
 +   resumed.
 + - The entries in the stack frame become arguments to the info table entry code.
 + - The result(s) returned by the info table entry code _are_ the result(s) of
 +   the I/O primop.
++
 +It is important to keep clear the distinction between the stack frame entries
 +and the final primop result(s): the stack frame's info table entry code
 +transforms the former into the latter.
++
 +The convention we follow is that the stack frame contains two fields:
 + - an outcome, using IOOpOutcome values: in-flight, success, failed, cancelled.
 + - a result or error code. For outcome success it is a result. For failed it is
 +   the error code (using posix errno codes), while for cancelled and in-flight
 +   outcomes there is no result.
++
 +This outcome+result/failure encoding is exactly the same as the corresponding
 +fields in the StgAsyncIOOp. One day we might just use the StgAsyncIOOp itself,
 +once all I/O managers use them.
++
 +The waitRead/waitWrite# primops do not use a result, but later I/O primops will
 +do. In particular read/write on files return a length, and other I/O primitives
 +also have a single result.
++
 +So this gives us two block functions and corresponding info tables:
++
 + 1. stg_block_io_unit: with a stack frame containing outcome+result/failure.
 +    On resume, throw exception on failure and otherwise return no args.
 +    This is for primops with result IO ().
++
 + 2. stg_block_io_int: with a stack frame containing outcome+result/failure.
 +    On resume, throw exception on failure and otherwise return result.
 +    This is for primops with result IO Int or IO Word.
++
 + 3. stg_block_io_aiop: in future if we add async I/O primitives that return an
 +    StgAsyncIOOp we would also need versions that return that (since even
 +    submitting async I/O can block if there's too much I/O in flight).
++
 +The stack frame layout used is:
 + Sp[0]   stg_block_io_unit_info or stg_block_io_int_info
 + Sp[1]   outcome
 + Sp[2]   result or error
++
 +C code should use setTsoIOOpOutcome to set this. But update this if the layout
 +changes!
++
++
 +Note [Calling convention for raisePrimIOException]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
++
 +In cases 1 & 2 we check the outcome and, on failure, we throw an exception. Our
 +approach is to use a helper function implemeted in generated Haskell code, in
 +ghc-internal. We need to perform a tail call to this helper function:
++
 +    raisePrimIOException :: Int# -> State# s -> (# State# s, a #)
++
 +The calling convention for top-level generated Haskell function like this uses
 +R2 because it has two arguments -- the Int# and State# -- but the State#
 +argument has a zero-width repesentation. The cmm call uses R1, R2, ... etc so
 +to pass in R2 we have to use a dummy first argument which will be passed in R1
 +(and ignored).
 +*/
++
 +/* stg_block_io_unit_info : the return info table for stg_block_io_unit */
 +INFO_TABLE_RET ( stg_block_io_unit, RET_SMALL, W_ info_ptr,
 +                 W_ outcome, W_ result )
 +    return ()
+ {
 -    // When blocking on an MVar we have to be careful to only release
 -    // the lock on the MVar at the very last moment (using
 -    // BLOCK_BUT_FIRST()), since when we release the lock another
 -    // Capability can wake up the thread, which modifies its stack and
 -    // other state.  This is not a problem for STM, because STM
 -    // wakeups are non-destructive; the waker simply calls
 -    // tryWakeupThread() which sends a message to the owner
 -    // Capability.  So the moment we release this lock we might start
 -    // getting wakeup messages, but that's perfectly harmless.
 -    //
 -    // Furthermore, we *must* release these locks, just in case an
 -    // exception is raised in this thread by
 -    // maybePerformBlockedException() while exiting to the scheduler,
 -    // which will abort the transaction, which needs to obtain a lock
 -    // on all the TVars to remove the thread from the queues.
 -    //
 -    ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
 +    if (outcome == 2 :: W_ /*IOOpOutcomeFailed*/) (likely: False) {
 +        /* See Note [Calling convention for raisePrimIOException] */
 +        W_ dummyR1;
 +        dummyR1 = 0;
 +        jump %ENTRY_CODE(HsIface_raisePrimIOException_info(W_[ghc_hs_iface]))
 +             (dummyR1, result);
 +    } else {
 +        /* success or cancelled outcomes */
 +        return ();
 +    }
 +}
++
 +/* Blocking for I/O primops with result IO ().
 + * See Note [Thread blocking for new I/O primops].
 + */
 +stg_block_io_unit
 +{
 +    /* Fill out the stack frame with dummy values. The IO manager will
 +     * overwrite these with the actual results when the I/O operation
 +     * completes, fails, or is cancelled.
 +     */
 +    Sp_adj(-3);
 +    Sp(0) = stg_block_io_unit_info;
 +    Sp(1) = 0;                    // outcome: 0 indicates IOOpOutcomeInFlight
 +    Sp(2) = 0;                    // result/errno
 +    BLOCK_GENERIC;
 +}
++
 +/* stg_block_io_int_info : the return info table for stg_block_io_int */
 +INFO_TABLE_RET ( stg_block_io_int, RET_SMALL, W_ info_ptr,
 +                 W_ outcome, W_ result )
 +    return ()
 +{
 +    if (outcome == 2 :: W_ /*IOOpOutcomeFailed*/) (likely: False) {
 +        /* See Note [Calling convention for raisePrimIOException] */
 +        W_ dummyR1;
 +        dummyR1 = 0;
 +        jump %ENTRY_CODE(HsIface_raisePrimIOException_info(W_[ghc_hs_iface]))
 +             (dummyR1, result);
 +    } else {
 +        /* success or cancelled outcomes */
 +        return (result);
 +    }
 +}
++
 +/* Blocking for I/O primops with result IO Int or Word (or rather Int#/Word#).
 + * See Note [Thread blocking for new I/O primops].
 + */
 +stg_block_io_int
 +{
 +    /* Fill out the stack frame with dummy values. The IO manager will
 +     * overwrite these with the actual results when the I/O operation
 +     * completes, fails, or is cancelled.
 +     */
 +    Sp_adj(-3);
 +    Sp(0) = stg_block_io_int_info;
 +    Sp(1) = 0;                    // outcome: 0 indicates IOOpOutcomeInFlight
 +    Sp(2) = 0;                    // result/errno
      BLOCK_GENERIC;
+ }

rts/IOManager.c

@@ -399,21 +399,6 @@ void startIOManager(void)
      switch (iomgr_type) {
 -#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_POLL)
 -#if defined(IOMGR_ENABLED_SELECT)
 -        case IO_MANAGER_SELECT:
 -#endif
 -#if defined(IOMGR_ENABLED_POLL)
 -        case IO_MANAGER_POLL:
 -#endif
 -            /* Make the exception CAF a GC root. See initBuiltinGcRoots for
 -             * similar examples. We throw this exception if a thread tries to
 -             * wait on an invalid FD.
 -             */
 -            getStablePtr((StgPtr)blockedOnBadFD_closure);
 -            break;
 -#endif
+-
  #if defined(IOMGR_ENABLED_MIO_POSIX)
          case IO_MANAGER_MIO_POSIX:
              /* Posix implementation in posix/Signals.c
@@ -776,10 +761,10 @@ void interruptIOManager(CapIOManager *iomgr)
  /* CMM primop. Result is true on success, or false on allocation failure. */
 -bool syncIOWaitReady(CapIOManager *iomgr,
 -                     StgTSO       *tso,
 -                     IOReadOrWrite rw,
 -                     HsInt         fd)
 +IOSubmitResult syncIOWaitReady(CapIOManager *iomgr,
 +                               StgTSO       *tso,
 +                               IOReadOrWrite rw,
 +                               HsInt         fd)
+ {
      debugTrace(DEBUG_iomanager,
                 "thread %ld waiting for %s I/O readiness on fd %d",
@@ -795,7 +780,7 @@ bool syncIOWaitReady(CapIOManager *iomgr,
              tso->block_info.fd = fd;
              appendToIOBlockedQueue(iomgr, tso);
              RELEASE_STORE(&tso->why_blocked, why_blocked);
 -            return true;
 +            return IOSubmitResultAsyncContinue;
+         }
  #endif
  #if defined(IOMGR_ENABLED_POLL)

rts/IOManager.h

@@ -325,8 +325,33 @@ typedef enum { IORead = 0, IOWrite = 1 } IOReadOrWrite;
   * false on heap allocation failure.
   */
 +/* Note [Encoding of result of I/O manager operations]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +We have quite a bit of information that to return from the I/O manager calls
 +back to the I/O primops. It (somewhat uncomfortably) fits into a C int.
++
 +We use the following encoding of the result:
++
 + * negative: synchronous failure, with -errno as the result.
 + * 0: ok, result successful, proceed to async: suspend the TSO.
 + * 1: synchronous success, return without suspending the TSO. This can occur
 +      for example when waiting on readiness of a regular file (which is always
 +      ready).
 + * 2: heap overflow
 + * >2: unallocated status codes
 +*/
 +typedef int IOSubmitResult;
++
 +/* Provide constants for IOSubmitResult */
 +enum IOSubmitResultCodes {
 +  /* negative numbers are -errno error codes */
 +  IOSubmitResultAsyncContinue = 0,
 +  IOSubmitResultSyncSuccess   = 1,
 +  IOSubmitResultHeapOverflow  = 2
 +};
++
  /* Called from CMM primop */
 -bool syncIOWaitReady(CapIOManager *iomgr, StgTSO *tso, IOReadOrWrite rw, HsInt fd);
 +IOSubmitResult syncIOWaitReady(CapIOManager *iomgr, StgTSO *tso, IOReadOrWrite rw, HsInt fd);
  void syncIOCancel(CapIOManager *iomgr, StgTSO *tso);

rts/IOManagerInternals.h

@@ -81,5 +81,25 @@ struct _CapIOManager {
  };
 +/* Fill in the outcome and result/error on the TSO's stack frame.
 + * The TSO must be blocked using one of the stg_block_io_* blocking actions.
 + *
 + * Once the thread is resumed (by the scheduler) the code for stg_block_*_info
 + * will pick up the info from the stack frame and use it to see if there's been
 + * a failure, and if so to raise a PrimIOException.
 + *
 + * See Note [Thread blocking for new I/O primops].
 + */
 +INLINE_HEADER void setTsoIOOpOutcome (StgTSO *tso,
 +                                      enum IOOpOutcome outcome,
 +                                      uint32_t result)
 +{
 +    ASSERT((StgPtr *)tso->stackobj->sp[0] == (StgPtr *)&stg_block_io_unit_info
 +        || (StgPtr *)tso->stackobj->sp[0] == (StgPtr *)&stg_block_io_int_info);
++
 +    tso->stackobj->sp[1] = (W_)outcome;
 +    tso->stackobj->sp[2] = (W_)result;
 +}
++
  #include "EndPrivate.h"

rts/Prelude.h

@@ -65,8 +65,6 @@ extern StgClosure ZCMain_main_closure;
  #define overflowException_closure ghc_hs_iface->overflowException_closure
  #define divZeroException_closure  ghc_hs_iface->divZZeroException_closure
 -#define blockedOnBadFD_closure    ghc_hs_iface->blockedOnBadFD_closure
+-
  #define Czh_con_info              ghc_hs_iface->Czh_con_info
  #define Izh_con_info              ghc_hs_iface->Izh_con_info
  #define Fzh_con_info              ghc_hs_iface->Fzh_con_info

rts/PrimOps.cmm

@@ -2297,32 +2297,60 @@ stg_whereFromzh (P_ clos, W_ buf)
     Thread I/O blocking primitives
     -------------------------------------------------------------------------- */
 -stg_waitReadzh ( W_ fd )
 +stg_handleIOSubmitResult ( CInt result )
+ {
 -    CBool ok; /* Ok, or heap alloc failure. */
 +    /* See Note [Encoding of result of I/O manager operations] */
 -    (ok) = ccall syncIOWaitReady(Capability_iomgr(MyCapability()) "ptr",
 -                                 CurrentTSO "ptr",
 -                                 /* IORead */ 0::CInt, fd);
 -    if (ok != 0::CBool) (likely: True) {
 -        jump stg_block_noregs();
 -    } else {
 +    /* case IOSubmitResultAsyncContinue */
 +    if (result == 0::CInt) (likely: True) {
 +        /* See Note [Thread blocking for new I/O primops] */
 +        jump stg_block_io_unit();
 +    }
++
 +    /* case IOSubmitResultSyncSuccess*/
 +    if (result == 1::CInt) (likely: True) {
 +        /* Success, don't even go via scheduler. */
 +        return ();
 +    }
++
 +    /* negative numbers are -errno error codes */
 +    if (result < 0::CInt) {
 +        /* See Note [Calling convention for raisePrimIOException] */
 +        W_ dummyR1; W_ errno;
 +        dummyR1 = 0;
 +        errno   = TO_W_(-result);
 +        jump %ENTRY_CODE(HsIface_raisePrimIOException_info(W_[ghc_hs_iface]))
 +                                                          (dummyR1, errno);
 +    }
++
 +    /* case IOSubmitResultHeapOverflow */
 +    if (result == 2::CInt) {
          jump stg_raisezh(HsIface_heapOverflow_closure(W_[ghc_hs_iface]));
++
+     }
 +    ccall sbarf("syncIOWaitReady result encoding error") never returns;
 +}
++
 +stg_waitReadzh ( W_ fd )
 +{
 +    CInt result;
++
 +    (result) = ccall syncIOWaitReady(Capability_iomgr(MyCapability()) "ptr",
 +                                     CurrentTSO "ptr",
 +                                     /* IORead */ 0::CInt, fd);
++
 +    jump stg_handleIOSubmitResult(result);
+ }
  stg_waitWritezh ( W_ fd )
+ {
 -    CBool ok; /* Ok, or heap alloc failure. */
 +    CInt result;
 -    (ok) = ccall syncIOWaitReady(Capability_iomgr(MyCapability()) "ptr",
 -                                 CurrentTSO "ptr",
 -                                 /* IOWrite */ 1::CInt, fd);
 -    if (ok != 0::CBool) (likely: True) {
 -        jump stg_block_noregs();
 -    } else {
 -        jump stg_raisezh(HsIface_heapOverflow_closure(W_[ghc_hs_iface]));
 -    }
 +    (result) = ccall syncIOWaitReady(Capability_iomgr(MyCapability()) "ptr",
 +                                     CurrentTSO "ptr",
 +                                     /* IOWrite */ 1::CInt, fd);
++
 +    jump stg_handleIOSubmitResult(result);
+ }
  stg_delayzh ( W_ us_delay )

rts/include/rts/RtsToHsIface.h

@@ -28,7 +28,7 @@ typedef struct {
      StgClosure *nonTermination_closure;  // GHC.Internal.Control.Exception.Base.nonTermination_closure
      StgClosure *nestedAtomically_closure;  // GHC.Internal.Control.Exception.Base.nestedAtomically_closure
      StgClosure *noMatchingContinuationPrompt_closure;  // GHC.Internal.Control.Exception.Base.noMatchingContinuationPrompt_closure
 -    StgClosure *blockedOnBadFD_closure;  // GHC.Internal.Event.Thread.blockedOnBadFD_closure
 +    StgClosure *raisePrimIOException_info; // GHC.Internal.Conc.IO.raisePrimIOException_info
      StgClosure *runSparks_closure;  // GHC.Internal.Conc.Sync.runSparks_closure
      StgClosure *ensureIOManagerIsRunning_closure;  // GHC.Internal.Conc.IO.ensureIOManagerIsRunning_closure
      StgClosure *interruptIOManager_closure;  // GHC.Internal.Conc.IO.interruptIOManager_closure

rts/include/stg/MiscClosures.h

@@ -369,6 +369,7 @@ RTS_FUN_DECL(stg_gc_bpp);
  RTS_RET(stg_gc_fun);
  RTS_FUN_DECL(__stg_gc_fun);
 +/* Blocking for various primops */
  RTS_FUN_DECL(stg_yield_noregs);
  RTS_FUN_DECL(stg_yield_to_interpreter);
  RTS_FUN_DECL(stg_block_noregs);
@@ -380,13 +381,19 @@ RTS_RET(stg_block_takemvar);
  RTS_RET(stg_block_readmvar);
  RTS_FUN_DECL(stg_block_putmvar);
  RTS_RET(stg_block_putmvar);
 +RTS_FUN_DECL(stg_block_stmwait);
 +RTS_FUN_DECL(stg_block_throwto);
 +RTS_RET(stg_block_throwto);
++
 +/* Blocking for I/O primops */
 +RTS_FUN_DECL(stg_block_io_unit);
 +RTS_RET(stg_block_io_unit);
 +RTS_FUN_DECL(stg_block_io_int);
 +RTS_RET(stg_block_io_int);
  #if defined(mingw32_HOST_OS)
  RTS_FUN_DECL(stg_block_async);
  RTS_RET(stg_block_async);
  #endif
 -RTS_FUN_DECL(stg_block_stmwait);
 -RTS_FUN_DECL(stg_block_throwto);
 -RTS_RET(stg_block_throwto);
  /* Entry/exit points from StgStartup.cmm */

rts/posix/Poll.c

@@ -20,7 +20,6 @@
  #include "Prelude.h"
  #include "RtsUtils.h"
  #include "rts/Time.h"
 -#include "RaiseAsync.h"
  #include "Trace.h"
  #include "Poll.h"
@@ -171,14 +170,13 @@ void freeCapabilityIOManagerPoll(CapIOManager *iomgr)
+ }
 -/* Used to implement syncIOWaitReady.
 - * Result is true on success, or false on allocation failure. */
 -bool syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
 -                         IOReadOrWrite rw, HsInt fd)
 +/* Used to implement syncIOWaitReady. */
 +IOSubmitResult syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
 +                                   IOReadOrWrite rw, HsInt fd)
+ {
      StgAsyncIOOp *aiop;
      aiop = (StgAsyncIOOp *)allocateMightFail(iomgr->cap, sizeofW(StgAsyncIOOp));
 -    if (RTS_UNLIKELY(aiop == NULL)) return false;
 +    if (RTS_UNLIKELY(aiop == NULL)) return IOSubmitResultHeapOverflow;
      SET_HDR(aiop, &stg_ASYNCIOOP_info, iomgr->cap->r.rCCCS);
      aiop->notify.tso     = tso;
      aiop->notify_type    = NotifyTSO;
@@ -189,13 +187,12 @@ bool syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
      return asyncIOWaitReadyPoll(iomgr, aiop, rw, fd);
+ }
 -/* Result is true on success, or false on allocation failure. */
 -bool asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
 -                         IOReadOrWrite rw, int fd)
 +IOSubmitResult asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
 +                                    IOReadOrWrite rw, int fd)
+ {
      if (RTS_UNLIKELY(isFullClosureTable(&iomgr->aiop_table))) {
          bool ok = enlargeTables(iomgr);
 -        if (RTS_UNLIKELY(!ok)) return false;
 +        if (RTS_UNLIKELY(!ok)) return IOSubmitResultHeapOverflow;
+     }
      int ix = insertClosureTable(iomgr->cap, &iomgr->aiop_table, aiop);
@@ -216,7 +213,7 @@ bool asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
                                     .events  = rw == IORead ? POLLIN : POLLOUT,
                                     .revents = 0
                                   };
 -    return true;
 +    return IOSubmitResultAsyncContinue;
+ }
@@ -226,6 +223,7 @@ void syncIOCancelPoll(CapIOManager *iomgr, StgTSO *tso)
      ASSERT(aiop->notify_type == NotifyTSO);
      ASSERT(indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop);
      ioCancel(iomgr, aiop);
 +    setTsoIOOpOutcome(tso, aiop->outcome, aiop->result);
      /* We cannot use the normal notifyIOCompletion here. We are in the context
       * of throwTo, interrupting a thread blocked on IO via an async exception.
       * We don't put the TSO back on the run queue or change the why_blocked
@@ -284,26 +282,18 @@ static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop)
      switch (aiop->notify_type) {
          case NotifyTSO:
+         {
 -            if (aiop->outcome == IOOpOutcomeFailed && aiop->error == EBADF) {
 -                /* The fd is invalid: raise an IOError exception in the blocked
 -                 * thread. (See bug #4934 for what happens without this.)
 -                 */
 -                StgTSO *tso = aiop->notify.tso;
 -                debugTrace(DEBUG_iomanager,
 -                           "Raising exception in thread %" FMT_StgThreadID
 -                           " blocked on an invalid fd", tso->id);
 -                raiseAsync(iomgr->cap, tso,
 -                           (StgClosure *)blockedOnBadFD_closure,
 -                           false, NULL);
 -            } else {
 -                /* We should be guaranteed that the tso is still on the same
 -                 * cap because the tso was not on the run queue of any cap and
 -                 * so is not subject to thread migration.
 -                 */
 -                StgTSO *tso = aiop->notify.tso;
 -                pushOnRunQueue(iomgr->cap, tso);
 -                RELEASE_STORE(&tso->why_blocked, NotBlocked);
 -            }
 +            /* We should be guaranteed that the tso is still on the same
 +             * cap because the tso was not on the run queue of any cap and
 +             * so is not subject to thread migration.
 +             */
 +            StgTSO *tso = aiop->notify.tso;
 +            ASSERT(tso->cap == iomgr->cap);
++
 +            /* Fill in the outcome and result/error on the TSO's stack frame */
 +            setTsoIOOpOutcome(tso, aiop->outcome, aiop->result);
 +            pushOnRunQueue(iomgr->cap, tso);
 +            RELEASE_STORE(&tso->why_blocked, NotBlocked);
++
              /* For the TSO case, the aiop was only reachable from the TSO
               * itself, and thus it is now no longer be reachable at all.
               */

rts/posix/Poll.h

@@ -20,13 +20,13 @@ void initCapabilityIOManagerPoll(CapIOManager *iomgr);
  void freeCapabilityIOManagerPoll(CapIOManager *iomgr);
  /* Synchronous I/O and timer operations */
 -bool syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
 -                         IOReadOrWrite rw, HsInt fd);
 +IOSubmitResult syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso,
 +                                   IOReadOrWrite rw, HsInt fd);
  void syncIOCancelPoll(CapIOManager *iomgr, StgTSO *tso);
  /* Asynchronous operations */
 -bool asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
 -                          IOReadOrWrite rw, int fd);
 +IOSubmitResult asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop,
 +                                    IOReadOrWrite rw, int fd);
  void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop);
  /* Scheduler operations */

rts/posix/Select.c

@@ -15,7 +15,6 @@
  #include "Signals.h"
  #include "Schedule.h"
  #include "Prelude.h"
 -#include "RaiseAsync.h"
  #include "RtsUtils.h"
  #include "Capability.h"
  #include "Select.h"
@@ -480,13 +479,18 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait)
                    IF_DEBUG(scheduler,
                        debugBelch("Killing blocked thread %" FMT_StgThreadID
                                   " on bad fd=%i\n", tso->id, fd));
 -                  raiseAsync(iomgr->cap, tso,
 -                      (StgClosure *)blockedOnBadFD_closure, false, NULL);
++
 +                  /* Fill in the outcome and error on the TSO's stack frame */
 +                  setTsoIOOpOutcome(tso, IOOpOutcomeFailed, EBADF);
 +                  pushOnRunQueue(iomgr->cap,tso);
 +                  RELEASE_STORE(&tso->why_blocked, NotBlocked);
                    break;
                case RTS_FD_IS_READY:
                    IF_DEBUG(scheduler,
                        debugBelch("Waking up blocked thread %" FMT_StgThreadID "\n",
                                   tso->id));
 +                 /* Fill in the outcome and result on the TSO's stack frame */
 +                  setTsoIOOpOutcome(tso, IOOpOutcomeSuccess, 0);
                    pushOnRunQueue(iomgr->cap,tso);
                    RELEASE_STORE(&tso->why_blocked, NotBlocked);
                    break;

rts/sm/Evac.c

@@ -1361,7 +1361,11 @@ selector_loop:
      // from-space during marking, for example.  We rely on the property
      // that evacuate() doesn't mind if it gets passed a to-space pointer.
 -    info = RELAXED_LOAD((StgInfoTable**) &selectee->header.info);
 +    // NB. this load must be ordered: the selectee may be updated
 +    // concurrently by another GC thread's unchain_thunk_selectors(),
 +    // which publishes an indirection by writing the indirectee and
 +    // then RELEASE-storing the info pointer. See #27477.
 +    info = ACQUIRE_LOAD((StgInfoTable**) &selectee->header.info);
      if (IS_FORWARDING_PTR(info)) {
          // We don't follow pointers into to-space; the constructor

testsuite/tests/rts/T27477.hs

 +{-# LANGUAGE BangPatterns #-}
++
 +-- Stress test for #27477: missing ACQUIRE in eval_thunk_selector
 +-- (rts/sm/Evac.c).
 +--
 +-- With the bug present this test crashes or reports value mismatches
 +-- within a few seconds on AArch64; on strongly-ordered targets
 +-- it just passes.
++
 +module Main (main) where
++
 +import Control.Concurrent
 +import Control.Exception
 +import Control.Monad
 +import Data.IORef
 +import System.Environment
 +import System.Exit
 +import System.IO
 +import System.Mem (performMinorGC)
++
 +data T = T { nxt :: T, val :: !Int }
++
 +-- expected values and the cells that should evaluate to them
 +type Batch = ([Int], [T])
++
 +tailD, branchD, branchesPerCell :: Int
 +tailD = 12          -- shared tail length per cluster
 +branchD = 3         -- private branch length
 +branchesPerCell = 2
 +-- tailD + branchD must stay below MAX_THUNK_SELECTOR_DEPTH (16)
++
 +{-# NOINLINE spineEnd #-}
 +spineEnd :: T
 +spineEnd = errorWithoutStackTrace "spine end reached"
++
 +-- Fully evaluated spine of constructors; cell i from the head has val i+1.
 +buildSpine :: Int -> IO T
 +buildSpine len = evaluate (go len (T spineEnd 0))
 +  where
 +    go :: Int -> T -> T
 +    go 0 acc = acc
 +    go k acc = go (k - 1) (T acc k)
++
 +-- k selector thunks, shallow-first: cell i selects from cell i-1,
 +-- cell 0 selects from t.  If t evaluates to spine cell m (val m+1),
 +-- cell i evaluates to spine cell m+1+i (val m+2+i).
 +{-# NOINLINE selChain #-}
 +selChain :: Int -> T -> [T]
 +selChain 0 _ = []
 +selChain k t = let t' = nxt t in t' : selChain (k - 1) t'
++
 +lenL :: [a] -> Int
 +lenL = go 0
 +  where
 +    go !n [] = n
 +    go !n (_ : xs) = go (n + 1) xs
++
 +everyN :: Int -> [a] -> [a]
 +everyN _ [] = []
 +everyN n (x : xs) = x : everyN n (drop (n - 1) xs)
++
 +-- One branch hanging off tail cell tj (which evaluates to val jval):
 +-- branch cell i evaluates to jval+1+i.  Returned deepest-first.
 +{-# NOINLINE mkBranch #-}
 +mkBranch :: Int -> T -> IO Batch
 +mkBranch jval tj = do
 +  let cells = selChain branchD tj
 +  _ <- evaluate (lenL cells)
 +  let expected = [ jval + 1 + i | i <- [0 .. branchD - 1] ]
 +  pure (reverse expected, reverse cells)
++
 +-- A cluster: one private spine, one shared tail of selectors over it,
 +-- branchesPerCell branches of selectors converging on every tail cell.
 +-- Neither the spine nor the tail is returned: they must stay reachable
 +-- only through the branch selectors.
 +buildCluster :: IO [Batch]
 +buildCluster = do
 +  sp <- buildSpine (tailD + branchD + 4)
 +  let tails = selChain tailD sp
 +  _ <- evaluate (lenL tails)
 +  bss <- forM (zip [0 ..] tails) $ \(j, tj) ->
 +    replicateM branchesPerCell (mkBranch (j + 2) tj)
 +  pure (concat bss)
++
 +verifyBatch :: IORef Int -> Int -> Batch -> IO ()
 +verifyBatch errs wid (es0, ts0) = go es0 ts0
 +  where
 +    go (e : es) (t : ts) = do
 +      v <- evaluate (val t)
 +      when (v /= e) $ do
 +        hPutStrLn stderr $
 +          "MISMATCH worker=" ++ show wid
 +            ++ " expected=" ++ show e ++ " got=" ++ show v
 +        modifyIORef' errs (+ 1)
 +      go es ts
 +    go _ _ = pure ()
++
 +-- simple cyclic barrier
 +newtype Barrier = Barrier (MVar (Int, [MVar ()]))
++
 +newBarrier :: IO Barrier
 +newBarrier = Barrier <$> newMVar (0, [])
++
 +awaitBarrier :: Barrier -> Int -> IO ()
 +awaitBarrier (Barrier st) total = do
 +  w <- newEmptyMVar
 +  join $ modifyMVar st $ \(k, ws) ->
 +    if k + 1 == total
 +      then pure ((0, []), mapM_ (\m -> putMVar m ()) ws)
 +      else pure ((k + 1, w : ws), takeMVar w)
++
 +worker :: Int -> Int -> Int -> Barrier -> [IORef [Batch]] -> IORef Int -> Int -> IO ()
 +worker rounds clusters nWorkers bar slots errs wid =
 +  forM_ [1 .. rounds] $ \(_r :: Int) -> do
 +    -- build fresh selector clusters, publish them
 +    batches <- concat <$> replicateM clusters buildCluster
 +    writeIORef (slots !! wid) batches
 +    awaitBarrier bar nWorkers
 +    -- root each branch's deepest cell via fresh cons cells in our own
 +    -- nursery (so our GC thread evacuates the shared cells itself), in
 +    -- a per-worker interleaved order so that different GC threads
 +    -- sweep different branches of the same shared tails concurrently
 +    published <- mapM readIORef slots
 +    let allBatches = concat published
 +        ordered
 +          | nWorkers > 1 =
 +              concat [ everyN nWorkers (drop ((wid + k) `mod` nWorkers) allBatches)
 +                     | k <- [0 .. nWorkers - 1] ]
 +          | otherwise = allBatches
 +        deepTs = [ t | (_, t : _) <- ordered ]
 +        deepEs = [ e | (e : _, _) <- ordered ]
 +    _ <- evaluate (lenL deepTs)
 +    _ <- evaluate (lenL deepEs)
 +    awaitBarrier bar nWorkers
 +    -- run a parallel GC with everything live
 +    when (wid == 0) performMinorGC
 +    awaitBarrier bar nWorkers
 +    -- force everything and check the values
 +    verifyBatch errs wid (deepEs, deepTs)
 +    awaitBarrier bar nWorkers
++
 +main :: IO ()
 +main = do
 +  hSetBuffering stderr LineBuffering
 +  args <- getArgs
 +  let atDef d i = if length args > i then read (args !! i) else d
 +      rounds = atDef 600 0
 +      clusters = atDef 48 1
 +  n <- getNumCapabilities
 +  bar <- newBarrier
 +  slots <- replicateM n (newIORef [])
 +  errs <- newIORef 0
 +  dones <- forM [0 .. n - 1] $ \i -> do
 +    done <- newEmptyMVar
 +    _ <- forkOn i $
 +      (worker rounds clusters n bar slots errs i >> putMVar done Nothing)
 +        `catch` \e -> putMVar done (Just (e :: SomeException))
 +    pure done
 +  results <- mapM takeMVar dones
 +  forM_ results $ \r -> case r of
 +    Just e -> do
 +      hPutStrLn stderr ("worker exception: " ++ show e)
 +      exitWith (ExitFailure 2)
 +    Nothing -> pure ()
 +  ec <- readIORef errs
 +  when (ec > 0) $ do
 +    hPutStrLn stderr ("FAILED: " ++ show ec ++ " mismatches")
 +    exitWith (ExitFailure 2)
 +  putStrLn "OK"

testsuite/tests/rts/T27477.stdout

+OK

testsuite/tests/rts/all.T

@@ -720,3 +720,12 @@ test('T27585',
       , extra_run_opts('+RTS -i0 -RTS')
       ],
       compile_and_run, ['-O -rtsopts'])
++
 +test('T27477',
 +     [ extra_run_opts('600 24 +RTS -N4 -A1m -RTS')
 +     , req_ghc_smp
 +     , req_target_smp
 +     , only_ways(['threaded1', 'threaded2'])
 +     ],
 +     compile_and_run, ['-O2'])
++

utils/check-exact/ExactPrint.hs

@@ -3404,13 +3404,13 @@ instance ExactPrint (HsCmd GhcPs) where
        e' <- markAnnotated e
        return (HsCmdLet (tkLet', tkIn') binds' e')
 -  exact (HsCmdDo (an0,loc) (L l es)) = do
 +  exact (HsCmdDo (an0,loc) es) = do
      debugM $ "HsCmdDo"
      loc' <- printStringAtAA loc "do"
      (an1,es') <- markAnnList' an0 $ do
 -      ee <- mapM markAnnotated es
 +      ee <- markAnnotated es
        return ee
 -    return (HsCmdDo (an1,loc') (L l es'))
 +    return (HsCmdDo (an1,loc') es')
  -- ---------------------------------------------------------------------
@@ -4508,10 +4508,10 @@ instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))] whe
        Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do
          debugM $ "LocatedL [ExprLStmt: snocView"
          ls' <- markAnnotated ls
 -        initStmts' <- markAnnotated initStmts
 +        initStmts' <- mapM markAnnotated initStmts
          return (initStmts' ++ [ls'])
        _ -> do
 -        stmts' <- markAnnotated stmts
 +        stmts' <- mapM markAnnotated stmts
          return stmts'
  instance ExactPrint [Located HsDocStringChunk] where

utils/deriveConstants/Main.hs

@@ -644,6 +644,7 @@ wanteds os = concat
            ,structField C "HsIface" "divZZeroException_closure"
            ,structField C "HsIface" "underflowException_closure"
            ,structField C "HsIface" "overflowException_closure"
 +          ,structField C "HsIface" "raisePrimIOException_info"
            ,structField C "HsIface" "unpackCStringzh_info"
            ,structField C "HsIface" "unpackCStringUtf8zh_info"