[Git][ghc/ghc][master] 12 commits: Add a test for thread scheduler fairness

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 40412093 by Duncan Coutts at 2026-07-01T10:34:50-04:00 Add a test for thread scheduler fairness It also tests that the interval timer and context switching works. We also test that fairness is lost when the context switching interval is too coarse for the duration of the test. We add this test before doing surgery on the interval timer, so we have decent coverage. - - - - - 3f34d557 by Duncan Coutts at 2026-07-01T10:34:50-04:00 Make exported stop/startTimer no-ops, and rename internal functions Specifically, internally rename: stop/startTimer to pause/unpauseTimer stop/startTicker to pause/unpauseTicker and keep stop/startTimer as exported functions, but now as no-ops. In the past the stop/startTicker actions were used incorrectly as if they were synchronous, which they are not. See issue #27105. We now document pause/unpackTicker as being async and not to be used for the purpose of concurrency safety. The existing stop/startTimer (note Timer not Ticker, the Timer calls the Ticker!) are also exported from the RTS as a public API. This was historically because the ticker used signals and it was important to suspend the timer signel over a process fork. So these functions were exported to be used by the process and unix libraries. We cannot just remove the RTS exports, but we now make them no-ops, and they can be removed from the process and unix library later. This was already documented in a changelog.d entry no-more-timer-signal but due to changes during the MR process the change to make stop/startTicker into no-ops didn't make it into the earlier MR. - - - - - 02e84e5f by Duncan Coutts at 2026-07-01T10:34:51-04:00 Make exitTicker/exitTimer unconditionally synchronous We never use them asynchronously, and we should never need to do so. And update some related comments. - - - - - 13db6a72 by Duncan Coutts at 2026-07-01T10:34:51-04:00 posix ticker: update and improve comments on (un)pause and exit Clarify what is async vs sync. - - - - - 43d9a07d by Duncan Coutts at 2026-07-01T10:34:51-04:00 posix ticker: split out ppoll/select helper functions Move the #ifdefs out of the main code body by introducing local helper functions and types, which themselves have two implementations (with a common API) based on ppoll or select. This helps improve clarity/readability. - - - - - a5491baa by Duncan Coutts at 2026-07-01T10:34:51-04:00 posix ticker: improve the implementation The existing implementation supported pausing and exiting, with the implementation of pausing reling on a mutex and condition variable. It needed to check the pause and stop shared variables on every iteration. It relies on ppoll or select, to wait on the timeout and also wait on an interrupt fd. The interrupt fd was only used for prompt exit/shutdown, and not for pausing or other notification. The pause only needed a lock and a memory operation, but the pause was not prompt. The resume used a lock, and signaling a cond var. The new implementation uses a somewhat more regular design: every notification is done by setting a shared variable and interrupting/notifying the ticker via the fd. The ticker thread does not need to check any shared variables on normal timer expiry, only when it recevies notification. This may be a micro-optimisation, but the tick occurs 100 times a second by default so any improvements in the hot path are amplified. When the ticker thread does receive notification it can check the various shared variables and update its local state. The blocking relies on using ppoll/select but without a timeout. This avoids the condition var and also allows further notifications when paused (also used for unpausing). This design can be extended with further notification types if needed by using and checking further shared vars (or making existing shared vars an enum or counter). This may be used in future for additional notifications to the ticker thread. This will likely be used to proxy wakeUpRts from a single handler context for example. And this approach, avoiding mutexes, is compatible with use from signal handlers. So overall, it's: * slightly simpler / more regular; * easier to extend with additional notifications; * probably slightly more efficient (but a micro-optimisation); * and supports calling notification from signal handlers - - - - - 5b20821e by Duncan Coutts at 2026-07-01T10:34:51-04:00 posix ticker: further minor local renaming for code clarity Improve the clarity with better choice of names for several local vars and function. - - - - - 1f3ec5e0 by Duncan Coutts at 2026-07-01T10:34:51-04:00 win32 ticker: split out local helper functions - - - - - 596e7307 by Duncan Coutts at 2026-07-01T10:34:51-04:00 win32 ticker: provide guarantee about concurrency and idempotency Use a lock to ensure pause/unpause can be used concurrently. Use a paused variable, protected by the lock, to ensure that pause and unpause are both idempotent. This is what the portable API expects. - - - - - 1870edd7 by Duncan Coutts at 2026-07-01T10:34:51-04:00 win32 ticker: make the initial tick be after one wait interval There is no need to tick immediately. This is consistent with the posix implementation. - - - - - 7c15ab5b by Duncan Coutts at 2026-07-01T10:34:51-04:00 ticker: remove now-unnecessary layer of enable/disable There was an atomic variable used to block *part* of the actions of the tick handler. This still did not make stopTimer synchronous, even for the part of the the handle_tick actions it covered. It also added a more expensive (sequentuially consistent) atomic operation in the hot path for the handle_tick action, whereas our new design requires no atomic ops at all. Now that we have eliminate the need for synchronous stop/startTicker, we don't need this not-quite-working-anyway atomic protocol. The new pause/unpauseTicker is explicitly asynchronous and idempotent. - - - - - 8585f8cb by Duncan Coutts at 2026-07-01T10:34:51-04:00 ticker: add TODOs about issue #27250: too much being done from handle_tick The handle_tick should not perform I/O, block, perform long-running operations or call arbitrary user code. Unfortunately, everything to do with the eventlog (at the moment) falls into all those categories. - - - - - 10 changed files: - rts/RtsStartup.c - rts/Schedule.c - rts/Ticker.h - rts/Timer.c - rts/Timer.h - rts/include/rts/Timer.h - rts/posix/Ticker.c - rts/win32/Ticker.c - + testsuite/tests/concurrent/should_run/T27105.hs - testsuite/tests/concurrent/should_run/all.T Changes: ===================================== rts/RtsStartup.c ===================================== @@ -415,8 +415,8 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) traceInitEvent(dumpIPEToEventLog); initHeapProfiling(); - /* start the virtual timer 'subsystem'. */ - startTimer(); + /* start the timer (after initTimer above) */ + unpauseTimer(); #if defined(RTS_USER_SIGNALS) if (RtsFlags.MiscFlags.install_signal_handlers) { @@ -512,14 +512,12 @@ hs_exit_(bool wait_foreign) } #endif - /* stop the ticker */ - stopTimer(); - /* - * it is quite important that we wait here as some timer implementations - * (e.g. pthread) may fire even after we exit, which may segfault as we've - * already freed the capabilities. + /* We rely on the guarantee that exitTimer stops the timer synchronously, + * which ensures the timer handler does not get run again after this point. + * We are about to start freeing resources used by the timer handler (like + * the capabilities, eventlog and profiling data structures). */ - exitTimer(true); + exitTimer(); /* * Dump the ticky counter definitions ===================================== rts/Schedule.c ===================================== @@ -455,7 +455,7 @@ run_thread: prev = setRecentActivity(ACTIVITY_YES); if (prev == ACTIVITY_DONE_GC) { #if !defined(PROFILING) - startTimer(); + unpauseTimer(); #endif } break; @@ -1936,7 +1936,7 @@ delete_threads_and_gc: // it will get re-enabled if we run any threads after the GC. setRecentActivity(ACTIVITY_DONE_GC); #if !defined(PROFILING) - stopTimer(); + pauseTimer(); #endif break; } @@ -2232,8 +2232,8 @@ forkProcess(HsStablePtr *entry generations[g].threads = END_TSO_QUEUE; } - // On Unix, all timers are reset in the child, so we need to start - // the timer again. + // The timer thread is not present in the child process, so we need + // to initialise the timer again. initTimer(); // TODO: need to trace various other things in the child @@ -2244,7 +2244,7 @@ forkProcess(HsStablePtr *entry // start timer after the IOManager is initialized // (the idle GC may wake up the IOManager) - startTimer(); + unpauseTimer(); // Install toplevel exception handlers, so interruption // signal will be sent to the main thread. ===================================== rts/Ticker.h ===================================== @@ -12,9 +12,44 @@ typedef void (*TickProc)(int); -void initTicker (Time interval, TickProc handle_tick); -void startTicker (void); -void stopTicker (void); -void exitTicker (bool wait); +/* The ticker is initialised in a paused state. Use unpauseTicker to start. */ +void initTicker(Time interval, TickProc handle_tick); + +/* Stop and terminate the ticker. It does not need to be stopped first. + * The exitTicker action is *synchronous*. When it returns the caller is + * guaranteed that the tick action is blocked. + */ +void exitTicker(void); + +/* Pause and unpause (resume) the ticker. + * + * The pauseTicker and unpauseTicker actions are *asynchronous*. After calling + * pauseTicker, the ticker will pause eventually, but there may be another tick + * action before it does pause (and theoretically there could be several but + * in practice this is unlikely). Similarly, after calling unpauseTicker the + * ticker will start up again eventually, but there is an unspecified delay + * between the unpause and the next tick action (but in practice it is short). + * + * This should be used for the purpose of *efficiency*: to avoid unnecessary + * OS thread wakeups caused by the ticker. + * + * These should *not* be used for the purpose of *concurrency safety*: to + * prevent the tick action from running concurrently with some other critical + * section. The synchronous case is not provided because it is not currently + * needed (and proper locking is often a better solution anyway). + * + * The pairing of unpauseTicker and the handle_tick action form a + * synchonises-with relation: values written before unpauseTicker can be + * read from the resulting handle_tick action. + * + * It *is* safe to call these functions from within the tick handler itself. + * + * It is safe to use these functions concurrently from multiple threads, but + * note that they *are* idempotent. This means it is not appropriate to use + * paired pause/unpause calls concurrently. They can be used by threads based + * on consistent use of some shared state or observation. + */ +void pauseTicker(void); +void unpauseTicker(void); #include "EndPrivate.h" ===================================== rts/Timer.c ===================================== @@ -28,15 +28,6 @@ #include "RtsSignals.h" #include "rts/EventLogWriter.h" -// This global counter is used to allow multiple threads to stop the -// timer temporarily with a stopTimer()/startTimer() pair. If -// timer_enabled == 0 timer is enabled -// timer_disabled == N, N > 0 timer is disabled by N threads -// When timer_enabled makes a transition to 0, we enable the timer, -// and when it makes a transition to non-0 we disable it. - -static StgWord timer_disabled; - /* ticks left before next pre-emptive context switch */ static int ticks_to_ctxt_switch = 0; @@ -107,9 +98,9 @@ static void handle_tick(int unused STG_UNUSED) { - handleProfTick(); - if (RtsFlags.ConcFlags.ctxtSwitchTicks > 0 - && SEQ_CST_LOAD_ALWAYS(&timer_disabled) == 0) + handleProfTick(); // Bad or worse: see issue #27250. + + if (RtsFlags.ConcFlags.ctxtSwitchTicks > 0) { ticks_to_ctxt_switch--; if (ticks_to_ctxt_switch <= 0) { @@ -123,7 +114,7 @@ handle_tick(int unused STG_UNUSED) ticks_to_eventlog_flush--; if (ticks_to_eventlog_flush <= 0) { ticks_to_eventlog_flush = RtsFlags.TraceFlags.eventlogFlushTicks; - flushEventLog(NULL); + flushEventLog(NULL); // Bad or worse: see issue #27250. } } #endif @@ -148,7 +139,7 @@ handle_tick(int unused STG_UNUSED) RtsFlags.MiscFlags.tickInterval; #if defined(THREADED_RTS) wakeUpRts(); - // The scheduler will call stopTimer() when it has done + // The scheduler will call pauseTimer() when it has done // the GC. #endif } else { @@ -160,10 +151,10 @@ handle_tick(int unused STG_UNUSED) #if defined(PROFILING) if (!(RtsFlags.ProfFlags.doHeapProfile || RtsFlags.CcFlags.doCostCentres)) { - stopTimer(); + pauseTimer(); } #else - stopTimer(); + pauseTimer(); #endif } } else { @@ -176,48 +167,49 @@ handle_tick(int unused STG_UNUSED) } } -void -initTimer(void) +void initTimer(void) { #if defined(HAVE_PREEMPTION) initProfTimer(); if (RtsFlags.MiscFlags.tickInterval != 0) { initTicker(RtsFlags.MiscFlags.tickInterval, handle_tick); } - SEQ_CST_STORE_ALWAYS(&timer_disabled, 1); #endif } -void -startTimer(void) +/* Deprecated exported functions. Now no-ops. + * Historically they were used by the process and unix libraries to disable + * the signal-based interval timer, since otherwise the timer signal would + * keep going off in the child process and confusing everything. The interval + * timer no longer uses signals, so there is no need any more for libraries to + * disable the timer. Also, the timer internal API has changed. + */ +void stopTimer(void) { /* no-op */ } +void startTimer(void) { /* no-op */ } + +void pauseTimer(void) { #if defined(HAVE_PREEMPTION) - if (SEQ_CST_SUB_ALWAYS(&timer_disabled, 1) == 0) { - if (RtsFlags.MiscFlags.tickInterval != 0) { - startTicker(); - } + if (RtsFlags.MiscFlags.tickInterval != 0) { + pauseTicker(); } #endif } -void -stopTimer(void) +void unpauseTimer(void) { #if defined(HAVE_PREEMPTION) - if (SEQ_CST_ADD_ALWAYS(&timer_disabled, 1) == 1) { - if (RtsFlags.MiscFlags.tickInterval != 0) { - stopTicker(); - } + if (RtsFlags.MiscFlags.tickInterval != 0) { + unpauseTicker(); } #endif } -void -exitTimer (bool wait) +void exitTimer (void) { #if defined(HAVE_PREEMPTION) if (RtsFlags.MiscFlags.tickInterval != 0) { - exitTicker(wait); + exitTicker(); } #endif } ===================================== rts/Timer.h ===================================== @@ -8,5 +8,12 @@ #pragma once -RTS_PRIVATE void initTimer (void); -RTS_PRIVATE void exitTimer (bool wait); +#include "BeginPrivate.h" + +void initTimer(void); +void exitTimer(void); + +void pauseTimer(void); +void unpauseTimer(void); + +#include "EndPrivate.h" ===================================== rts/include/rts/Timer.h ===================================== @@ -13,6 +13,6 @@ #pragma once -void startTimer (void); -void stopTimer (void); +void startTimer (void); // Deprecated: see issue #27073 +void stopTimer (void); // Deprecated: see issue #27073 int rtsTimerSignal (void); // Deprecated: see issue #27073 ===================================== rts/posix/Ticker.c ===================================== @@ -103,120 +103,112 @@ #include #include -static Time itimer_interval = DEFAULT_TICK_INTERVAL; -// Should we be firing ticks? -// Writers to this must hold the mutex below. -static bool stopped = false; +// Forward declarations of local types and helper functions to hide the +// difference between ppoll() and select() +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 +typedef struct timespec timeout; // for ppoll() +typedef struct { struct pollfd pollfds[1]; } fdset; +#else +typedef struct timeval timeout; // for select() +typedef struct { int fd; fd_set selectfds; } fdset; // need to stash fd +#endif +static void poll_init_timeout(timeout *tv, Time t); +static void poll_init_fdset(fdset *fds, int fd); // single fd only +// poll_*_timeout returns >0 if fd ready, ==0 if timeout, <0 if error +static int poll_no_timeout(fdset *fdset); +static int poll_with_timeout(fdset *fdset, timeout *t); + + +static Time ticker_interval = DEFAULT_TICK_INTERVAL; -// should the ticker thread exit? -// This can be set without holding the mutex. -static bool exited = true; +// Atomic variable used by client threads to communicate that they want the +// ticker thread to pause. This communication is one-way, with no +// acknowledgement. +static bool pause_request; -// Signaled when we want to (re)start the timer -static Condition start_cond; -static Mutex mutex; -static OSThreadId thread; +// Atomic variable used by other threads to communicate that they want the +// ticker thread to exit. +static bool exit_request; -// fds for interrupting the ticker -static int interruptfd_r = -1, interruptfd_w = -1; +// Used to wait for the ticker thread to terminate after asking it to exit. +static OSThreadId ticker_thread_id; -static void *itimer_thread_func(void *_handle_tick) +// Fds used with sendFdWakeup to notify the ticker thread that any of the +// *_request variables above have been set. +static int notifyfd_r = -1, notifyfd_w = -1; + +static void *ticker_thread_func(void *_handle_tick) { TickProc handle_tick = _handle_tick; -#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 - struct pollfd pollfds[1]; + // Thread-local view of our state. We compare these with the corresponding + // atomic shared variables used to request state changes. + bool paused = true; // updated from atomic shared var pause_request + bool exit = false; // updated from atomic shared var exit_request + // Note that we start paused. - pollfds[0].fd = interruptfd_r; - pollfds[0].events = POLLIN; + timeout timeout; + fdset fdset; + poll_init_timeout(&timeout, ticker_interval); + poll_init_fdset(&fdset, notifyfd_r); - struct timespec ts = { .tv_sec = TimeToSeconds(itimer_interval) - , .tv_nsec = TimeToNS(itimer_interval) % 1000000000 - }; -#else - fd_set selectfds; - FD_ZERO(&selectfds); - FD_SET(interruptfd_r, &selectfds); - - struct timeval tv = { .tv_sec = TimeToSeconds(itimer_interval) - /* convert remainder time in nanoseconds - to microseconds, rounding up: */ - , .tv_usec = ((TimeToNS(itimer_interval) % 1000000000) - + 999) / 1000 - }; -#endif + while (!exit) { - // Relaxed is sufficient: If we don't see that exited was set in one iteration we will - // see it next time. - while (!RELAXED_LOAD_ALWAYS(&exited)) { - -#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 - int nfds = 1; - int nready = ppoll(pollfds, nfds, &ts, NULL); -#else - struct timeval tv_tmp = tv; // copy since select may change this value. - int nfds = interruptfd_r+1; - int nready = select(nfds, &selectfds, NULL, NULL, &tv_tmp); -#endif - // In either case (ppoll or select), the result nready is the number - // of fds that are ready. - if (RTS_LIKELY(nready == 0)) { - // Timer expired, not interrupted, continue. - } else if (nready > 0) { - // We only monitor one fd (the interruptfd_r), so we know - // it is that fd that is ready without any further checks. - collectFdWakeup(interruptfd_r); - // No further action needed, continue on to handling the final tick - // and then stop. - - // Note that we rely on sendFdWakeup and select/poll to provide the - // happens-before relation. So if 'exited' was set before calling - // sendFdWakeup, then we should be able to reliably read it after. - // And thus reading 'exited' in the while loop guard is ok. + int notify; + if (paused) { + notify = poll_no_timeout(&fdset); } else { - // While the RTS attempts to mask signals, some foreign libraries - // that rely on signal delivery may unmask them. Consequently we - // may see EINTR. See #24610. - if (errno != EINTR) { - sysErrorBelch("Ticker: poll failed: %s", strerror(errno)); - } + notify = poll_with_timeout(&fdset, &timeout); } - // first try a cheap test - if (RELAXED_LOAD_ALWAYS(&stopped)) { - OS_ACQUIRE_LOCK(&mutex); - // should we really stop? - if (stopped) { - waitCondition(&start_cond, &mutex); - } - OS_RELEASE_LOCK(&mutex); - } else { + if (RTS_LIKELY(notify == 0)) { + // The time expired, no state change notification. handle_tick(0); + + } else if (notify > 0) { + // State change notification, check the request variables. + + // We rely on sendFdWakeup and select/poll to provide the + // happens-before relation. So if the request variables are set + // before calling sendFdWakeup, then we should be able to reliably + // read them here afterwards. + collectFdWakeup(notifyfd_r); + + paused = ACQUIRE_LOAD_ALWAYS(&pause_request); + exit = RELAXED_LOAD_ALWAYS(&exit_request); + } else if (errno != EINTR) { + // While the RTS attempts to mask signals, some foreign libraries + // that rely on signal delivery may unmask them. Consequently we + // may see EINTR. See #24610. + sysErrorBelch("Ticker: poll failed: %s", strerror(errno)); } } return NULL; } +/* Initialise the ticker on startup or re-initialise the ticker after a fork(). + * In the fork case, the thread will not be present, but fds are inherited. + * + * The ticker is started in the paused state. Use unpauseTicker to continue. + */ void initTicker (Time interval, TickProc handle_tick) { - itimer_interval = interval; - stopped = true; - exited = false; + ticker_interval = interval; + pause_request = true; + exit_request = false; + #if defined(HAVE_SIGNAL_H) sigset_t mask, omask; int sigret; #endif int ret; - initCondition(&start_cond); - initMutex(&mutex); - /* Open the interrupt fd synchronously. * - * We used to do it in itimer_thread_func (i.e. in the timer thread) but it + * We used to do it in ticker_thread_func (i.e. in the timer thread) but it * meant that some user code could run before it and get confused by the * allocation of the timerfd. * @@ -226,11 +218,11 @@ initTicker (Time interval, TickProc handle_tick) * descriptor closed by the first call! (see #20618) */ - if (interruptfd_r != -1) { + if (notifyfd_r != -1) { // don't leak the old file descriptors after a fork (#25280) - closeFdWakeup(interruptfd_r, interruptfd_w); + closeFdWakeup(notifyfd_r, notifyfd_w); } - newFdWakeup(&interruptfd_r, &interruptfd_w); + newFdWakeup(¬ifyfd_r, ¬ifyfd_w); /* * Create the thread with all blockable signals blocked, leaving signal @@ -242,7 +234,7 @@ initTicker (Time interval, TickProc handle_tick) sigfillset(&mask); sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); #endif - ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick); + ret = createAttachedOSThread(&ticker_thread_id, "ghc_ticker", ticker_thread_func, (void*)handle_tick); #if defined(HAVE_SIGNAL_H) if (sigret == 0) pthread_sigmask(SIG_SETMASK, &omask, NULL); @@ -253,47 +245,112 @@ initTicker (Time interval, TickProc handle_tick) } } -void -startTicker(void) +/* Asynchronous. Idempotent. */ +void unpauseTicker(void) { - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, false); - signalCondition(&start_cond); - OS_RELEASE_LOCK(&mutex); + RELEASE_STORE_ALWAYS(&pause_request, false); + sendFdWakeup(notifyfd_w); } -/* There may be at most one additional tick fired after a call to this */ -void -stopTicker(void) +/* Asynchronous. Idempotent. + * There may be at additional ticks fired after a call to this, but it will + * usually stop quickly. + */ +void pauseTicker(void) { - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, true); - OS_RELEASE_LOCK(&mutex); + RELEASE_STORE_ALWAYS(&pause_request, true); + sendFdWakeup(notifyfd_w); } -/* There may be at most one additional tick fired after a call to this */ -void -exitTicker (bool wait) +/* Synchronous. Not idempotent. + * The ticker is guaranteed stopped after this. + */ +void exitTicker(void) { - ASSERT(!SEQ_CST_LOAD(&exited)); - SEQ_CST_STORE(&exited, true); - // ensure that ticker wakes up if stopped - startTicker(); - sendFdWakeup(interruptfd_w); - - // wait for ticker to terminate if necessary - if (wait) { - if (pthread_join(thread, NULL)) { - sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); - } - closeFdWakeup(interruptfd_r, interruptfd_w); - closeMutex(&mutex); - closeCondition(&start_cond); - } else { - pthread_detach(thread); + ASSERT(!RELAXED_LOAD_ALWAYS(&exit_request)); + RELEASE_STORE_ALWAYS(&exit_request, true); + sendFdWakeup(notifyfd_w); + + // wait for ticker thread to terminate + if (pthread_join(ticker_thread_id, NULL)) { + sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); } + closeFdWakeup(notifyfd_r, notifyfd_w); +} + +/* Implementation of the local helpers, to hide the difference between ppoll() + * and select(). + */ +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 +static void poll_init_timeout(timeout *tv, Time t) +{ + tv->tv_sec = TimeToSeconds(t); + tv->tv_nsec = TimeToNS(t) % 1000000000; +} + +static void poll_init_fdset(fdset *fds, int fd) +{ + fds->pollfds[0].fd = fd; + fds->pollfds[0].events = POLLIN; +} + +static int poll_no_timeout(fdset *fds) +{ + int nfds = 1; + return ppoll(fds->pollfds, nfds, NULL, NULL); +} + +static int poll_with_timeout(fdset *fds, timeout *ts) +{ + int nfds = 1; + return ppoll(fds->pollfds, nfds, ts, NULL); +} + +#else // select() + +static void poll_init_timeout(timeout *tv, Time t) +{ + tv->tv_sec = TimeToSeconds(t); + /* convert remainder time in nanoseconds to microseconds, rounding up: */ + tv->tv_usec = ((TimeToNS(t) % 1000000000) + 999) / 1000; +} + +static void poll_init_fdset(fdset *fds, int fd) +{ + /* select() modifies the fd_set: it uses the same fd_set for reporting as + * for input. Thus we must rebuild it every time. We can optimise this + * rebuilding somewhat however if we rely on select() not modifying the + * bits that we didn't ask it to look at. So we can zero the fd_set just + * once, and then only reset the single bit for the single fd, before each + * call to selct(). + */ + fds->fd = fd; + FD_ZERO(&fds->selectfds); +} + +static int poll_no_timeout(fdset *fds) +{ + /* select() modifies the fd_set so we must set it every time, but we rely + * on it not touching other bits to avoid having to FD_ZERO it every time + */ + FD_SET(fds->fd, &fds->selectfds); + int nfds = fds->fd+1; + return select(nfds, &fds->selectfds, NULL, NULL, NULL); +} + +static int poll_with_timeout(fdset *fds, timeout *tv) +{ + struct timeval tv_tmp = *tv; // copy since select may change this value. + /* select() modifies the fd_set so we must set it every time, but we rely + * on it not touching other bits to avoid having to FD_ZERO it every time + */ + FD_SET(fds->fd, &fds->selectfds); + int nfds = fds->fd+1; + return select(nfds, &fds->selectfds, NULL, NULL, &tv_tmp); } +#endif +/* This is obsolete, but is used in the unix package for now */ int rtsTimerSignal(void) { ===================================== rts/win32/Ticker.c ===================================== @@ -11,7 +11,11 @@ static TickProc tick_proc = NULL; static HANDLE timer_queue = NULL; + +static Mutex lock; // To protect the timer and paused var below static HANDLE timer = NULL; +static bool paused; + static Time tick_interval = 0; static VOID CALLBACK tick_callback( @@ -36,12 +40,19 @@ static VOID CALLBACK tick_callback( // This seems to be the case starting at some point during the // Windows 7 lifetime and any newer versions of windows. +// Forward decls +static void startTicker(void); +static void stopTicker(bool synchronous); + void initTicker (Time interval, TickProc handle_tick) { + ASSERT(timer_queue == NULL); tick_interval = interval; tick_proc = handle_tick; + OS_INIT_LOCK(&lock); + paused = true; // starts paused timer_queue = CreateTimerQueue(); if (timer_queue == NULL) { sysErrorBelch("CreateTimerQueue"); @@ -49,39 +60,81 @@ initTicker (Time interval, TickProc handle_tick) } } +// Asynchronous. Idempotent. void -startTicker(void) +unpauseTicker(void) { - BOOL r; - - r = CreateTimerQueueTimer(&timer, - timer_queue, - tick_callback, - 0, - 0, - TimeToMS(tick_interval), // ms - WT_EXECUTEINTIMERTHREAD); - if (r == 0) { - sysErrorBelch("CreateTimerQueueTimer"); - stg_exit(EXIT_FAILURE); + OS_ACQUIRE_LOCK(&lock); + if (paused) { + startTicker(); } + paused = false; + OS_RELEASE_LOCK(&lock); } +// Asynchronous. Idempotent. void -stopTicker(void) +pauseTicker(void) { - if (timer_queue != NULL && timer != NULL) { - DeleteTimerQueueTimer(timer_queue, timer, NULL); - timer = NULL; + OS_ACQUIRE_LOCK(&lock); + if (!paused) { + /* pauseTicker is called from within the handle_tick, so stopping + * the ticker here /must/ be asynchronous or we will deadlock! */ + stopTicker(false /* asynchronous */); } + paused = true; + OS_RELEASE_LOCK(&lock); } void -exitTicker (bool wait) +exitTicker(void) { - stopTicker(); - if (timer_queue != NULL) { - DeleteTimerQueueEx(timer_queue, wait ? INVALID_HANDLE_VALUE : NULL); - timer_queue = NULL; + ASSERT(timer_queue != NULL); + + OS_ACQUIRE_LOCK(&lock); + if (!paused) { + stopTicker(true /* synchronous */); + } + OS_RELEASE_LOCK(&lock); + + // From the docs for DeleteTimerQueueEx: + // If this parameter is INVALID_HANDLE_VALUE, the function waits + // for all callback functions to complete before returning. + // This is a belt-and-braces approach to ensuring exitTicker is synchronous, + // since stopTicker(true) is already synchronous and there's only one timer. + HANDLE completion = INVALID_HANDLE_VALUE; + DeleteTimerQueueEx(timer_queue, completion); + timer_queue = NULL; +} + +static void startTicker(void) { + ASSERT(timer_queue != NULL && timer == NULL); + DWORD interval = TimeToMS(tick_interval); // ms + BOOL r = CreateTimerQueueTimer(&timer, + timer_queue, + tick_callback, + NULL, // callback param + interval, // inital interval + interval, // recurrant interval + WT_EXECUTEINTIMERTHREAD); + //TODO: using WT_EXECUTEINTIMERTHREAD is fine for context switching, and + // plausibly also ok for profile sampling but is way out for eventlog + // flushing. The eventlog flush does a global synchronisation of all + // capabilities and I/O! And with eventlog providers, it calls arbitrary + // user code. This is not ok! See issue #27250. + if (r == 0) { + sysErrorBelch("CreateTimerQueueTimer"); + stg_exit(EXIT_FAILURE); } + ASSERT(timer != NULL); +} + +static void stopTicker(bool synchronous) { + ASSERT(timer_queue != NULL && timer != NULL); + // From the docs for DeleteTimerQueueTimer: + // If this parameter is INVALID_HANDLE_VALUE, the function waits for any + // running timer callback functions to complete before returning. + HANDLE completion = synchronous ? INVALID_HANDLE_VALUE : NULL; + DeleteTimerQueueTimer(timer_queue, timer, completion); + timer = NULL; } ===================================== testsuite/tests/concurrent/should_run/T27105.hs ===================================== @@ -0,0 +1,114 @@ +{-# OPTIONS_GHC -fno-omit-yields #-} + +import Control.Monad +import Control.Monad.ST +import Control.Concurrent +import Control.Exception +import System.Exit +import System.Mem +import GHC.Arr +import Prelude hiding (init) + +-- Test thread fairness: +-- run two cpu-bound threads concurrently for a second, +-- each counts how many operations it can perform until signaled to stop +-- expect a balance between the two with no more than a 75% imperfection. +-- Yes, 75%! On the CI machines we occasionally observe extraordinary levels +-- of unfairness: nearly 60% in some cases. We don't want this to become a +-- fragile test that is ignored, so we use an extreme bound. This should still +-- catch gross breakage. +-- +-- This _should_ detect if the interval timer is not working, or if thread +-- context switching is messed up. We can expect failure if we force a +-- contex switch interval of more than half the test time, i.e. more than 0.5s +-- +-- We run the test twice, with allocating and non-allocating worker threads. +-- The -fno-omit-yields above is crucial for worker_nonalloc below, or it never +-- gets interrupted and thus no context switches. + +main :: IO () +main = do + test worker_alloc + performMajorGC + test worker_nonalloc + +test :: Worker -> IO () +test worker = do + stop <- newEmptyMVar + res1 <- newEmptyMVar + res2 <- newEmptyMVar + _ <- forkIO (worker stop >>= putMVar res1) + _ <- forkIO (worker stop >>= putMVar res2) + threadDelay 300_000 + -- Let them run for 300ms. The default context switch interval is 20ms. + -- This gives time for 15 context switches, so this _should_ be enough + -- to get less than 10% unfairness. And on most platforms it is enough. + -- But OSX! Oh OSX! How do I loath thee? Let me count++ the ways. + -- To avoid a fragile test, we use a 75% unfairness threshold. + putMVar stop () + count1 <- takeMVar res1 + count2 <- takeMVar res2 + let balance :: Double + balance = abs ((fromIntegral count1 - fromIntegral count2) + / fromIntegral count2) + when (balance > 0.75) $ do + putStrLn "Schedule fairness more than 75% tolerance:" + putStrLn $ "imperfection: " ++ show (balance * 100) ++ "%" + putStrLn $ "work counts: " ++ show (count1, count2) + exitFailure + +type Worker = MVar () -> IO Int + +-- count how many iterations we can calculate until we're signaled to stop +worker_template :: IO a -> (a -> IO ()) -> MVar () -> IO Int +worker_template init iter stop = do + a <- init + go a 0 + where + go a !count = do + ok <- tryReadMVar stop + case ok of + Just () -> return count + Nothing -> do + iter a + go a (count + 1) + + +-- the allocating worker +{-# NOINLINE worker_alloc #-} +worker_alloc :: Worker +worker_alloc = + worker_template + (return 18) + (\n -> evaluate (fib n) >> return ()) + +-- by forcing this to be Integer we cause lots of allocation! +fib :: Integer -> Integer +fib 0 = 0 +fib 1 = 1 +fib n = fib (n-1) + fib (n-2) + + +-- the non-allocating worker +{-# NOINLINE worker_nonalloc #-} +worker_nonalloc :: Worker +worker_nonalloc = + worker_template + (stToIO $ newSTArray (0,50_000) 42) + (\arr -> stToIO $ arrrev arr) + +arrrev :: STArray s Int Int -> ST s () +arrrev arr = + let (i,j) = boundsSTArray arr + in arrrev_go arr i j + +{-# NOINLINE arrrev_go #-} +arrrev_go :: STArray s Int Int -> Int -> Int -> ST s () +arrrev_go !_ !i !j | i >= j = return () +arrrev_go !arr !i !j = do + x <- readSTArray arr i + y <- readSTArray arr j + writeSTArray arr i y + writeSTArray arr j x + arrrev_go arr (i+1) (j-1) + ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -325,3 +325,15 @@ test('T26341b' # test uses pipe operations which are not supported by the JS/wasm backends , when(arch('wasm32') or arch('javascript'), skip) , compile_and_run, ['-package process']) + +# Scheduler (very rough) fairness +test('T27105', + [when(arch('wasm32'), skip), # same reason as T367_letnoescape + run_timeout_multiplier(0.05)], # we expect this to run for ~2s + compile_and_run, ['']) +test('T27105_fail', + [when(arch('wasm32'), skip), + # And we can expect it to fail if we context switch too coarsely + extra_run_opts('+RTS -C0.2 -RTS'), expect_fail, + run_timeout_multiplier(0.05)], + multimod_compile_and_run, ['T27105.hs', '']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a8a24f4386e7838403212cb87b32d1... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a8a24f4386e7838403212cb87b32d1... You're receiving this email because of your account on gitlab.haskell.org.