+    /* start the timer (after initTimer above) */

+    unpauseTimer();

+    /* 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();

+            unpauseTimer();

+            pauseTimer();

+        // The timer thread is not present in the child process, so we need

+        // to initialise the timer again.

+        unpauseTimer();

+/* 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);

+  handleProfTick(); // Bad or worse: see issue #27250.

+

+  if (RtsFlags.ConcFlags.ctxtSwitchTicks > 0)

+          flushEventLog(NULL);  // Bad or worse: see issue #27250.

+              // The scheduler will call pauseTimer() when it has done

+                  pauseTimer();

+              pauseTimer();

+void initTimer(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 (RtsFlags.MiscFlags.tickInterval != 0) {

+        pauseTicker();

+void unpauseTimer(void)

+    if (RtsFlags.MiscFlags.tickInterval != 0) {

+        unpauseTicker();

+void exitTimer (void)

+        exitTicker();

+#include "BeginPrivate.h"

+

+void initTimer(void);

+void exitTimer(void);

+

+void pauseTimer(void);

+void unpauseTimer(void);

+

+#include "EndPrivate.h"

+void startTimer (void);    // Deprecated: see issue #27073

+void stopTimer (void);     // Deprecated: see issue #27073

+// 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;

+// 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;

+// Atomic variable used by other threads to communicate that they want the

+// ticker thread to exit.

+static bool exit_request;

+// Used to wait for the ticker thread to terminate after asking it to exit.

+static OSThreadId ticker_thread_id;

+// 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)

+    // 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.

+    timeout timeout;

+    fdset fdset;

+    poll_init_timeout(&timeout, ticker_interval);

+    poll_init_fdset(&fdset, notifyfd_r);

+    while (!exit) {

+        int notify;

+        if (paused) {

+            notify = poll_no_timeout(&fdset);

+            notify = poll_with_timeout(&fdset, &timeout);

+        if (RTS_LIKELY(notify == 0)) {

+            // The time expired, no state change notification.

+

+        } 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));

+/* 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.

+ */

+    ticker_interval     = interval;

+    pause_request       = true;

+    exit_request        = false;

+

+     * We used to do it in ticker_thread_func (i.e. in the timer thread) but it

+    if (notifyfd_r != -1) {

+        closeFdWakeup(notifyfd_r, notifyfd_w);

+    newFdWakeup(&notifyfd_r, &notifyfd_w);

+    ret = createAttachedOSThread(&ticker_thread_id, "ghc_ticker", ticker_thread_func, (void*)handle_tick);

+/* Asynchronous. Idempotent. */

+void unpauseTicker(void)

+    RELEASE_STORE_ALWAYS(&pause_request, false);

+    sendFdWakeup(notifyfd_w);

+/* Asynchronous. Idempotent.

+ * There may be at additional ticks fired after a call to this, but it will

+ * usually stop quickly.

+ */

+void pauseTicker(void)

+    RELEASE_STORE_ALWAYS(&pause_request, true);

+    sendFdWakeup(notifyfd_w);

+/* Synchronous. Not idempotent.

+ * The ticker is guaranteed stopped after this.

+ */

+void exitTicker(void)

+    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 */

+

+static Mutex lock; // To protect the timer and paused var below

+static bool paused;

+

+// Forward decls

+static void startTicker(void);

+static void stopTicker(bool synchronous);

+

+    ASSERT(timer_queue == NULL);

+    OS_INIT_LOCK(&lock);

+    paused = true; // starts paused

+// Asynchronous. Idempotent.

+unpauseTicker(void)

+    OS_ACQUIRE_LOCK(&lock);

+    if (paused) {

+        startTicker();

+    paused = false;

+    OS_RELEASE_LOCK(&lock);

+// Asynchronous. Idempotent.

+pauseTicker(void)

+    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);

+exitTicker(void)

+    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;

+{-# 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)