Rodrigo Mesquita pushed to branch wip/romes/27131 at Glasgow Haskell Compiler / GHC Commits: 4a86b837 by Rodrigo Mesquita at 2026-04-29T15:31:09+01:00 test: Add test setting another TSO's flags Introduces a test that runs on two capabilities. The main thread running on Capability 0 sets the flags on a TSO running on Capability 1. The TSO from Capability 1 itself checks whether its flags were set and reports that back. This validates that the RTS messages for setting TSO flags work, even if it doesn't test a harsher scenario with race conditions to exercise why the message passing is necessary for safely setting another TSO's flags. Part of #27131 - - - - - 4 changed files: - + testsuite/tests/rts/T27131.hs - + testsuite/tests/rts/T27131.stdout - + testsuite/tests/rts/T27131_c.c - testsuite/tests/rts/all.T Changes: ===================================== testsuite/tests/rts/T27131.hs ===================================== @@ -0,0 +1,81 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import Control.Concurrent +import Control.Monad +import Foreign.C.Types +import GHC.Conc.Sync (ThreadId(..), forkOn, myThreadId, setNumCapabilities) +import GHC.Exts (ThreadId#) + +foreign import ccall unsafe "rts_enableStopNextBreakpoint" + rts_enableStopNextBreakpoint :: ThreadId# -> IO () + +foreign import ccall unsafe "rts_disableStopNextBreakpoint" + rts_disableStopNextBreakpoint :: ThreadId# -> IO () + +foreign import ccall unsafe "rts_enableStopAfterReturn" + rts_enableStopAfterReturn :: ThreadId# -> IO () + +foreign import ccall unsafe "rts_disableStopAfterReturn" + rts_disableStopAfterReturn :: ThreadId# -> IO () + +foreign import ccall unsafe "has_local_stop_next_breakpoint" + c_hasLocalStopNextBreakpoint :: IO CInt + +foreign import ccall unsafe "has_local_stop_after_return" + c_hasLocalStopAfterReturn :: IO CInt + +main :: IO () +main = do + setNumCapabilities 2 + checkFlag + "TSO_STOP_NEXT_BREAKPOINT" + rts_enableStopNextBreakpoint + rts_disableStopNextBreakpoint + c_hasLocalStopNextBreakpoint + checkFlag + "TSO_STOP_AFTER_RETURN" + rts_enableStopAfterReturn + rts_disableStopAfterReturn + c_hasLocalStopAfterReturn + +checkFlag + :: String + -> (ThreadId# -> IO ()) + -> (ThreadId# -> IO ()) + -> IO CInt + -> IO () +checkFlag label enable disable isMyThreadFlagSet = do + -- Print the main thread's capability (should be 0) + print =<< threadCapability =<< myThreadId + + -- Target thread will write its own flag value here + targetCheckVar <- newEmptyMVar + + -- Run the new TSO runs on capability 1 + ThreadId tid# <- forkOn 1 $ do + replicateM_ 2 $ do + replyVar <- takeMVar targetCheckVar + isSet <- (/= 0) <$> isMyThreadFlagSet + putMVar replyVar isSet + + -- Enable the other TSO's flag + enable tid# + -- It will check whether it is set and reply here + renderCheck label "set" =<< checkTarget targetCheckVar + + -- Ditto. + disable tid# + renderCheck label "unset" . not =<< checkTarget targetCheckVar + +checkTarget :: MVar (MVar Bool) -> IO Bool +checkTarget targetCheckVar = do + replyVar <- newEmptyMVar + putMVar targetCheckVar replyVar + takeMVar replyVar + +renderCheck :: String -> String -> Bool -> IO () +renderCheck label state ok = putStrLn $ + label ++ " " ++ state ++ ": " ++ if ok then "ok" else "failed" ===================================== testsuite/tests/rts/T27131.stdout ===================================== @@ -0,0 +1,6 @@ +(0,False) +TSO_STOP_NEXT_BREAKPOINT set: ok +TSO_STOP_NEXT_BREAKPOINT unset: ok +(0,False) +TSO_STOP_AFTER_RETURN set: ok +TSO_STOP_AFTER_RETURN unset: ok ===================================== testsuite/tests/rts/T27131_c.c ===================================== @@ -0,0 +1,15 @@ +#include "Rts.h" + +int has_local_stop_next_breakpoint(void) +{ + CapabilityPublic *cap = (CapabilityPublic *) rts_unsafeGetMyCapability(); + StgTSO *tso = cap->r.rCurrentTSO; + return (tso->flags & TSO_STOP_NEXT_BREAKPOINT) != 0; +} + +int has_local_stop_after_return(void) +{ + CapabilityPublic *cap = (CapabilityPublic *) rts_unsafeGetMyCapability(); + StgTSO *tso = cap->r.rCurrentTSO; + return (tso->flags & TSO_STOP_AFTER_RETURN) != 0; +} ===================================== testsuite/tests/rts/all.T ===================================== @@ -623,6 +623,13 @@ test('T20201b', [js_skip, exit_code(1)], compile_and_run, ['-with-rtsopts -A64z' test('T22012', [js_skip, extra_ways(['ghci'])], compile_and_run, ['T22012_c.c']) +test('T27131', + [ only_ways(['threaded1', 'threaded2']) + , req_ghc_with_threaded_rts + , req_target_smp + ], + compile_and_run, ['T27131_c.c']) + # Skip for JS platform as the JS RTS is always single threaded test('T22795a', [only_ways(['normal']), js_skip, req_ghc_with_threaded_rts], compile_and_run, ['-threaded']) test('T22795b', [only_ways(['normal']), js_skip], compile_and_run, ['-single-threaded']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a86b837ebaeed7a093e37137c8d2ad6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a86b837ebaeed7a093e37137c8d2ad6... You're receiving this email because of your account on gitlab.haskell.org.