Rodrigo Mesquita pushed to branch wip/romes/27131 at Glasgow Haskell Compiler / GHC Commits: 321f7a7f by Rodrigo Mesquita at 2026-03-31T14:28:45+01:00 New rts Message to {set,unset} TSO flags [skip ci] This commit introduces stg_MSG_SET_TSO_FLAG_info and stg_MSG_UNSET_TSO_FLAG_info, which allows setting flags of a TSO other than yourself. This is especially useful/necessary to set breakpoints and toggle breakpoints of different threads, which is needed to safely implement features like pausing, toggling step-out, toggling step-in per thread, etc. Fixes #27131 - - - - - 7 changed files: - rts/Interpreter.c - rts/Messages.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Threads.h - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h Changes: ===================================== rts/Interpreter.c ===================================== @@ -416,12 +416,12 @@ void rts_disableStopNextBreakpointAll(void) void rts_enableStopNextBreakpoint(StgTSO* tso) { - tso->flags |= TSO_STOP_NEXT_BREAKPOINT; + setThreadFlag(_, tso, TSO_STOP_NEXT_BREAKPOINT); } void rts_disableStopNextBreakpoint(StgTSO* tso) { - tso->flags &= ~TSO_STOP_NEXT_BREAKPOINT; + unsetThreadFlag(_, tso, TSO_STOP_NEXT_BREAKPOINT); } /* --------------------------------------------------------------------------- @@ -430,12 +430,12 @@ void rts_disableStopNextBreakpoint(StgTSO* tso) void rts_enableStopAfterReturn(StgTSO* tso) { - tso->flags |= TSO_STOP_AFTER_RETURN; + setThreadFlag(_, tso, TSO_STOP_AFTER_RETURN); } void rts_disableStopAfterReturn(StgTSO* tso) { - tso->flags &= ~TSO_STOP_AFTER_RETURN; + unsetThreadFlag(_, tso, TSO_STOP_AFTER_RETURN); } /* ===================================== rts/Messages.c ===================================== @@ -137,6 +137,16 @@ loop: MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m; handleCloneStackMessage(cap, cloneStackMessage); } + else if(i == &stg_MSG_SET_TSO_FLAG_info){ + MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m; + u->tso->flags |= u->flag; + return; + } + else if(i == &stg_MSG_UNSET_TSO_FLAG_info){ + MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m; + u->tso->flags &= ~u->flag; + return; + } else { barf("executeMessage: %p", i); ===================================== rts/StgMiscClosures.cmm ===================================== @@ -855,6 +855,12 @@ INFO_TABLE_CONSTR(stg_MSG_NULL,1,0,0,PRIM,"MSG_NULL","MSG_NULL") INFO_TABLE_CONSTR(stg_MSG_CLONE_STACK,3,0,0,PRIM,"MSG_CLONE_STACK","MSG_CLONE_STACK") { ccall pbarf("stg_MSG_CLONE_STACK object (%p) entered!", R1 "ptr") never returns; } +INFO_TABLE_CONSTR(stg_MSG_SET_TSO_FLAG,3,0,0,PRIM,"MSG_SET_TSO_FLAG","MSG_SET_TSO_FLAG") +{ foreign "C" barf("stg_MSG_SET_TSO_FLAG object (%p) entered!", R1) never returns; } + +INFO_TABLE_CONSTR(stg_MSG_UNSET_TSO_FLAG,3,0,0,PRIM,"MSG_UNSET_TSO_FLAG","MSG_UNSET_TSO_FLAG") +{ foreign "C" barf("stg_MSG_UNSET_TSO_FLAG object (%p) entered!", R1) never returns; } + /* ---------------------------------------------------------------------------- END_TSO_QUEUE ===================================== rts/Threads.c ===================================== @@ -376,6 +376,32 @@ migrateThread (Capability *from, StgTSO *tso, Capability *to) tryWakeupThread(from, tso); } +/* ---------------------------------------------------------------------------- + {set,unset}ThreadFlag + + sets or unsets a flag in a given TSO + ------------------------------------------------------------------------- */ + +void setThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag) +{ + updThreadFlag(from, tso, flag, &stg_MSG_SET_TSO_FLAG_info); +} +void unsetThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag) +{ + updThreadFlag(from, tso, flag, &stg_MSG_UNSET_TSO_FLAG_info); +} + +static void +updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, StgInfoTable* info) +{ + MessageUpdTSOFlag *msg; + msg = (MessageUpdTSOFlag *)allocate(from,sizeofW(MessageUpdTSOFlag)); + msg->tso = tso; + msg->flag = flag; + SET_HDR(msg, info, CCS_SYSTEM); + sendMessage(cap, tso->cap, (Message*)msg); +} + /* ---------------------------------------------------------------------------- awakenBlockedQueue ===================================== rts/Threads.h ===================================== @@ -19,6 +19,9 @@ void checkBlockingQueues (Capability *cap, StgTSO *tso); void tryWakeupThread (Capability *cap, StgTSO *tso); void migrateThread (Capability *from, StgTSO *tso, Capability *to); +void setThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag); +void unsetThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag); + // Wakes up a thread on a Capability (probably a different Capability // from the one held by the current Task). // ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -620,6 +620,12 @@ typedef struct MessageCloneStack_ { StgTSO *tso; } MessageCloneStack; +typedef struct MessageUpdTSOFlag_ { + StgHeader header; + Message *link; + StgTSO *tso; + StgWord32 flag; +} MessageUpdTSOFlag; /* ---------------------------------------------------------------------------- Compact Regions ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -152,6 +152,8 @@ RTS_ENTRY(stg_MSG_TRY_WAKEUP); RTS_ENTRY(stg_MSG_THROWTO); RTS_ENTRY(stg_MSG_BLACKHOLE); RTS_ENTRY(stg_MSG_CLONE_STACK); +RTS_ENTRY(stg_MSG_SET_TSO_FLAG); +RTS_ENTRY(stg_MSG_UNSET_TSO_FLAG); RTS_ENTRY(stg_MSG_NULL); RTS_ENTRY(stg_MVAR_TSO_QUEUE); RTS_ENTRY(stg_catch); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/321f7a7f2f314fe76cc95ab61d820a88... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/321f7a7f2f314fe76cc95ab61d820a88... You're receiving this email because of your account on gitlab.haskell.org.