GitLab

Duncan Coutts pushed to branch wip/dcoutts/issue-26717 at Glasgow Haskell Compiler / GHC

Commits:

e4e28ed8

by Duncan Coutts at 2026-05-05T23:30:53+01:00

Document that eventlog thread stop code ThreadBlocked is no longer used

It has not been used since GHC 7.0.x (2011). In 7.2 all the BlockedOn*
codes were added, and these were and are used instead of ThreadBlocked.

ba23ba28

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Add a proper mapping to eventlog external thread stop status

That is the mapping from rts-internal codes, to the coes used in the
status field in the eventlog EVENT_STOP_THREAD event.

See issue #9003 for what goes wrong when we mess this up. In that
ticket, people note that we should really not require the internal
tso->why_blocked codes to leak into the external eventlog thread stop
codes. The same principle applies to the StgThreadReturnCode.

This change properly separates them, and explicitly maps between them
using a pair of (compact, constant) tables. These tables are pretty
small (with no alignment constraints) and will soon shrink so it seems
a sensible tradeoff.

We also introduce and use proper EVENT_STOP_THREAD constants in the
event log format header. Previously there was not specification in the
code for these (only in the docs): the values were encoded into the
conversion code.

This will allow us to renumber the internal why_blockd codes without
breaking the eventlog output.

18cc92f2

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Remove unused tso->block_info.wakeup member.

Presumably it was used once, but not now.

61518e26

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Document StgTSOBlockInfo to say what cases use what members

In principle, tso->why_blocked is the tag for the StgTSOBlockInfo union,
so we should be able to say for each union member the why_blocked cases
that use that member.

0f6dc851

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Add a tso->block_info.mvar member and use it

in preference to the generic block_info.closure union member, with
casts.

The plan is that when we know what case we're in (via tso->why_blocked)
then we can always access the correct union member, and so we will only
need to access block_info.closure for generic cases where we don't know
or don't care.

bb625ec1

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Add a tso->block_info.unused member and use it

in preference to the generic block_info.closure union member, with
casts.

The plan is that when we know what case we're in (via tso->why_blocked)
then we can always access the correct union member, and so we will only
need to access block_info.closure for generic cases where we don't know
or don't care.

620b8462

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Avoid storing to tso->block_info.closure

In one case we can use a specific union member (.prev) instead. In
several cases the stores were in fact redundant because of subsequent
overwrites.

In scavengeTSO we replace setting tso->block_info.closure to a valid
closure, with an assertion that the block_info.unused is already set to
END_TSO_QUEUE which is a valid (static) closure.

7494dedc

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Renumber the tso->why_blocked constants

We can do this now because we have separated the internal values from
the external ones used in the eventlog.

This lets us put them back into a deliberate order and consolodate some
gaps.

More importantly, it is a prepation for a slightly more sophisticated
encoding.

3d9eb500

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Define constants for the existing stg_threadStatuszh return codes

The stg_threadStatuszh reuses the internal tso->why_blocked codes but
also extends them with a couple previously magic values. This is awkward
since we need to know what those magic values are so we don't
accidentally use those values to mean something else. By pulling a
definition up to where the why_blocked codes are defined we will be able
to avoid mistakenly assining those codes some meaning (or just changing
the BlockedThreadComplete, BlockedThreadKilled code if necessary).

e016e3c8

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Extend the tso->why_blocked encoding to indicate block_info closures

We use some bit tricks to cheaply and generically test if a
tso->why_blocked tag implies that the corresponding tso->block_info will
contain a non-trivial valid closure (i.e. not just block_info.unused set
to END_TSO_QUEUE).

In particular we arrange for most why_blocked values to naturally have a
distinguishing bit, but for the BlockedOn{Read,Write,Delay} cases, they
can come in either non-closure or closure forms. We allow an additional
bit to distinguish these cases. The non-closure forms are only from
legacy I/O managers: select and win32-legacy. So this extra bit
mechanism will be able to be retired once the legacy I/O managers are
themselves retired.

This means in a few places we need to untag the why_blocked value before
inspecting it, but in most places we do not.

f8830056

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Use BlockInfoForceNonClosure in the select I/O manager

ff1abaa4

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Use BlockInfoForceNonClosure in the win32-legacy I/O manager

for the BlockedOn{Read,Write} since these use the non-heap allocated
StgAsyncIOResult.

917d2087

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Enforce the why_blocked and block_info rules in checkTSO

We now check the cases wher IsBlockInfoClosure should hold, the cases
that are supposed to use block_info.unused == END_TSO_QUEUE, and which
cases are allowed to use BlockInfoForceNonClosure.

This partially enforces the use of why_blocked as a tag for the
block_info union. We could be stricter and check for the correct
expected info table for the closure cases.

90b94dbd

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Use IsBlockInfoClosure to simplify several tests

In GC and generic traversal we need to know if we should look at the
block_info.closure or not. Now we can do just that using a cheap bit
test on the why_blocked tag.

This fixes issue 26717, where the problem was that some GC modes did not
know when to look at block_info.closure, because the poll I/O manager
uses a closure for BlockedOn{Read,Write} while the select I/O manager
uses a non-closure. Now this information is in the why_blocked tag
itself.

8d928079

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Remove the now-unused scavengeTSOIOManager

The GC no longer has to delegate to the I/O manager, since it can use
IsBlockInfoClosure to decide things itself.

df8b49f7
by Duncan Coutts at 2026-05-05T23:33:22+01:00
```
Remove duplicate assertion
```

7c6995b8

by Duncan Coutts at 2026-05-05T23:33:22+01:00

Follow atomic access rules more consistently for tso->why_blocked

The rule is this:

store block_info *before* why_blocked
store why_blocked using store release

load why_blocked using load acquire
load block_info *after* why_blocked

This is a an atomic store release / load acquire pair and (if the reads
are in a separate thread to the writes, and the read receives the value
stored) then this guarantees a full "happens before" relationship of
these stores and loads.

In some cases, we do not need a full load acquire, because we don't read
the block_info at all and so do not need any ordering. In this case we
just need an atomic relaxed load.

This was being followed in most places, but not all. If there's good
reason in any case that we don't need atomic access, then we should
document that in a comment. In the absence of that I think it's easier
to follow the rule everywhere.

011fdc27
by Duncan Coutts at 2026-05-05T23:33:22+01:00
```
Add a changelog entry
```

25 changed files:

+ changelog.d/T26716
docs/users_guide/eventlog-formats.rst
libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs
rts/IOManager.c
rts/IOManager.h
rts/PrimOps.cmm
rts/RaiseAsync.c
rts/RaiseAsync.h
rts/STM.c
rts/Schedule.c
rts/Threads.c
rts/Trace.c
rts/Trace.h
rts/TraverseHeap.c
rts/include/rts/Constants.h
rts/include/rts/EventLogFormat.h
rts/include/rts/storage/TSO.h
rts/posix/Poll.c
rts/posix/Select.c
rts/posix/Timeout.c
rts/sm/Compact.c
rts/sm/NonMovingMark.c
rts/sm/Sanity.c
rts/sm/Scav.c
rts/win32/AsyncMIO.c

Changes:

changelog.d/T26716

 +section: rts
 +synopsis: Fix a use-after-free bug in the poll I/O manager
 +issues: #26716, #26717
 +mrs: !15519
 +description: {
 +  Experimental work on ASAN support for GHC (MR !15168) revealed a
 +  use-after-free bug when using the combination of the new poll I/O
 +  manager with the compacting GC. The ultimate cause is that a TSO's
 +  `block_info` (used by I/O managers and many other parts of the RTS)
 +  is sometimes a GC pointer and sometimes not, but without a consistent
 +  and easy-to-follow rule for when this is the case. The solution has
 +  been to clean up and enforce that the TSO's `why_blocked` enumeration
 +  is a proper tag for the `block_info`, and to use an encoding that
 +  determines precisely when the `block_info` is a pointer or not.
 +}

docs/users_guide/eventlog-formats.rst

@@ -211,7 +211,7 @@ Thread and scheduling events
        * 1: HeapOverflow
        * 2: StackOverflow
        * 3: ThreadYielding
 -      * 4: ThreadBlocked
 +      * 4: unused
        * 5: ThreadFinished
        * 6: ForeignCall
        * 7: BlockedOnMVar
@@ -237,6 +237,10 @@ Thread and scheduling events
     these eventlog stop thread codes are now independent. We are nevertheless
     left with some historical warts:
 +    * 4: this was previously documented as `ThreadBlocked`. This code was used
 +      in GHC 6.12.x (the first GHC version with eventlog support) and in 7.0.x.
 +      From GHC 7.2 onwards this code is no longer used. Whenever a thread
 +      blocks, a more detailed `BlockedOn*` code is used instead.
      * 14,15: these correspond to GHC internal status codes `BlockedOnGA` and
        `BlockedOnGA_NoSend` that are no longer used (and may never have been
        used by any released version of GHC).

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

@@ -607,13 +607,16 @@ threadStatus (ThreadId t) = IO $ \s ->
          -- NB. keep these in sync with rts/include/rts/Constants.h
       mk_stat 0  = ThreadRunning
       mk_stat 1  = ThreadBlocked BlockedOnMVar
 -     mk_stat 2  = ThreadBlocked BlockedOnBlackHole
 -     mk_stat 6  = ThreadBlocked BlockedOnSTM
 +     mk_stat 2  = ThreadBlocked BlockedOnMVar -- BlockedOnMVarRead
 +     mk_stat 3  = ThreadBlocked BlockedOnBlackHole
 +     mk_stat 4  = ThreadBlocked BlockedOnException
 +     -- 5,6,7: BlockedOn{Read,Write,Delay}
 +     mk_stat 8  = ThreadBlocked BlockedOnSTM
 +     mk_stat 9  = ThreadBlocked BlockedOnForeignCall
       mk_stat 10 = ThreadBlocked BlockedOnForeignCall
 -     mk_stat 11 = ThreadBlocked BlockedOnForeignCall
 -     mk_stat 12 = ThreadBlocked BlockedOnException
 -     mk_stat 14 = ThreadBlocked BlockedOnMVar -- possibly: BlockedOnMVarRead
 -     -- NB. these are hardcoded in rts/PrimOps.cmm
 +     -- 11: ThreadMigrating
 +     -- 12: BlockedOnDoProc
 +     -- 13,14,15: unused
       mk_stat 16 = ThreadFinished
       mk_stat 17 = ThreadDied
       mk_stat _  = ThreadBlocked BlockedOnOther

rts/IOManager.c

@@ -611,41 +611,6 @@ void markCapabilityIOManager(evac_fn evac, void *user, Capability *cap)
+ }
 -void scavengeTSOIOManager(StgTSO *tso)
 -{
 -    switch (iomgr_type) {
+-
 -            /* case IO_MANAGER_SELECT:
 -             * BlockedOn{Read,Write} uses block_info.fd
 -             * BlockedOnDelay        uses block_info.target
 -             * both of these are not GC pointers, so there is nothing to do.
 -             */
+-
 -#if defined(IOMGR_ENABLED_POLL)
 -        case IO_MANAGER_POLL:
 -            /* BlockedOn{Read,Write} uses block_info.aiop
 -             * BlockedOnDelay        uses block_info.timeout
 -             * both of these are heap allocated, so we can do the same in all
 -             * cases, which is why we can use the generic block_info.closure.
 -             */
 -            evacuate(&tso->block_info.closure);
 -            break;
 -#endif
+-
 -            /* case IO_MANAGER_WIN32_LEGACY:
 -             * BlockedOn{Read,Write,DoProc} uses block_info.async_reqID
 -             * which is a plain integer, so nothing to scavenge.
 -             */
+-
 -        default:
 -            /* All the other I/O managers do not use I/O-related why_blocked
 -             * reasons, so there are no cases to handle.
 -             */
 -            break;
 -    }
 -}
+-
+-
  /* Declared in rts/IOInterface.h. Used only by the MIO threaded I/O manager on
   * Unix platforms.
   */
@@ -807,16 +772,17 @@ bool syncIOWaitReady(Capability   *cap,
  #if defined(IOMGR_ENABLED_SELECT)
          case IO_MANAGER_SELECT:
+         {
 -            StgWord why_blocked = rw == IORead ? BlockedOnRead : BlockedOnWrite;
 +            StgThreadWhyBlocked why_blocked = (rw == IORead ? BlockedOnRead
 +                                                            : BlockedOnWrite)
 +                                            | BlockInfoForceNonClosure;
              tso->block_info.fd = fd;
 -            RELEASE_STORE(&tso->why_blocked, why_blocked);
              appendToIOBlockedQueue(cap, tso);
 +            RELEASE_STORE(&tso->why_blocked, why_blocked);
              return true;
+         }
  #endif
  #if defined(IOMGR_ENABLED_POLL)
          case IO_MANAGER_POLL:
 -            ASSERT(tso->why_blocked == NotBlocked);
              return syncIOWaitReadyPoll(cap, tso, rw, fd);
  #endif
          default:
@@ -868,8 +834,8 @@ bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay)
+         {
              LowResTime target = getDelayTarget(us_delay);
              tso->block_info.target = target;
 -            RELEASE_STORE(&tso->why_blocked, BlockedOnDelay);
              insertIntoSleepingQueue(cap, tso, target);
 +            RELEASE_STORE(&tso->why_blocked, BlockedOnDelay | BlockInfoForceNonClosure);
              return true;
+         }
  #endif
@@ -889,8 +855,8 @@ bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay)
               * simplifies matters, so set the status to OnDoProc and put the
               * delayed thread on the blocked_queue.
               */
 -            RELEASE_STORE(&tso->why_blocked, BlockedOnDoProc);
              appendToIOBlockedQueue(cap, tso);
 +            RELEASE_STORE(&tso->why_blocked, BlockedOnDoProc);
              return true;
+         }
  #endif
@@ -906,6 +872,7 @@ void syncDelayCancel(Capability *cap, StgTSO *tso)
      switch (iomgr_type) {
  #if defined(IOMGR_ENABLED_SELECT)
          case IO_MANAGER_SELECT:
 +            ASSERT(tso->why_blocked == (BlockedOnDelay | BlockInfoForceNonClosure));
              removeThreadFromQueue(cap, &cap->iomgr->sleeping_queue, tso);
              break;
  #endif

rts/IOManager.h

@@ -291,11 +291,6 @@ void wakeupIOManager(void);
  void markCapabilityIOManager(evac_fn evac, void *user, Capability *cap);
 -/* GC hook: scavenge I/O related tso->block_info. Used by scavengeTSO.
 - */
 -void scavengeTSOIOManager(StgTSO *tso);
+-
+-
  /* Several code paths are almost identical between read and write paths. In
   * such cases we use a shared code path with an enum to say which we're doing.
   */

rts/PrimOps.cmm

@@ -1145,12 +1145,12 @@ stg_threadStatuszh ( gcptr tso )
      // contents of block_info too, then we'd have to do some synchronisation.
      if (what_next == ThreadComplete) {
 -        ret = 16;  // NB. magic, matches up with GHC.Conc.threadStatus
 +        ret = BlockedThreadComplete;  // NB. magic, matches up with GHC.Conc.threadStatus
      } else {
          if (what_next == ThreadKilled) {
 -            ret = 17;
 +            ret = BlockedThreadKilled;
          } else {
 -            ret = why_blocked;
 +            ret = UntagWhyBlocked(why_blocked);
+         }
+     }
@@ -2313,7 +2313,8 @@ stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf )
      StgTSO_block_info(CurrentTSO) = reqID;
      ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32);
 -    %release StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I32;
 +    %release StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I32
 +                                            | BlockInfoForceNonClosure::I32;
      ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr");
      jump stg_block_async();
@@ -2332,7 +2333,8 @@ stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf )
      StgTSO_block_info(CurrentTSO) = reqID;
      ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32);
 -    %release StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I32;
 +    %release StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I32
 +                                            | BlockInfoForceNonClosure::I32;
      ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr");
      jump stg_block_async();

rts/RaiseAsync.c

@@ -233,7 +233,6 @@ throwTo (Capability *cap,       // the Capability we hold
  uint32_t
  throwToMsg (Capability *cap, MessageThrowTo *msg)
+ {
 -    StgWord status;
      StgTSO *target = ACQUIRE_LOAD(&msg->target);
      Capability *target_cap;
@@ -268,9 +267,9 @@ check_target:
          return THROWTO_BLOCKED;
+     }
 -    status = ACQUIRE_LOAD(&target->why_blocked);
 +    StgThreadWhyBlocked why_blocked = ACQUIRE_LOAD(&target->why_blocked);
 -    switch (status) {
 +    switch (UntagWhyBlocked(why_blocked)) {
      case NotBlocked:
+     {
          if ((target->flags & TSO_BLOCKEX) == 0) {
@@ -354,7 +353,7 @@ check_target:
          StgMVar *mvar;
          StgInfoTable *info USED_IF_THREADS;
 -        mvar = (StgMVar *)target->block_info.closure;
 +        mvar = target->block_info.mvar;
          // ASSUMPTION: tso->block_info must always point to a
          // closure.  In the threaded RTS it does.
@@ -370,9 +369,10 @@ check_target:
          // we have the MVar, let's check whether the thread
          // is still blocked on the same MVar.
 -        if ((target->why_blocked != BlockedOnMVar
 -             && target->why_blocked != BlockedOnMVarRead)
 -            || (StgMVar *)target->block_info.closure != mvar) {
 +        StgThreadWhyBlocked why_blocked_still = ACQUIRE_LOAD(&target->why_blocked);
 +        if ((   why_blocked_still != BlockedOnMVar
 +             && why_blocked_still != BlockedOnMVarRead)
 +            || target->block_info.mvar != mvar) {
              unlockClosure((StgClosure *)mvar, info);
              goto retry;
+         }
@@ -490,7 +490,7 @@ check_target:
          goto retry;
      default:
 -        barf("throwTo: unrecognised why_blocked (%d)", target->why_blocked);
 +        barf("throwTo: unrecognised why_blocked (%d)", why_blocked);
+     }
      barf("throwTo");
+ }
@@ -625,7 +625,7 @@ awakenBlockedExceptionQueue (Capability *cap, StgTSO *tso)
  static void
  removeFromMVarBlockedQueue (StgTSO *tso)
+ {
 -    StgMVar *mvar = (StgMVar*)tso->block_info.closure;
 +    StgMVar *mvar = tso->block_info.mvar;
      StgMVarTSOQueue *q = (StgMVarTSOQueue*)tso->_link;
      if (q == (StgMVarTSOQueue*)END_TSO_QUEUE) {
@@ -667,7 +667,7 @@ removeFromMVarBlockedQueue (StgTSO *tso)
  static void
  removeFromQueues(Capability *cap, StgTSO *tso)
+ {
 -  switch (tso->why_blocked) {
 +  switch (UntagWhyBlocked(ACQUIRE_LOAD(&tso->why_blocked))) {
    case NotBlocked:
    case ThreadMigrating:
@@ -721,8 +721,8 @@ removeFromQueues(Capability *cap, StgTSO *tso)
+   }
   done:
 -  RELAXED_STORE(&tso->why_blocked, NotBlocked);
    appendToRunQueue(cap, tso);
 +  RELEASE_STORE(&tso->why_blocked, NotBlocked);
+ }
  /* -----------------------------------------------------------------------------
@@ -1105,9 +1105,9 @@ done:
      IF_DEBUG(sanity, checkTSO(tso));
      // wake it up
 -    if (tso->why_blocked != NotBlocked) {
 -        tso->why_blocked = NotBlocked;
 +    if (RELAXED_LOAD(&tso->why_blocked) != NotBlocked) {
          appendToRunQueue(cap,tso);
 +        RELEASE_STORE(&tso->why_blocked, NotBlocked);
+     }
      return tso;

rts/RaiseAsync.h

@@ -56,7 +56,7 @@ void awakenBlockedExceptionQueue  (Capability *cap, StgTSO *tso);
  INLINE_HEADER int
  interruptible(StgTSO *t)
+ {
 -  switch (t->why_blocked) {
 +  switch (UntagWhyBlocked(t->why_blocked)) {
    case BlockedOnMVar:
    case BlockedOnSTM:
    case BlockedOnMVarRead:

rts/STM.c

@@ -264,7 +264,7 @@ static StgBool cond_lock_tvar(Capability *cap,
  static void park_tso(StgTSO *tso) {
    ASSERT(tso -> why_blocked == NotBlocked);
 -  tso -> block_info.closure = (StgClosure *) END_TSO_QUEUE;
 +  tso->block_info.unused = END_TSO_QUEUE;
    RELEASE_STORE(&tso -> why_blocked, BlockedOnSTM);
    TRACE("park_tso on tso=%p", tso);
+ }

rts/Schedule.c

@@ -174,6 +174,9 @@ static void deleteAllThreads (void);
  static void deleteThread_(StgTSO *tso);
  #endif
 +static inline EventThreadStatus eventlogThreadStatus(StgThreadReturnCode ret_code);
 +static inline EventThreadStatus eventlogThreadStatusBlocked(StgThreadWhyBlocked why_blocked);
++
  /* ---------------------------------------------------------------------------
     Main scheduling loop.
@@ -522,20 +525,21 @@ run_thread:
  #endif
      if (ret == ThreadBlocked) {
 -        uint16_t why_blocked = ACQUIRE_LOAD(&t->why_blocked);
 +        StgThreadWhyBlocked why_blocked = ACQUIRE_LOAD(&t->why_blocked);
 +        EventThreadStatus status = eventlogThreadStatusBlocked(why_blocked);
 +        StgWord32 status_detail = 0;
          if (why_blocked == BlockedOnBlackHole) {
              StgTSO *owner = blackHoleOwner(t->block_info.bh->bh);
 -            traceEventStopThread(cap, t, t->why_blocked + 6,
 -                                 owner != NULL ? owner->id : 0);
 -        } else {
 -            traceEventStopThread(cap, t, t->why_blocked + 6, 0);
 +            status_detail = owner != NULL ? owner->id : 0;
+         }
 +        traceEventStopThread(cap, t, status, status_detail);
      } else {
 +        EventThreadStatus status = eventlogThreadStatus(ret);
 +        StgWord32 status_detail = 0;
          if (ret == StackOverflow) {
 -          traceEventStopThread(cap, t, ret, t->tot_stack_size);
 -        } else {
 -          traceEventStopThread(cap, t, ret, 0);
 +            status_detail = t->tot_stack_size;
+         }
 +        traceEventStopThread(cap, t, status, status_detail);
+     }
      ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
@@ -1096,7 +1100,7 @@ schedulePostRunThread (Capability *cap, StgTSO *t)
      //
      // and a is never equal to b given a consistent view of memory.
      //
 -    if (t -> trec != NO_TREC && t -> why_blocked == NotBlocked) {
 +    if (t -> trec != NO_TREC && RELAXED_LOAD(&t->why_blocked) == NotBlocked) {
          if (!stmValidateNestOfTransactions(cap, t -> trec, true)) {
              debugTrace(DEBUG_sched | DEBUG_stm,
                         "trec %p found wasting its time", t);
@@ -2512,17 +2516,18 @@ suspendThread (StgRegTable *reg, bool interruptible)
    task = cap->running_task;
    tso = cap->r.rCurrentTSO;
 -  traceEventStopThread(cap, tso, THREAD_SUSPENDED_FOREIGN_CALL, 0);
 +  traceEventStopThread(cap, tso, STOP_THREAD_ForeignCall, 0);
    // XXX this might not be necessary --SDM
    RELAXED_STORE(&tso->what_next, ThreadRunGHC);
    threadPaused(cap,tso);
 +  tso->block_info.unused = END_TSO_QUEUE;
    if (interruptible) {
 -    tso->why_blocked = BlockedOnCCall_Interruptible;
 +    RELEASE_STORE(&tso->why_blocked, BlockedOnCCall_Interruptible);
    } else {
 -    tso->why_blocked = BlockedOnCCall;
 +    RELEASE_STORE(&tso->why_blocked, BlockedOnCCall);
+   }
    // Hand back capability
@@ -2580,16 +2585,25 @@ resumeThread (void *task_)
      tso = incall->suspended_tso;
      incall->suspended_tso = NULL;
      incall->suspended_cap = NULL;
++
 +    // we set why_blocked previously in suspendThread
 +    ASSERT(tso->why_blocked == BlockedOnCCall ||
 +           tso->why_blocked == BlockedOnCCall_Interruptible);
++
      // we will modify tso->_link
      IF_NONMOVING_WRITE_BARRIER_ENABLED {
          updateRemembSetPushClosure(cap, (StgClosure *)tso->_link);
+     }
      tso->_link = END_TSO_QUEUE;
 +    // but no need to modify tso->block_info.prev as coincidentally
 +    // it has the value we want already (since in suspendThread we set
 +    // tso->block_info.unused to END_TSO_QUEUE for BlockedOnCCall).
 +    ASSERT(tso->block_info.prev == END_TSO_QUEUE);
      traceEventRunThread(cap, tso);
      /* Reset blocking status */
 -    tso->why_blocked  = NotBlocked;
 +    RELEASE_STORE(&tso->why_blocked, NotBlocked);
      if ((tso->flags & TSO_BLOCKEX) == 0) {
          // avoid locking the TSO if we don't have to
@@ -2941,8 +2955,9 @@ deleteThread (StgTSO *tso)
      // The TSO must be on the run queue of the Capability we own, or
      // we must own all Capabilities.
 -    if (tso->why_blocked != BlockedOnCCall &&
 -        tso->why_blocked != BlockedOnCCall_Interruptible) {
 +    StgThreadWhyBlocked why_blocked = RELAXED_LOAD(&tso->why_blocked);
 +    if (why_blocked != BlockedOnCCall &&
 +        why_blocked != BlockedOnCCall_Interruptible) {
          throwToSingleThreaded(tso->cap,tso,NULL);
+     }
+ }
@@ -2953,10 +2968,12 @@ deleteThread_(StgTSO *tso)
  { // for forkProcess only:
    // like deleteThread(), but we delete threads in foreign calls, too.
 -    if (tso->why_blocked == BlockedOnCCall ||
 -        tso->why_blocked == BlockedOnCCall_Interruptible) {
 +    StgThreadWhyBlocked why_blocked = RELAXED_LOAD(&tso->why_blocked);
 +    if (why_blocked == BlockedOnCCall ||
 +        why_blocked == BlockedOnCCall_Interruptible) {
          tso->what_next = ThreadKilled;
          appendToRunQueue(tso->cap, tso);
 +        RELEASE_STORE(&tso->why_blocked, NotBlocked);
      } else {
          deleteThread(tso);
+     }
@@ -3307,7 +3324,7 @@ resurrectThreads (StgTSO *threads)
          // Wake up the thread on the Capability it was last on
          cap = tso->cap;
 -        switch (tso->why_blocked) {
 +        switch (UntagWhyBlocked(RELAXED_LOAD(&tso->why_blocked))) {
          case BlockedOnMVar:
          case BlockedOnMVarRead:
              /* Called by GC - sched_mutex lock is currently held. */
@@ -3346,3 +3363,40 @@ void setAllocLimitKill(bool shouldKill, bool shouldHook)
     allocLimitKill = shouldKill;
     allocLimitRunHook = shouldHook;
+ }
++
 +/* Map from the internal thread return codes and the tso->why_blocked values to
 + * the external eventlog STOP_THREAD status codes. See issue #9003 for what
 + * goes wrong if we do not handle this mapping in an intentional fashion.
 + *
 + * For the internal values see Constants.h
 + * For the external values see rts/include/rts/EventLogFormat.h and
 + * docs/users_guide/eventlog-formats.rst
 + */
 +static const unsigned char thread_stop_code[] = {
 +    [HeapOverflow]   = STOP_THREAD_HeapOverflow,
 +    [StackOverflow]  = STOP_THREAD_StackOverflow,
 +    [ThreadYielding] = STOP_THREAD_ThreadYielding,
 +    [ThreadFinished] = STOP_THREAD_ThreadFinished
 +};
++
 +static const unsigned char thread_blocked_code[] = {
 +    [BlockedOnMVar]                = STOP_THREAD_BlockedOnMVar,
 +    [BlockedOnMVarRead]            = STOP_THREAD_BlockedOnMVarRead,
 +    [BlockedOnBlackHole]           = STOP_THREAD_BlockedOnBlackHole,
 +    [BlockedOnRead]                = STOP_THREAD_BlockedOnRead,
 +    [BlockedOnWrite]               = STOP_THREAD_BlockedOnWrite,
 +    [BlockedOnDelay]               = STOP_THREAD_BlockedOnDelay,
 +    [BlockedOnSTM]                 = STOP_THREAD_BlockedOnSTM,
 +    [BlockedOnDoProc]              = STOP_THREAD_BlockedOnDoProc,
 +    [BlockedOnMsgThrowTo]          = STOP_THREAD_BlockedOnMsgThrowTo,
 +};
++
 +static inline EventThreadStatus eventlogThreadStatus(StgThreadReturnCode ret_code)
 +{
 +    return thread_stop_code[ret_code];
 +}
++
 +static inline EventThreadStatus eventlogThreadStatusBlocked(StgThreadWhyBlocked why_blocked)
 +{
 +    return thread_blocked_code[UntagWhyBlocked(why_blocked)];
 +}

rts/Threads.c

@@ -97,8 +97,8 @@ createThread(Capability *cap, W_ size)
      // Always start with the compiled code evaluator
      tso->what_next = ThreadRunGHC;
 -    tso->block_info.closure = (StgClosure *)END_TSO_QUEUE;
 -    tso->why_blocked  = NotBlocked;
 +    tso->block_info.prev = END_TSO_QUEUE;
 +    tso->why_blocked = NotBlocked;
      tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE;
      tso->bq = (StgBlockingQueue *)END_TSO_QUEUE;
      tso->flags = 0;
@@ -291,13 +291,12 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
+     }
  #endif
 -    switch (ACQUIRE_LOAD(&tso->why_blocked))
 +    switch (UntagWhyBlocked(ACQUIRE_LOAD(&tso->why_blocked)))
+     {
      case BlockedOnMVar:
      case BlockedOnMVarRead:
+     {
          if (tso->_link == END_TSO_QUEUE) {
 -            tso->block_info.closure = (StgClosure*)END_TSO_QUEUE;
              goto unblock;
          } else {
              return;
@@ -336,8 +335,8 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
  unblock:
      // just run the thread now, if the BH is not really available,
      // we'll block again.
 -    tso->why_blocked = NotBlocked;
      appendToRunQueue(cap,tso);
 +    RELEASE_STORE(&tso->why_blocked, NotBlocked);
      // We used to set the context switch flag here, which would
      // trigger a context switch a short time in the future (at the end
@@ -368,7 +367,8 @@ migrateThread (Capability *from, StgTSO *tso, Capability *to)
      traceEventMigrateThread (from, tso, to->no);
      // ThreadMigrating tells the target cap that it needs to be added to
      // the run queue when it receives the MSG_TRY_WAKEUP.
 -    tso->why_blocked = ThreadMigrating;
 +    tso->block_info.unused = END_TSO_QUEUE;
 +    RELEASE_STORE(&tso->why_blocked, ThreadMigrating);
      tso->cap = to;
      tryWakeupThread(from, tso);
+ }
@@ -879,9 +879,9 @@ loop:
      // save why_blocked here, because waking up the thread destroys
      // this information
 -    StgWord why_blocked = ACQUIRE_LOAD(&tso->why_blocked);
 +    StgThreadWhyBlocked why_blocked = ACQUIRE_LOAD(&tso->why_blocked);
      ASSERT(why_blocked == BlockedOnMVarRead || why_blocked == BlockedOnMVar);
 -    ASSERT(tso->block_info.closure == (StgClosure*)mvar);
 +    ASSERT(tso->block_info.mvar == mvar);
      // actually perform the takeMVar
      StgStack* stack = tso->stackobj;
@@ -952,7 +952,7 @@ end:
  void
  printThreadBlockage(StgTSO *tso)
+ {
 -  switch (ACQUIRE_LOAD(&tso->why_blocked)) {
 +  switch (UntagWhyBlocked(ACQUIRE_LOAD(&tso->why_blocked))) {
  #if defined(mingw32_HOST_OS)
      case BlockedOnDoProc:
      debugBelch("is blocked on proc (request: %" FMT_Word ")", tso->block_info.async_reqID);
@@ -971,10 +971,10 @@ printThreadBlockage(StgTSO *tso)
  #endif
      break;
    case BlockedOnMVar:
 -    debugBelch("is blocked on an MVar @ %p", tso->block_info.closure);
 +    debugBelch("is blocked on an MVar @ %p", tso->block_info.mvar);
      break;
    case BlockedOnMVarRead:
 -    debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure);
 +    debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.mvar);
      break;
      break;
    case BlockedOnBlackHole:
@@ -1049,7 +1049,7 @@ printAllThreads(void)
    debugBelch("other threads:\n");
    for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
      for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) {
 -      if (t->why_blocked != NotBlocked) {
 +      if (RELAXED_LOAD(&t->why_blocked) != NotBlocked) {
            printThreadStatus(t);
+       }
        next = t->global_link;

rts/Trace.c

@@ -169,24 +169,20 @@ static void tracePreface (void)
  #if defined(DEBUG)
  static char *thread_stop_reasons[] = {
 -    [HeapOverflow] = "heap overflow",
 -    [StackOverflow] = "stack overflow",
 -    [ThreadYielding] = "yielding",
 -    [ThreadBlocked] = "blocked",
 -    [ThreadFinished] = "finished",
 -    [THREAD_SUSPENDED_FOREIGN_CALL] = "suspended while making a foreign call",
 -    [6 + BlockedOnMVar]         = "blocked on an MVar",
 -    [6 + BlockedOnMVarRead]     = "blocked on an atomic MVar read",
 -    [6 + BlockedOnBlackHole]    = "blocked on a black hole",
 -    [6 + BlockedOnRead]         = "blocked on a read operation",
 -    [6 + BlockedOnWrite]        = "blocked on a write operation",
 -    [6 + BlockedOnDelay]        = "blocked on a delay operation",
 -    [6 + BlockedOnSTM]          = "blocked on STM",
 -    [6 + BlockedOnDoProc]       = "blocked on asyncDoProc",
 -    [6 + BlockedOnCCall]        = "blocked on a foreign call",
 -    [6 + BlockedOnCCall_Interruptible] = "blocked on a foreign call (interruptible)",
 -    [6 + BlockedOnMsgThrowTo]   =  "blocked on throwTo",
 -    [6 + ThreadMigrating]       =  "migrating"
 +    [STOP_THREAD_HeapOverflow]        = "heap overflow",
 +    [STOP_THREAD_StackOverflow]       = "stack overflow",
 +    [STOP_THREAD_ThreadYielding]      = "yielding",
 +    [STOP_THREAD_ThreadFinished]      = "finished",
 +    [STOP_THREAD_ForeignCall]         = "suspended while making a foreign call",
 +    [STOP_THREAD_BlockedOnMVar]       = "blocked on an MVar",
 +    [STOP_THREAD_BlockedOnMVarRead]   = "blocked on an atomic MVar read",
 +    [STOP_THREAD_BlockedOnBlackHole]  = "blocked on a black hole",
 +    [STOP_THREAD_BlockedOnRead]       = "blocked on a read operation",
 +    [STOP_THREAD_BlockedOnWrite]      = "blocked on a write operation",
 +    [STOP_THREAD_BlockedOnDelay]      = "blocked on a delay operation",
 +    [STOP_THREAD_BlockedOnSTM]        = "blocked on STM",
 +    [STOP_THREAD_BlockedOnDoProc]     = "blocked on asyncDoProc",
 +    [STOP_THREAD_BlockedOnMsgThrowTo] = "blocked on throwTo"
  };
  #endif
@@ -230,10 +226,10 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag,
          break;
      case EVENT_STOP_THREAD:     // (cap, thread, status)
 -        if (info1 == 6 + BlockedOnBlackHole) {
 +        if (info1 == STOP_THREAD_BlockedOnBlackHole) {
              debugBelch("cap %d: thread %" FMT_Word "[\"%.*s\"]" " stopped (blocked on black hole owned by thread %lu)\n",
                         cap->no, (W_)tso->id, threadLabelLen, threadLabel, (long)info2);
 -        } else if (info1 == StackOverflow) {
 +        } else if (info1 == STOP_THREAD_StackOverflow) {
              debugBelch("cap %d: thread %" FMT_Word "[\"%.*s\"]"
                         " stopped (stack overflow, size %lu)\n",
                        cap->no, (W_)tso->id, threadLabelLen, threadLabel, (long)info2);

rts/Trace.h

@@ -600,7 +600,7 @@ INLINE_HEADER void traceEventRunThread(Capability *cap STG_UNUSED,
  INLINE_HEADER void traceEventStopThread(Capability          *cap    STG_UNUSED,
                                          StgTSO              *tso    STG_UNUSED,
 -                                        StgThreadReturnCode  status STG_UNUSED,
 +                                        EventThreadStatus    status STG_UNUSED,
                                          StgWord32           info    STG_UNUSED)
+ {
      traceSchedEvent2(cap, EVENT_STOP_THREAD, tso, status, info);

rts/TraverseHeap.c

@@ -1242,15 +1242,12 @@ inner_loop:
          traversePushClosure(ts, (StgClosure *) tso->blocked_exceptions, c, sep, child_data);
          traversePushClosure(ts, (StgClosure *) tso->bq, c, sep, child_data);
          traversePushClosure(ts, (StgClosure *) tso->trec, c, sep, child_data);
 -        switch (ACQUIRE_LOAD(&tso->why_blocked)) {
 -        case BlockedOnMVar:
 -        case BlockedOnMVarRead:
 -        case BlockedOnBlackHole:
 -        case BlockedOnMsgThrowTo:
++
 +        StgThreadWhyBlocked why_blocked = ACQUIRE_LOAD(&tso->why_blocked);
 +        if (IsBlockInfoClosure(why_blocked) && why_blocked != NotBlocked) {
 +            // The NotBlocked case uses block_info.prev as a TSO back link.
 +            // Do not follow in that case or we'll get into a loop.
              traversePushClosure(ts, tso->block_info.closure, c, sep, child_data);
 -            break;
 -        default:
 -            break;
+         }
          goto loop;
+     }

rts/include/rts/Constants.h

@@ -248,33 +248,83 @@
  /*
   * Constants for the why_blocked field of a TSO
 - * NB. keep these in sync with GHC/Conc/Sync.hs: threadStatus
 + *
 + * These say why the TSO is blocked, and also act as the tag for the
 + * block_info union. The comment for each tag below says which member
 + * of the block_info union is used.
 + *
 + * We also use the why_blocked to determine if the block_info contains
 + * a closure or not. There are three classes of tag:
 + * 1. why_blocked tags where block_info is always a closure;
 + * 2. why_blocked tags where block_info is never a closure;
 + * 3. why_blocked tags where block_info is sometimes a closure;
 + *
 + * We use the following encoding scheme for the three classes above:
 + * 1. the tag value has bits 3 and 4 unset (values 0..7);
 + * 2. the tag value has bit 3 set (values 8..15); and
 + * 3. the tag value has bit 4 set when it is not a closure and unset
 + *    when it is a closure.
 + *
 + * This scheme makes it cheap and simple to check if the GC needs to
 + * look at the block_info.closure.
 + *
 + * The reason for the encoding using 2 marker bits rather than 1 is
 + * that it minimises the cases in the code that need to use or check
 + * the tag bits. The only tags in class 3 are BlockedOn{Read,Write
 + * Delay,DoProc} which are used by in-RTS I/O managers, and the only
 + * ones that need to use block_info members that are not a closure are
 + * the legacy I/O managers select and win32-legacy. So when these I/O
 + * managers are removed then we can simplify the encoding.
   */
 -#define NotBlocked          0
 -#define BlockedOnMVar       1
 -#define BlockedOnMVarRead   14 /* TODO: renumber me, see #9003 */
 -#define BlockedOnBlackHole  2
 -#define BlockedOnRead       3
 -#define BlockedOnWrite      4
 -#define BlockedOnDelay      5
 -#define BlockedOnSTM        6
+-
 -/* Win32 only: */
 -#define BlockedOnDoProc     7
+-
 -/* Only relevant for THREADED_RTS: */
 -#define BlockedOnCCall      10
 -#define BlockedOnCCall_Interruptible 11
 -   /* same as above but permit killing the worker thread */
+-
 -/* Involved in a message sent to tso->msg_cap */
 -#define BlockedOnMsgThrowTo 12
 +#define BlockInfoForceNonClosure 16
 +#define UntagWhyBlocked(why) ((why) & 15)
 +#define IsBlockInfoClosure(why) (((why) & 24) == 0)
 +/*
 + * In the threaded RTS there is an invariant that the block_info union
 + * is always a valid GC closure. To ensure this, the tags that use
 + * block_info.unused, always set it to END_TSO_QUEUE. The non-closure
 + * why_blocked tags are only used by I/O managers on the non-threaded
 + * RTS. New in-RTS I/O managers use the AIOP and TimeoutQueue mechanism
 + * which are closures.
 + *
 + * Note: keep these in sync with GHC/Conc/Sync.hs: threadStatus
 + * Note: keep these in sync with Schedule.c: eventlogStopStatus which
 + * converts the constants here to the ones used in the eventlog.
 + */
 +#define NotBlocked          0 /* Uses block_info.prev */
 +#define BlockedOnMVar       1 /* Uses block_info.mvar */
 +#define BlockedOnMVarRead   2 /* Uses block_info.mvar */
 +#define BlockedOnBlackHole  3 /* Uses block_info.bh */
 +#define BlockedOnMsgThrowTo 4 /* Uses block_info.throwto */
 +#define BlockedOnRead       5 /* Uses block_info.aiop or uses .fd or
 +                                 .async_result with BlockInfoForceNonClosure */
 +#define BlockedOnWrite      6 /* Uses block_info.aiop or uses .fd or
 +                                 .async_result with BlockInfoForceNonClosure */
 +#define BlockedOnDelay      7 /* Uses block_info.timeout or
 +                                 uses .target with BlockInfoForceNonClosure */
++
 +#define BlockedOnSTM                  8 /* Uses block_info.unused */
 +#define BlockedOnCCall                9 /* Uses block_info.unused */
 +#define BlockedOnCCall_Interruptible 10 /* Uses block_info.unused
 +                                        * Same as BlockedOnCCall but permits
 +                                        * killing the worker thread */
 +#define ThreadMigrating              11 /* Uses block_info.unused */
 +#define BlockedOnDoProc              12 /* Uses block_info.async_result
 +                                         * used by win32-legacy I/O manager */
++
 +/* Reserved values, not values that why_blocked currently use. They
 + * are used in primop stg_threadStatuszh and must not overlap with
 + * other why_blocked status values. They could be changed, if the
 + * threadStatus in ghc-internal is updated too.
 + */
 +#define BlockedThreadComplete 16
 +#define BlockedThreadKilled   17
 -/* The thread is not on any run queues, but can be woken up
 -   by tryWakeupThread() */
 -#define ThreadMigrating     13
 +/* Next available non-closure why_blocked tag numbers are: 13,14,15
 + * For more closure tag numbers, shift up all the non-closure ones
 + * and adjust the BlockInfoForceNonClosure tag and related macros.
 + * If we reach BlockInfoForceNonClosure then shift that up. */
 -/* Next number is 15.  */
  /*
   * These constants are returned to the scheduler by a thread that has
@@ -286,6 +336,7 @@
  #define ThreadYielding 3
  #define ThreadBlocked  4
  #define ThreadFinished 5
 +/* If this is ever extended, also adjust the eventlogStopStatus mapping */
  /*
   * Flags for the tso->flags field.

rts/include/rts/EventLogFormat.h

@@ -26,7 +26,7 @@
   *    - generate the event itself by calling postEvent() somewhere
+  *
   *  - Describe the meaning and encoding of the event in the users guide
 - *    (docs/user_guide/eventlog-formats.rst)
 + *    (docs/users_guide/eventlog-formats.rst)
+  *
   *  - In the Haskell code to parse the event log file:
   *    - add types and code to read the new event
@@ -85,27 +85,26 @@
  /*
   * Status values for EVENT_STOP_THREAD
 - *
 - * 1-5 are the StgRun return values (from rts/include/Constants.h):
 - *
 - * #define HeapOverflow   1
 - * #define StackOverflow  2
 - * #define ThreadYielding 3
 - * #define ThreadBlocked  4
 - * #define ThreadFinished 5
 - * #define ForeignCall                  6
 - * #define BlockedOnMVar                7
 - * #define BlockedOnBlackHole           8
 - * #define BlockedOnRead                9
 - * #define BlockedOnWrite               10
 - * #define BlockedOnDelay               11
 - * #define BlockedOnSTM                 12
 - * #define BlockedOnDoProc              13
 - * #define BlockedOnCCall               -- not used (see ForeignCall)
 - * #define BlockedOnCCall_NoUnblockExc  -- not used (see ForeignCall)
 - * #define BlockedOnMsgThrowTo          16
 + * type EventThreadStatus
 + * Keep values in sync with docs/users_guide/eventlog-formats.rst
   */
 -#define THREAD_SUSPENDED_FOREIGN_CALL 6
 +#define STOP_THREAD_HeapOverflow        1
 +#define STOP_THREAD_StackOverflow       2
 +#define STOP_THREAD_ThreadYielding      3
 +/* 4 unused */
 +#define STOP_THREAD_ThreadFinished      5
 +#define STOP_THREAD_ForeignCall         6
 +#define STOP_THREAD_BlockedOnMVar       7
 +#define STOP_THREAD_BlockedOnBlackHole  8
 +#define STOP_THREAD_BlockedOnRead       9
 +#define STOP_THREAD_BlockedOnWrite      10
 +#define STOP_THREAD_BlockedOnDelay      11
 +#define STOP_THREAD_BlockedOnSTM        12
 +#define STOP_THREAD_BlockedOnDoProc     13
 +/* 14-17 unused */
 +#define STOP_THREAD_BlockedOnMsgThrowTo 18
 +/* 19 unused */
 +#define STOP_THREAD_BlockedOnMVarRead   20
  /*
   * Capset type values for EVENT_CAPSET_CREATE

rts/include/rts/storage/TSO.h

@@ -30,6 +30,15 @@ typedef StgWord64 StgThreadID;
  #define tsoLocked(tso) ((tso)->flags & TSO_LOCKED)
 +/* Type for the tso->why_blocked field. See values in Constants.h.
 + *
 + * The StgThreadWhyBlocked type could be 8-bits, but for reasons
 + * unclear it is currently 32-bits. Previous comments here claimed
 + * that the smallest atomic type on AArch64 is 32-bits, but this is
 + * false.
 + */
 +typedef StgWord32 StgThreadWhyBlocked;
++
  /*
   * Type returned after running a thread.  Values of this type
   * include HeapOverflow, StackOverflow etc.  See Constants.h for the
@@ -37,20 +46,46 @@ typedef StgWord64 StgThreadID;
   */
  typedef unsigned int StgThreadReturnCode;
 -/* Reason for thread being blocked. See comment above struct StgTso_. */
 +/* Additional information about how the thread is blocked.
 + * The tso->why_blocked is the tag for this union. */
  typedef union {
 +  /* Used for generic read, for cases where block_info is a closure.
 +   * Never used for writes. Use .unused below instead. */
    StgClosure *closure;
 -  StgTSO *prev; // a back-link when the TSO is on the run queue (NotBlocked)
++
 +  /* For why_blocked cases where block_info is unused, this will be set to
 +   * END_TSO_QUEUE, to maintain invariant that block_info.closure is valid */
 +  StgTSO *unused;
++
 +  /* case NotBlocked: A back-link when the TSO is on the run queue */
 +  StgTSO *prev;
++
 +  /* case BlockedOnMVar, BlockedOnMVarRead: the mvar the TSO is blocked on */
 +  StgMVar *mvar;
++
 +  /* case BlockedOnBlackHole */
    struct MessageBlackHole_ *bh;
++
 +  /* case BlockedOnMsgThrowTo */
    struct MessageThrowTo_ *throwto;
 -  struct MessageWakeup_  *wakeup;
++
 +  /* case BlockedOnRead, BlockedOnWrite: legacy I/O managers */
    StgInt fd;    /* StgInt instead of int, so that it's the same size as the ptrs */
++
 +  /* case BlockedOnRead, BlockedOnWrite: new I/O managers */
    StgAsyncIOOp *aiop;
++
 +  /* case BlockedOnDelay: new I/O managers */
    StgTimeoutQueue *timeout;
++
  #if defined(mingw32_HOST_OS)
 +  /* case BlockedOnRead, BlockedOnWrite, BlockedOnDoProc:
 +   * used by the win32-legacy I/O manager */
    StgWord async_reqID;
  #endif
++
  #if !defined(THREADED_RTS)
 +  /* case BlockedOnDelay: used by the select I/O manager */
    StgWord target;
      // Only for the non-threaded RTS: the target time for a thread
      // blocked in threadDelay, in units of 1ms.  This is a
@@ -71,7 +106,21 @@ typedef union {
   * have the reason in the why_blocked field of the TSO, and some
   * further info (such as the closure the thread is blocked on, or the
   * file descriptor if the thread is waiting on I/O) in the block_info
 - * field.
 + * field. See Constants.h for the why_blocked values.
 + *
 + * The why_blocked field must be updated atomically. The protocol for
 + * updating block_info and why_blocked fields together is as follows:
 + *
 + *   Writes:
 + *     - first write block_info (normal non-atomic write)
 + *     - then write why_blocked with an atomic *store release*
 + *
 + *   Reads:
 + *     - first read why_blocked with an atomic *load acquire*
 + *     - then read block_info (normal non-atomic read)
 + *
 + *   Read of only why_blocked without block_info:
 + *     - read why_blocked with an atomic *relaxed load*
   */
  typedef struct StgTSO_ {
@@ -121,11 +170,7 @@ typedef struct StgTSO_ {
      StgWord16               what_next;      // Values defined in Constants.h
      StgWord32               flags;          // Values defined in Constants.h
 -    /*
 -     * N.B. why_blocked only has a handful of values but must be atomically
 -     * updated; the smallest width which AArch64 supports for is 32-bits.
 -     */
 -    StgWord32               why_blocked;    // Values defined in Constants.h
 +    StgThreadWhyBlocked     why_blocked;    // Values defined in Constants.h
      StgTSOBlockInfo         block_info;     // Barrier provided by why_blocked
      StgThreadID             id;
      StgWord32               saved_errno;

rts/posix/Poll.c

@@ -146,8 +146,9 @@ bool syncIOWaitReadyPoll(Capability *cap, StgTSO *tso,
      aiop->notify.tso     = tso;
      aiop->notify_type    = NotifyTSO;
      aiop->live           = &stg_ASYNCIO_LIVE0_closure;
 -    tso->why_blocked     = rw == IORead ? BlockedOnRead : BlockedOnWrite;
      tso->block_info.aiop = aiop;
 +    RELEASE_STORE(&tso->why_blocked, rw == IORead ? BlockedOnRead
 +                                                  : BlockedOnWrite);
      return asyncIOWaitReadyPoll(cap, aiop, rw, fd);
+ }
@@ -194,7 +195,6 @@ void syncIOCancelPoll(Capability *cap, StgTSO *tso)
       * We don't put the TSO back on the run queue or change the why_blocked
       * status, as that is done by removeFromQueues (in the throwTo* functions).
       */
 -    tso->block_info.closure = (StgClosure *)END_TSO_QUEUE;
+ }
@@ -259,10 +259,9 @@ static void notifyIOCompletion(Capability *cap, StgAsyncIOOp *aiop)
                   * 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;
 -                tso->why_blocked = NotBlocked;
 -                tso->_link       = END_TSO_QUEUE;
 +                StgTSO *tso = aiop->notify.tso;
                  pushOnRunQueue(cap, tso);
 +                RELEASE_STORE(&tso->why_blocked, NotBlocked);
+             }
              break;
+         }

rts/posix/Select.c

@@ -105,11 +105,10 @@ static bool wakeUpSleepingThreads (Capability *cap, LowResTime now)
              break;
+         }
          iomgr->sleeping_queue = tso->_link;
 -        RELAXED_STORE(&tso->why_blocked, NotBlocked);
 -        tso->_link = END_TSO_QUEUE;
          IF_DEBUG(scheduler, debugBelch("Waking up sleeping thread %"
                                         FMT_StgThreadID "\n", tso->id));
          pushOnRunQueue(cap,tso);
 +        RELEASE_STORE(&tso->why_blocked, NotBlocked);
          flag = true;
+     }
      return flag;
@@ -268,7 +267,7 @@ awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait)
         * So the (int) cast should be removed across the code base once
         * GHC requires a version of FreeBSD that has that change in it.
         */
 -        switch (ACQUIRE_LOAD(&tso->why_blocked)) {
 +        switch (UntagWhyBlocked(ACQUIRE_LOAD(&tso->why_blocked))) {
          case BlockedOnRead:
+           {
              int fd = tso->block_info.fd;
@@ -397,7 +396,7 @@ awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait)
                int fd;
                enum FdState fd_state = RTS_FD_IS_BLOCKING;
 -              switch (tso->why_blocked) {
 +              switch (UntagWhyBlocked(ACQUIRE_LOAD(&tso->why_blocked))) {
                case BlockedOnRead:
                    fd = tso->block_info.fd;
@@ -436,9 +435,8 @@ awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait)
                    IF_DEBUG(scheduler,
                        debugBelch("Waking up blocked thread %" FMT_StgThreadID "\n",
                                   tso->id));
 -                  tso->why_blocked = NotBlocked;
 -                  tso->_link = END_TSO_QUEUE;
                    pushOnRunQueue(cap,tso);
 +                  RELEASE_STORE(&tso->why_blocked, NotBlocked);
                    break;
                case RTS_FD_IS_BLOCKING:
                    if (prev == NULL)

rts/posix/Timeout.c

@@ -48,8 +48,8 @@ bool syncDelayTimeout(Capability *cap, StgTSO *tso, HsInt us_delay)
      initElemTimeoutQueue(timeout, notify, NotifyTSO, cap->r.rCCCS);
      ASSERT(tso->why_blocked == NotBlocked);
 -    tso->why_blocked = BlockedOnDelay;
      tso->block_info.timeout = timeout;
 +    RELEASE_STORE(&tso->why_blocked, BlockedOnDelay);
      insertTimeoutQueue(&cap->iomgr->timeout_queue, timeout, target);
@@ -67,8 +67,6 @@ void syncDelayCancelTimeout(Capability *cap, StgTSO *tso)
      deleteTimeoutQueue(&cap->iomgr->timeout_queue, timeout);
 -    tso->block_info.closure = (StgClosure *)END_TSO_QUEUE;
+-
      /* the timeout is no longer accessible from anywhere (except here) */
      IF_NONMOVING_WRITE_BARRIER_ENABLED {
          updateRemembSetPushClosure(cap, (StgClosure *)timeout);
@@ -120,10 +118,10 @@ static void notifyTimeoutCompletion(Capability *cap, StgTimeout *timeout)
      switch (timeout->notify_type) {
          case NotifyTSO:
+         {
 -            StgTSO *tso      = timeout->notify.tso;
 -            tso->why_blocked = NotBlocked;
 -            tso->_link       = END_TSO_QUEUE;
 +            StgTSO *tso = timeout->notify.tso;
 +            tso->_link  = END_TSO_QUEUE;
              pushOnRunQueue(cap, tso);
 +            RELEASE_STORE(&tso->why_blocked, NotBlocked);
              break;
+         }
          case NotifyMVar:

rts/sm/Compact.c

@@ -468,16 +468,10 @@ thread_TSO (StgTSO *tso)
      thread_(&tso->_link);
      thread_(&tso->global_link);
 -    switch (ACQUIRE_LOAD(&tso->why_blocked)) {
 -    case BlockedOnMVar:
 -    case BlockedOnMVarRead:
 -    case BlockedOnBlackHole:
 -    case BlockedOnMsgThrowTo:
 -    case NotBlocked:
 +    if (IsBlockInfoClosure(ACQUIRE_LOAD(&tso->why_blocked))) {
 +        /* This also follows the block_info.prev back-link in
 +         * the NotBlocked case, which may not be necessary. */
          thread_(&tso->block_info.closure);
 -        break;
 -    default:
 -        break;
+     }
      thread_(&tso->blocked_exceptions);
      thread_(&tso->bq);

rts/sm/NonMovingMark.c

@@ -1055,16 +1055,10 @@ trace_tso (MarkQueue *queue, StgTSO *tso)
      if (tso->label != NULL) {
          markQueuePushClosure_(queue, (StgClosure *) tso->label);
+     }
 -    switch (ACQUIRE_LOAD(&tso->why_blocked)) {
 -    case BlockedOnMVar:
 -    case BlockedOnMVarRead:
 -    case BlockedOnBlackHole:
 -    case BlockedOnMsgThrowTo:
 -    case NotBlocked:
 +    if (IsBlockInfoClosure(ACQUIRE_LOAD(&tso->why_blocked))) {
 +        /* This also follows the block_info.prev back-link in
 +         * the NotBlocked case, which may not be necessary. */
          markQueuePushClosure_(queue, tso->block_info.closure);
 -        break;
 -    default:
 -        break;
+     }
+ }

rts/sm/Sanity.c

@@ -779,13 +779,45 @@ checkTSO(StgTSO *tso)
             info == &stg_WHITEHOLE_info); // used to happen due to STM doing
                                           // lockTSO(), might not happen now
 -    if (   tso->why_blocked == BlockedOnMVar
 -        || tso->why_blocked == BlockedOnMVarRead
 -        || tso->why_blocked == BlockedOnBlackHole
 -        || tso->why_blocked == BlockedOnMsgThrowTo
 -        || tso->why_blocked == NotBlocked
 -        ) {
 +    StgThreadWhyBlocked why_blocked = ACQUIRE_LOAD(&tso->why_blocked);
 +    switch (why_blocked) {
 +    case NotBlocked:
 +    case BlockedOnMVar:
 +    case BlockedOnMVarRead:
 +    case BlockedOnBlackHole:
 +    case BlockedOnMsgThrowTo:
 +    case BlockedOnRead:
 +    case BlockedOnWrite:
 +    case BlockedOnDelay:
 +        //TODO: we could be more specific and check BlockedOnMVar has an MVar,
 +        // BlockedOnBlackHole has a message, BlockedOnRead has an AIOP etc.
 +        ASSERT(IsBlockInfoClosure(why_blocked));
          ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->block_info.closure));
 +        break;
++
 +    case BlockedOnSTM:
 +    case BlockedOnCCall:
 +    case BlockedOnCCall_Interruptible:
 +    case ThreadMigrating:
 +#if defined(mingw32_HOST_OS) && !defined(THREADED_RTS)
 +    case BlockedOnDoProc:
 +#endif
 +        ASSERT(!IsBlockInfoClosure(why_blocked));
 +        ASSERT(tso->block_info.unused == END_TSO_QUEUE);
 +        break;
++
 +#if !defined(THREADED_RTS)
 +    // Only these three can use BlockInfoForceNonClosure
 +    case BlockedOnRead  | BlockInfoForceNonClosure:
 +    case BlockedOnWrite | BlockInfoForceNonClosure:
 +    case BlockedOnDelay | BlockInfoForceNonClosure:
 +        ASSERT(!IsBlockInfoClosure(why_blocked));
 +        break;
 +#endif
++
 +    default:
 +        barf("checkTSO: strange tso->why_blocked: %d for TSO %"
 +             FMT_StgThreadID " (%p)", why_blocked, tso->id, tso);
+     }
      ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->bq));

rts/sm/Scav.c

@@ -138,29 +138,16 @@ scavengeTSO (StgTSO *tso)
          evacuate((StgClosure **)&tso->label);
+     }
 -    switch (ACQUIRE_LOAD(&tso->why_blocked)) {
 -    case BlockedOnMVar:
 -    case BlockedOnMVarRead:
 -    case BlockedOnBlackHole:
 -    case BlockedOnMsgThrowTo:
 -    case NotBlocked:
 +    if (IsBlockInfoClosure(ACQUIRE_LOAD(&tso->why_blocked))) {
          evacuate(&tso->block_info.closure);
 -        break;
 -    case BlockedOnRead:
 -    case BlockedOnWrite:
 -    case BlockedOnDelay:
 -    case BlockedOnDoProc:
 -        scavengeTSOIOManager(tso);
 -        break;
 -    default:
 +    } else {
  #if defined(THREADED_RTS)
      // in the THREADED_RTS, block_info.closure must always point to a
      // valid closure, because we assume this in throwTo().  In the
      // non-threaded RTS it might be a FD (for
      // BlockedOnRead/BlockedOnWrite) or a time value (BlockedOnDelay)
 -        tso->block_info.closure = (StgClosure *)END_TSO_QUEUE;
 +        ASSERT(tso->block_info.unused == END_TSO_QUEUE);
  #endif
 -        break;
+     }
      tso->dirty = gct->failed_to_evac;

rts/win32/AsyncMIO.c

@@ -298,7 +298,7 @@ start:
              for(tso = iomgr->blocked_queue_hd; tso != END_TSO_QUEUE;
                    tso = tso->_link) {
 -                switch(ACQUIRE_LOAD(&tso->why_blocked)) {
 +                switch (UntagWhyBlocked(ACQUIRE_LOAD(&tso->why_blocked))) {
                  case BlockedOnRead:
                  case BlockedOnWrite:
                  case BlockedOnDoProc:
@@ -318,8 +318,6 @@ start:
+                         }
                          // Terminates the run queue + this inner for-loop.
 -                        tso->_link = END_TSO_QUEUE;
 -                        tso->why_blocked = NotBlocked;
                          // For stg_block_async frames (read/write/doProc),
                          // write len and errCode directly to the stack.
                          // For stg_block_noregs frames (delay), nothing
@@ -329,14 +327,14 @@ start:
                              tso->stackobj->sp[2] = (W_)errCode;
+                         }
                          pushOnRunQueue(&MainCapability, tso);
 +                        RELEASE_STORE(&tso->why_blocked, NotBlocked);
                          break;
+                     }
                      break;
 -                default:
 -                    if (tso->why_blocked != NotBlocked) {
 -                        barf("awaitRequests: odd thread state");
 -                    }
 +                case NotBlocked:
                      break;
 +                default:
 +                    barf("awaitRequests: odd thread state");
+                 }
                  prev = tso;