GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

a46a1bb1

by Cheng Shao at 2026-03-09T04:50:30-04:00

compiler: add myCapabilityExpr to GHC.Cmm.Utils

This commit adds `myCapabilityExpr` to `GHC.Cmm.Utils` which is
computed from `BaseReg`. It's convenient for codegen logic where one
needs to pass the current Capability's pointer.

4afc65b1

by Cheng Shao at 2026-03-09T04:50:30-04:00

compiler: lower tryPutMVar# into a ccall directly

This patch addresses an old TODO of `stg_tryPutMVarzh` by removing it
completely and making the compiler lower `tryPutMVar#` into a ccall to
`performTryPutMVar` directly, without landing into an intermediate C
or Cmm function. `performTryPutMVar` is promoted to a public RTS
function with default visibility, and the compiler lowering logic
takes into account the C ABI of `performTryPutMVar` and converts from
C Bool to primop's `Int#` result properly.

8 changed files:

compiler/GHC/Cmm/Utils.hs
compiler/GHC/StgToCmm/Prim.hs
rts/PrimOps.cmm
rts/RtsSymbols.c
rts/Threads.c
rts/Threads.h
rts/include/rts/Threads.h
rts/include/stg/MiscClosures.h

Changes:

compiler/GHC/Cmm/Utils.hs

@@ -37,6 +37,7 @@ module GHC.Cmm.Utils(
          baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
          currentTSOExpr, currentNurseryExpr, cccsExpr,
 +        myCapabilityExpr,
          -- Tagging
          cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,
@@ -569,7 +570,7 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b []
  -- Access to common global registers
  baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
 -  spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr
 +  spLimExpr, hpLimExpr, cccsExpr, myCapabilityExpr :: Platform -> CmmExpr
  baseExpr           p = CmmReg $ baseReg           p
  spExpr             p = CmmReg $ spReg             p
  spLimExpr          p = CmmReg $ spLimReg          p
@@ -578,3 +579,5 @@ hpLimExpr          p = CmmReg $ hpLimReg          p
  currentTSOExpr     p = CmmReg $ currentTSOReg     p
  currentNurseryExpr p = CmmReg $ currentNurseryReg p
  cccsExpr           p = CmmReg $ cccsReg           p
 +myCapabilityExpr   p =
 +  cmmRegOff (baseReg p) $ negate $ pc_OFFSET_Capability_r $ platformConstants p

compiler/GHC/StgToCmm/Prim.hs

@@ -345,6 +345,25 @@ emitPrimOp cfg primop =
      emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val]
      emitDirtyMutVar mutv (CmmReg (CmmLocal res))
 +  TryPutMVarOp -> \[mvar, val] -> inlinePrimop $ \[res] -> do
 +    cres <- newTemp b8
 +    emitCCall
 +      [(cres, NoHint)]
 +      ( CmmLit
 +          ( CmmLabel
 +              ( mkForeignLabel
 +                  (fsLit "performTryPutMVar")
 +                  ForeignLabelInExternalPackage
 +                  IsFunction
 +              )
 +          )
 +      )
 +      [(myCapabilityExpr platform, AddrHint), (mvar, AddrHint), (val, AddrHint)]
 +    emitAssign (CmmLocal res) $
 +      CmmMachOp
 +        (MO_UU_Conv W8 (wordWidth platform))
 +        [CmmReg (CmmLocal cres)]
++
  --  #define sizzeofByteArrayzh(r,a) \
  --     r = ((StgArrBytes *)(a))->bytes
    SizeofByteArrayOp -> \[arg] -> inlinePrimop $ \[res] ->
@@ -1777,7 +1796,6 @@ emitPrimOp cfg primop =
    TakeMVarOp -> alwaysExternal
    TryTakeMVarOp -> alwaysExternal
    PutMVarOp -> alwaysExternal
 -  TryPutMVarOp -> alwaysExternal
    ReadMVarOp -> alwaysExternal
    TryReadMVarOp -> alwaysExternal
    IsEmptyMVarOp -> alwaysExternal

rts/PrimOps.cmm

@@ -1927,95 +1927,6 @@ loop:
+ }
 -// NOTE: there is another implementation of this function in
 -// Threads.c:performTryPutMVar().  Keep them in sync!  It was
 -// measurably slower to call the C function from here (70% for a
 -// tight loop doing tryPutMVar#).
 -//
 -// TODO: we could kill the duplication by making tryPutMVar# into an
 -// inline primop that expands into a C call to performTryPutMVar().
 -stg_tryPutMVarzh ( P_ mvar, /* :: MVar a */
 -                   P_ val,  /* :: a */ )
 -{
 -    W_ info, tso, q, qinfo;
+-
 -    LOCK_CLOSURE(mvar, info);
+-
 -    if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
 -#if defined(THREADED_RTS)
 -        unlockClosure(mvar, info);
 -#endif
 -        return (0);
 -    }
+-
 -    q = StgMVar_head(mvar);
 -loop:
 -    if (q == stg_END_TSO_QUEUE_closure) {
 -        /* No further takes, the MVar is now full. */
 -        if (info == stg_MVAR_CLEAN_info) {
 -            ccall dirty_MVAR(BaseReg "ptr", mvar "ptr", StgMVar_value(mvar) "ptr");
 -        }
+-
 -        StgMVar_value(mvar) = val;
 -        unlockClosure(mvar, stg_MVAR_DIRTY_info);
 -        return (1);
 -    }
+-
 -    qinfo = GET_INFO_ACQUIRE(q);
+-
 -    if (qinfo == stg_IND_info ||
 -        qinfo == stg_MSG_NULL_info) {
 -        q = %acquire StgInd_indirectee(q);
 -        goto loop;
 -    }
+-
 -    // There are takeMVar(s) waiting: wake up the first one
+-
 -    tso = StgMVarTSOQueue_tso(q);
 -    q = StgMVarTSOQueue_link(q);
 -    StgMVar_head(mvar) = q;
 -    if (q == stg_END_TSO_QUEUE_closure) {
 -        StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
 -    } else {
 -        if (info == stg_MVAR_CLEAN_info) {
 -            // Resolve #18919.
 -            ccall dirty_MVAR(BaseReg "ptr", mvar "ptr",
 -                             StgMVar_value(mvar) "ptr");
 -            info = stg_MVAR_DIRTY_info;
 -        }
 -    }
+-
 -    // save why_blocked here, because waking up the thread destroys
 -    // this information
 -    W_ why_blocked;
 -    why_blocked = TO_W_(StgTSO_why_blocked(tso)); // TODO: Missing barrier
 -    ASSERT(StgTSO_block_info(tso) == mvar);
+-
 -    // actually perform the takeMVar
 -    W_ stack;
 -    stack = StgTSO_stackobj(tso);
 -    if (IS_STACK_CLEAN(stack)) {
 -        ccall dirty_STACK(MyCapability() "ptr", stack "ptr");
 -    }
 -    PerformTake(stack, val);
+-
 -    // indicate that the MVar operation has now completed.
 -    StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
+-
 -    ccall tryWakeupThread(MyCapability() "ptr", tso);
+-
 -    // If it was a readMVar, then we can still do work,
 -    // so loop back. (XXX: This could take a while)
 -    if (why_blocked == BlockedOnMVarRead)
 -        goto loop;
+-
 -    ASSERT(why_blocked == BlockedOnMVar);
+-
 -    unlockClosure(mvar, info);
 -    return (1);
 -}
+-
+-
  stg_readMVarzh ( P_ mvar, /* :: MVar a */ )
+ {
      W_ val, info, tso, q;

rts/RtsSymbols.c

@@ -678,6 +678,7 @@ extern char **environ;
        SymI_HasDataProto(stg_readTVarIOzh)                                   \
        SymI_HasProto(resumeThread)                                       \
        SymI_HasProto(setNumCapabilities)                                 \
 +      SymI_HasProto(performTryPutMVar)                                  \
        SymI_HasProto(getNumberOfProcessors)                              \
        SymI_HasProto(resolveObjs)                                        \
        SymI_HasDataProto(stg_retryzh)                                        \
@@ -869,7 +870,6 @@ extern char **environ;
        SymI_HasDataProto(stg_takeMVarzh)                                     \
        SymI_HasDataProto(stg_readMVarzh)                                     \
        SymI_HasDataProto(stg_threadStatuszh)                                 \
 -      SymI_HasDataProto(stg_tryPutMVarzh)                                   \
        SymI_HasDataProto(stg_tryTakeMVarzh)                                  \
        SymI_HasDataProto(stg_tryReadMVarzh)                                  \
        SymI_HasDataProto(stg_unmaskAsyncExceptionszh)                        \

rts/Threads.c

@@ -795,8 +795,6 @@ threadStackUnderflow (Capability *cap, StgTSO *tso)
  /* ----------------------------------------------------------------------------
     Implementation of tryPutMVar#
+-
 -   NOTE: this should be kept in sync with stg_tryPutMVarzh in PrimOps.cmm
     ------------------------------------------------------------------------- */
  bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value)

rts/Threads.h

@@ -24,7 +24,7 @@ void migrateThread       (Capability *from, StgTSO *tso, Capability *to);
  //
  #if defined(THREADED_RTS)
  void wakeupThreadOnCapability (Capability *cap,
 -                               Capability *other_cap,
 +                               Capability *other_cap,
                                 StgTSO *tso);
  #endif
@@ -40,8 +40,6 @@ StgBool isThreadBound (StgTSO* tso);
  void threadStackOverflow  (Capability *cap, StgTSO *tso);
  W_   threadStackUnderflow (Capability *cap, StgTSO *tso);
 -bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value);
+-
  #if defined(DEBUG)
  void printThreadBlockage (StgTSO *tso);
  void printThreadStatus (StgTSO *t);

rts/include/rts/Threads.h

@@ -90,3 +90,5 @@ extern Capability MainCapability;
  // current value at the moment).
  //
  extern void setNumCapabilities (uint32_t new_);
++
 +bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value);

rts/include/stg/MiscClosures.h

@@ -512,7 +512,6 @@ RTS_FUN_DECL(stg_takeMVarzh);
  RTS_FUN_DECL(stg_putMVarzh);
  RTS_FUN_DECL(stg_readMVarzh);
  RTS_FUN_DECL(stg_tryTakeMVarzh);
 -RTS_FUN_DECL(stg_tryPutMVarzh);
  RTS_FUN_DECL(stg_tryReadMVarzh);
  RTS_FUN_DECL(stg_waitReadzh);