[Git][ghc/ghc][wip/davide/ghc-toolchain-throw-less] ghc-toolchain: don't throw when candidate executables are not found
by David Eichmann (＠DavidEichmann) 11 Jun '26
by David Eichmann (＠DavidEichmann) 11 Jun '26
11 Jun '26
David Eichmann pushed to branch wip/davide/ghc-toolchain-throw-less at Glasgow Haskell Compiler / GHC
Commits:
9e4fc6a5 by David Eichmann at 2026-06-11T15:37:32+01:00
ghc-toolchain: don't throw when candidate executables are not found
Fixes #27369
- - - - -
2 changed files:
- utils/ghc-toolchain/src/GHC/Toolchain/Program.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
Changes:
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Program.hs
=====================================
@@ -148,12 +148,14 @@ findProgram description userSpec candidates
Just prefix -> map (prefix++) candidates
Nothing -> []
candidates' = prefixedCandidates ++ candidates
- err =
- [ "Failed to find " ++ description ++ "."
- , "Looked for one of " ++ show candidates' ++ " in the system search path."
- ]
- path <- oneOf' err (map findExecutableErr candidates')
- return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) }
+ pathMay <- findM doesExecutableExist candidates'
+ case pathMay of
+ Nothing -> throwEs
+ [ "Failed to find " ++ description ++ "."
+ , "Looked for one of " ++ show candidates' ++ " in the system search path."
+ ]
+ Just path ->
+ return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) }
-- Note that @configure.ac@ checks these llvm version constants (using @sed@) to
-- ensure they are the same as the @$LlvmMinVersion@ and @$LlvmMaxVersion@
@@ -222,21 +224,19 @@ maybeFindProgramFromProgOpts :: String -> ProgOpt -> Maybe (M Program)
maybeFindProgramFromProgOpts description userSpec = case poPath userSpec of
Nothing -> Nothing
Just path -> Just $ do
- let err =
- [ "Failed to find " ++ description ++ "."
- , "Looked for user-specified program '" ++ path ++ "' in the system search path."
- ]
- path' <- findExecutableErr path <|> throwEs err
- return Program { prgPath = path', prgFlags = fromMaybe [] (poFlags userSpec) }
-
-findExecutableErr :: String -> M FilePath
-findExecutableErr name = do
- r <- liftIO $ findExecutable name
- case r of
- Nothing -> throwE $ name ++ " not found in search path"
- -- Use the given `prgPath` or candidate name rather than the
- -- absolute path returned by `findExecutable`.
- Just _x -> return name
+ exists <- doesExecutableExist path
+ unless exists $ throwEs
+ [ "Failed to find " ++ description ++ "."
+ , "Looked for user-specified program '" ++ path ++ "' in the system search path."
+ ]
+ return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) }
+
+-- | Returns the first condidate that exists (can )
+doesExecutableExist
+ :: String -- ^ executable name
+ -> M Bool
+doesExecutableExist name = isJust <$> liftIO (findExecutable name)
+
-------------------- Compiling utilities --------------------
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
=====================================
@@ -9,6 +9,7 @@ module GHC.Toolchain.Utils
, oneOf'
, isSuccess
, lastLine
+ , findM
) where
import Control.Exception
@@ -69,3 +70,10 @@ isSuccess = \case
lastLine :: String -> String
lastLine = maybe "" snd . unsnoc . lines
+
+findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
+findM f = \case
+ [] -> return Nothing
+ a:as -> do
+ found <- f a
+ if found then return (Just a) else findM f as
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e4fc6a5ed9a42dd6e1cd0c3cc7ebf9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e4fc6a5ed9a42dd6e1cd0c3cc7ebf9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/davide/ghc-toolchain-throw-less
by David Eichmann (＠DavidEichmann) 11 Jun '26
by David Eichmann (＠DavidEichmann) 11 Jun '26
11 Jun '26
David Eichmann pushed new branch wip/davide/ghc-toolchain-throw-less at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/davide/ghc-toolchain-throw-le…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
11 Jun '26
Magnus pushed new branch wip/mangoiv/process-1.6.30.0 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/mangoiv/process-1.6.30.0
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/dcoutts/issue-27105-stopTicker] 19 commits: Promote HAVE_PREEMPTION from Timer.c to OSThreads.h
by Duncan Coutts (＠dcoutts) 11 Jun '26
by Duncan Coutts (＠dcoutts) 11 Jun '26
11 Jun '26
Duncan Coutts pushed to branch wip/dcoutts/issue-27105-stopTicker at Glasgow Haskell Compiler / GHC
Commits:
84cee6bb by Duncan Coutts at 2026-06-08T13:07:29+02:00
Promote HAVE_PREEMPTION from Timer.c to OSThreads.h
We will want to know about HAVE_PREEMPTION in more places.
HAVE_PREEMPTION tells us that we do have OS threads available,
irrespective of whether THREADED is defined. In particular,
HAVE_PREEMPTION is defined on all proper OSs, but not on WASM (and
hyopthetically may not be true on some other platforms like
micro-controllers, RTOSs, VM hypervisors etc).
- - - - -
1e270fa6 by Duncan Coutts at 2026-06-08T13:07:31+02:00
Define ACQUIRE_LOCK_ALWAYS and friends
Fix issue #27335
Like the atomic _ALWAYS variants, these lock actions are always defined,
rather than being dependent on whether we are in the THREADED case. All
the "normal" LOCK macros are defined to be no-ops when !THREADED.
The use case for the _ALWAYS variants is where we are using OS threads
even in the non-threaded RTS. This includes everything to do with the
timer/ticker thread, which is used in the non-threaded RTS too.
In particular, we will want to use this for eventlog things, because the
timer thread performs eventlogging concurrently with the main
capability, even in the non-threaded RTS.
- - - - -
10806a8c by Duncan Coutts at 2026-06-08T13:07:31+02:00
Use ACQUIRE/RELEASE_LOCK_ALWAYS with eventBufMutex
Even in the non-threaded RTS the eventBufMutex is needed by both the
main capability and the timer/ticker thread, so always use the mutex.
This should fix #25165 which is about the main capability and the timer
thread posting events to the eventlog buffer concurrently and thereby
corrupting the buffer data.
- - - - -
a5e2d9c6 by Duncan Coutts at 2026-06-08T13:07:31+02:00
Expose eventBufMutex in the EventLog interface/header
We will need it in forkProcess to ensure we don't write to the global
eventlog buffer concurrently with trying to flush eventlog buffers and
do the fork().
- - - - -
7f881fdd by Duncan Coutts at 2026-06-08T13:07:31+02:00
Split flushAllCapsEventsBufs into safe and unlocked version
Following the convention that unlocked versions have a trailing _
underscore in their name. This one requires the caller to hold the
eventlog global buffer mutex. We will need this in forkProcess.
- - - - -
45c43c44 by Duncan Coutts at 2026-06-08T13:07:31+02:00
Remove redundant use of stopTimer in setNumCapabilities
Historically, the comment here was:
We must stop the interval timer while we are changing the
capabilities array lest handle_tick may try to context switch
an old capability. See #17289.
and
We must disable the timer while we do this since the tick handler may
call contextSwitchAllCapabilities, which may see the capabilities array
as we free it.
What this refers to is that historically, when changing the number of
capabilities, the array of capabilities was reallocated to a new size,
allocating new ones and freeing the old ones, thus invalidating all
existing capbility pointers.
Strangely, for good measure the code used to call stopTimer twice (hence
the two similar comments above).
However, since commit a3eccf06292dd666b24606251a52da2b466a9612, the
capabilities array is no longer reallocated. Instead the array is
allcoated once on RTS startup to the maximum size it could ever be
allowed to be, and then capabilities get enabled/disabled at runtime. So
the capability pointers never become invalid anymore. At worst, they may
point to capabilities that are disabled.
Thus we no longer need to stop the timer (twice) while we change the
number of enabled capabilities. This also partially solves issue #27105,
which notes that stopTimer is being used as if it were synchronous, when
it is not. At least for this case, the solution is that stopTimer is not
needed at all!
- - - - -
55c052e2 by Duncan Coutts at 2026-06-08T13:07:31+02:00
Remove redundant use of stopTimer in forkProcess
but replace it with taking the eventlog buffer lock during the fork.
Fixes issue #27105
The original reason to block the timer during a fork was that
historically the timer was implemented using a periodic timer signal,
and the signal itself would interrupt the fork system call (returning
EINTR). For large processes (where fork() takes a while) this could
permanently livelock: the timer always would go off before the fork
could complete, which got retried in a loop forever.
The timer is no longer implemented as a unix signal, but uses threads.
Thus the original problem no longer exists. The only remaining reason to
block the timer tick is to prevent actions taken by the tick from
interfering with the delicate process involved in fork (taking a load of
locks and pausing everything).
The only thing we need to do is to prevent the eventlog from being
written to or flushed while the fork is taking place. To achieve this
all we need to do is hold the mutex for the global eventlog buffer.
This removes the last use of stopTimer that expects stopTimer to work
synchronously (which it was not) and thus solves issue #27105. To be
clear, we solve issue #27105 not by making stopTimer synchronous, but by
eliminating the use sites that expected it to be synchronous.
- - - - -
3d2a4e6e by Duncan Coutts at 2026-06-10T09:59:48+01: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.
- - - - -
5b29323b by Duncan Coutts at 2026-06-10T10:59:05+01: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.
- - - - -
a847e252 by Duncan Coutts at 2026-06-10T11:02:43+01:00
Make exitTicker/exitTimer unconditionally synchronous
We never use them asynchronously, and we should never need to do so.
And update some related comments.
- - - - -
e3705818 by Duncan Coutts at 2026-06-11T00:22:04+01:00
posix ticker: update and improve comments on (un)pause and exit
Clarify what is async vs sync.
- - - - -
2de52c61 by Duncan Coutts at 2026-06-11T00:22:34+01: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.
- - - - -
499de471 by Duncan Coutts at 2026-06-11T00:22:52+01: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
- - - - -
993b9399 by Duncan Coutts at 2026-06-11T00:23:46+01:00
posix ticker: further minor local renaming for code clarity
Improve the clarity with better choice of names for several local vars
and function.
- - - - -
df53d0e3 by Duncan Coutts at 2026-06-11T10:17:21+01:00
win32 ticker: split out local helper functions
- - - - -
0f01836b by Duncan Coutts at 2026-06-11T10:19:40+01: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.
- - - - -
e0c747e9 by Duncan Coutts at 2026-06-11T10:22:52+01: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.
- - - - -
c6a0ceb6 by Duncan Coutts at 2026-06-11T10:22:52+01: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.
- - - - -
50dd42da by Duncan Coutts at 2026-06-11T10:22:52+01: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.
- - - - -
14 changed files:
- rts/Capability.c
- rts/RtsStartup.c
- rts/Schedule.c
- rts/Ticker.h
- rts/Timer.c
- rts/Timer.h
- rts/eventlog/EventLog.c
- rts/eventlog/EventLog.h
- rts/include/rts/OSThreads.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/Capability.c
=====================================
@@ -443,13 +443,6 @@ void
moreCapabilities (uint32_t from USED_IF_THREADS, uint32_t to USED_IF_THREADS)
{
#if defined(THREADED_RTS)
- // We must disable the timer while we do this since the tick handler may
- // call contextSwitchAllCapabilities, which may see the capabilities array
- // as we free it. The alternative would be to protect the capabilities
- // array with a lock but this seems more expensive than necessary.
- // See #17289.
- stopTimer();
-
if (to == 1) {
// THREADED_RTS must work on builds that don't have a mutable
// BaseReg (eg. unregisterised), so in this case
@@ -470,8 +463,6 @@ moreCapabilities (uint32_t from USED_IF_THREADS, uint32_t to USED_IF_THREADS)
}
debugTrace(DEBUG_sched, "allocated %d more capabilities", to - from);
-
- startTimer();
#endif
}
=====================================
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
=====================================
@@ -37,6 +37,7 @@
#include "win32/AsyncWinIO.h"
#endif
#include "Trace.h"
+#include "eventlog/EventLog.h"
#include "RaiseAsync.h"
#include "Threads.h"
#include "Timer.h"
@@ -454,7 +455,7 @@ run_thread:
prev = setRecentActivity(ACTIVITY_YES);
if (prev == ACTIVITY_DONE_GC) {
#if !defined(PROFILING)
- startTimer();
+ unpauseTimer();
#endif
}
break;
@@ -1935,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;
}
@@ -2100,24 +2101,31 @@ forkProcess(HsStablePtr *entry
ACQUIRE_LOCK(&all_tasks_mutex);
#endif
- stopTimer(); // See #4074
-
#if defined(TRACING)
- flushAllCapsEventsBufs(); // so that child won't inherit dirty file buffers
+#if defined(HAVE_PREEMPTION)
+ // We must hold the eventlog global mutex over the fork to prevent the
+ // timer thread from trying to post events. While holding the mutex we need
+ // to flush the eventlogs (global and per-cap) so that child won't inherit
+ // dirty eventlog buffers or file buffers.
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
+#endif
+ flushAllCapsEventsBufs_();
#endif
pid = fork();
if (pid) { // parent
- startTimer(); // #4074
-
RELEASE_LOCK(&sched_mutex);
RELEASE_LOCK(&sm_mutex);
RELEASE_LOCK(&stable_ptr_mutex);
RELEASE_LOCK(&stable_name_mutex);
RELEASE_LOCK(&task->lock);
+#if defined(TRACING) && defined(HAVE_PREEMPTION)
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
+#endif
+
#if defined(THREADED_RTS)
/* N.B. releaseCapability_ below may need to take all_tasks_mutex */
RELEASE_LOCK(&all_tasks_mutex);
@@ -2224,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
@@ -2236,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.
@@ -2303,12 +2311,6 @@ setNumCapabilities (uint32_t new_n_capabilities USED_IF_THREADS)
cap = rts_lock();
task = cap->running_task;
-
- // N.B. We must stop the interval timer while we are changing the
- // capabilities array lest handle_tick may try to context switch
- // an old capability. See #17289.
- stopTimer();
-
stopAllCapabilities(&cap, task);
if (new_n_capabilities < enabled_capabilities)
@@ -2364,9 +2366,7 @@ setNumCapabilities (uint32_t new_n_capabilities USED_IF_THREADS)
tracingAddCapabilities(n_capabilities, new_n_capabilities);
#endif
- // Resize the capabilities array
- // NB. after this, capabilities points somewhere new. Any pointers
- // of type (Capability *) are now invalid.
+ // Allocate and initialise the extra capabilities
moreCapabilities(n_capabilities, new_n_capabilities);
// Resize and update storage manager data structures
@@ -2394,8 +2394,6 @@ setNumCapabilities (uint32_t new_n_capabilities USED_IF_THREADS)
// Notify IO manager that the number of capabilities has changed.
notifyIOManagerCapabilitiesChanged(&cap);
- startTimer();
-
rts_unlock(cap);
#endif // THREADED_RTS
=====================================
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,20 +28,6 @@
#include "RtsSignals.h"
#include "rts/EventLogWriter.h"
-// See Note [No timer on wasm32]
-#if !defined(wasm32_HOST_ARCH)
-#define HAVE_PREEMPTION
-#endif
-
-// 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;
@@ -112,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) {
@@ -128,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
@@ -153,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 {
@@ -165,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 {
@@ -181,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/eventlog/EventLog.c
=====================================
@@ -129,8 +129,11 @@ typedef struct _EventsBuf {
static EventsBuf *capEventBuf; // one EventsBuf for each Capability
static EventsBuf eventBuf; // an EventsBuf not associated with any Capability
-#if defined(THREADED_RTS)
-static Mutex eventBufMutex; // protected by this mutex
+#if defined(HAVE_PREEMPTION)
+// Note that this mutex is used even in the non-threaded RTS, since the timer
+// thread posts events and flushes. So _all_ uses of this mutex must use
+// ACQUIRE_LOCK_ALWAYS/RELEASE_LOCK_ALWAYS.
+Mutex eventBufMutex; // protects eventBuf above
#endif
// Event type
@@ -393,8 +396,10 @@ initEventLogging(void)
moreCapEventBufs(0, get_n_capabilities());
initEventsBuf(&eventBuf, EVENT_LOG_SIZE, (EventCapNo)(-1));
-#if defined(THREADED_RTS)
+#if defined(HAVE_PREEMPTION)
initMutex(&eventBufMutex);
+#endif
+#if defined(THREADED_RTS)
initMutex(&state_change_mutex);
#endif
}
@@ -416,7 +421,7 @@ startEventLogging_(void)
{
initEventLogWriter();
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
postHeaderEvents();
/*
@@ -425,7 +430,7 @@ startEventLogging_(void)
*/
printAndClearEventBuf(&eventBuf);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
return true;
}
@@ -495,7 +500,7 @@ endEventLogging(void)
flushEventLog_(NULL);
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
// Mark end of events (data).
postEventTypeNum(&eventBuf, EVENT_DATA_END);
@@ -503,7 +508,7 @@ endEventLogging(void)
// Flush the end of data marker.
printAndClearEventBuf(&eventBuf);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
stopEventLogWriter();
event_log_writer = NULL;
@@ -666,7 +671,7 @@ void
postCapEvent (EventTypeNum tag,
EventCapNo capno)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, tag);
postEventHeader(&eventBuf, tag);
@@ -685,14 +690,14 @@ postCapEvent (EventTypeNum tag,
barf("postCapEvent: unknown event tag %d", tag);
}
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postCapsetEvent (EventTypeNum tag,
EventCapsetID capset,
StgWord info)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, tag);
postEventHeader(&eventBuf, tag);
@@ -726,7 +731,7 @@ void postCapsetEvent (EventTypeNum tag,
barf("postCapsetEvent: unknown event tag %d", tag);
}
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postCapsetStrEvent (EventTypeNum tag,
@@ -740,14 +745,14 @@ void postCapsetStrEvent (EventTypeNum tag,
return;
}
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
if (!hasRoomForVariableEvent(&eventBuf, size)){
printAndClearEventBuf(&eventBuf);
if (!hasRoomForVariableEvent(&eventBuf, size)){
errorBelch("Event size exceeds buffer size, bail out");
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
return;
}
}
@@ -758,7 +763,7 @@ void postCapsetStrEvent (EventTypeNum tag,
postBuf(&eventBuf, (StgWord8*) msg, strsize);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postCapsetVecEvent (EventTypeNum tag,
@@ -783,14 +788,14 @@ void postCapsetVecEvent (EventTypeNum tag,
}
}
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
if (!hasRoomForVariableEvent(&eventBuf, size)){
printAndClearEventBuf(&eventBuf);
if(!hasRoomForVariableEvent(&eventBuf, size)){
errorBelch("Event size exceeds buffer size, bail out");
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
return;
}
}
@@ -804,7 +809,7 @@ void postCapsetVecEvent (EventTypeNum tag,
postBuf(&eventBuf, (StgWord8*) argv[i], 1 + strlen(argv[i]));
}
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postWallClockTime (EventCapsetID capset)
@@ -813,7 +818,7 @@ void postWallClockTime (EventCapsetID capset)
StgWord64 sec;
StgWord32 nsec;
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
/* The EVENT_WALL_CLOCK_TIME event is intended to allow programs
reading the eventlog to match up the event timestamps with wall
@@ -846,7 +851,7 @@ void postWallClockTime (EventCapsetID capset)
postWord64(&eventBuf, sec);
postWord32(&eventBuf, nsec);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
/*
@@ -885,7 +890,7 @@ void postEventHeapInfo (EventCapsetID heap_capset,
W_ mblockSize,
W_ blockSize)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, EVENT_HEAP_INFO_GHC);
postEventHeader(&eventBuf, EVENT_HEAP_INFO_GHC);
@@ -899,7 +904,7 @@ void postEventHeapInfo (EventCapsetID heap_capset,
postWord64(&eventBuf, mblockSize);
postWord64(&eventBuf, blockSize);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postEventGcStats (Capability *cap,
@@ -952,7 +957,7 @@ void postTaskCreateEvent (EventTaskId taskId,
EventCapNo capno,
EventKernelThreadId tid)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, EVENT_TASK_CREATE);
postEventHeader(&eventBuf, EVENT_TASK_CREATE);
@@ -961,14 +966,14 @@ void postTaskCreateEvent (EventTaskId taskId,
postCapNo(&eventBuf, capno);
postKernelThreadId(&eventBuf, tid);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postTaskMigrateEvent (EventTaskId taskId,
EventCapNo capno,
EventCapNo new_capno)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, EVENT_TASK_MIGRATE);
postEventHeader(&eventBuf, EVENT_TASK_MIGRATE);
@@ -977,28 +982,28 @@ void postTaskMigrateEvent (EventTaskId taskId,
postCapNo(&eventBuf, capno);
postCapNo(&eventBuf, new_capno);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postTaskDeleteEvent (EventTaskId taskId)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, EVENT_TASK_DELETE);
postEventHeader(&eventBuf, EVENT_TASK_DELETE);
/* EVENT_TASK_DELETE (taskID) */
postTaskId(&eventBuf, taskId);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void
postEventNoCap (EventTypeNum tag)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, tag);
postEventHeader(&eventBuf, tag);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void
@@ -1042,9 +1047,9 @@ void postLogMsg(EventsBuf *eb, EventTypeNum type, char *msg, va_list ap)
void postMsg(char *msg, va_list ap)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
postLogMsg(&eventBuf, EVENT_LOG_MSG, msg, ap);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postCapMsg(Capability *cap, char *msg, va_list ap)
@@ -1138,32 +1143,32 @@ void postConcUpdRemSetFlush(Capability *cap)
void postConcMarkEnd(StgWord32 marked_obj_count)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, EVENT_CONC_MARK_END);
postEventHeader(&eventBuf, EVENT_CONC_MARK_END);
postWord32(&eventBuf, marked_obj_count);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postNonmovingHeapCensus(uint16_t blk_size,
const struct NonmovingAllocCensus *census)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
postEventHeader(&eventBuf, EVENT_NONMOVING_HEAP_CENSUS);
postWord16(&eventBuf, blk_size);
postWord32(&eventBuf, census->n_active_segs);
postWord32(&eventBuf, census->n_filled_segs);
postWord32(&eventBuf, census->n_live_blocks);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postNonmovingPrunedSegments(uint32_t pruned_segments, uint32_t free_segments)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
postEventHeader(&eventBuf, EVENT_NONMOVING_PRUNED_SEGMENTS);
postWord32(&eventBuf, pruned_segments);
postWord32(&eventBuf, free_segments);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void closeBlockMarker (EventsBuf *ebuf)
@@ -1224,7 +1229,7 @@ static HeapProfBreakdown getHeapProfBreakdown(void)
void postHeapProfBegin(void)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
PROFILING_FLAGS *flags = &RtsFlags.ProfFlags;
StgWord modSelector_len =
flags->modSelector ? strlen(flags->modSelector) : 0;
@@ -1258,42 +1263,42 @@ void postHeapProfBegin(void)
postStringLen(&eventBuf, flags->ccsSelector, ccsSelector_len);
postStringLen(&eventBuf, flags->retainerSelector, retainerSelector_len);
postStringLen(&eventBuf, flags->bioSelector, bioSelector_len);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postHeapProfSampleBegin(StgInt era)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, EVENT_HEAP_PROF_SAMPLE_BEGIN);
postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_BEGIN);
postWord64(&eventBuf, era);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postHeapBioProfSampleBegin(StgInt era, StgWord64 time)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, EVENT_HEAP_BIO_PROF_SAMPLE_BEGIN);
postEventHeader(&eventBuf, EVENT_HEAP_BIO_PROF_SAMPLE_BEGIN);
postWord64(&eventBuf, era);
postWord64(&eventBuf, time);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postHeapProfSampleEnd(StgInt era)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, EVENT_HEAP_PROF_SAMPLE_END);
postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_END);
postWord64(&eventBuf, era);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postHeapProfSampleString(const char *label,
StgWord64 residency)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
StgWord label_len = strlen(label);
StgWord len = 1+8+label_len+1;
CHECK(!ensureRoomForVariableEvent(&eventBuf, len));
@@ -1303,7 +1308,7 @@ void postHeapProfSampleString(const char *label,
postWord8(&eventBuf, 0);
postWord64(&eventBuf, residency);
postStringLen(&eventBuf, label, label_len);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
#if defined(PROFILING)
@@ -1313,7 +1318,7 @@ void postHeapProfCostCentre(StgWord32 ccID,
const char *srcloc,
StgBool is_caf)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
StgWord label_len = strlen(label);
StgWord module_len = strlen(module);
StgWord srcloc_len = strlen(srcloc);
@@ -1326,13 +1331,13 @@ void postHeapProfCostCentre(StgWord32 ccID,
postStringLen(&eventBuf, module, module_len);
postStringLen(&eventBuf, srcloc, srcloc_len);
postWord8(&eventBuf, is_caf);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void postHeapProfSampleCostCentre(CostCentreStack *stack,
StgWord64 residency)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
StgWord depth = 0;
CostCentreStack *ccs;
for (ccs = stack; ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack)
@@ -1351,7 +1356,7 @@ void postHeapProfSampleCostCentre(CostCentreStack *stack,
depth>0 && ccs != NULL && ccs != CCS_MAIN;
ccs = ccs->prevStack, depth--)
postWord32(&eventBuf, ccs->cc->ccID);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
@@ -1359,7 +1364,7 @@ void postProfSampleCostCentre(Capability *cap,
CostCentreStack *stack,
StgWord64 tick)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
StgWord depth = 0;
CostCentreStack *ccs;
for (ccs = stack; ccs != NULL && ccs != CCS_MAIN; ccs = ccs->prevStack)
@@ -1377,7 +1382,7 @@ void postProfSampleCostCentre(Capability *cap,
depth>0 && ccs != NULL && ccs != CCS_MAIN;
ccs = ccs->prevStack, depth--)
postWord32(&eventBuf, ccs->cc->ccID);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
// This event is output at the start of profiling so the tick interval can
@@ -1385,11 +1390,11 @@ void postProfSampleCostCentre(Capability *cap,
// can be calculated from how many samples there are.
void postProfBegin(void)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
postEventHeader(&eventBuf, EVENT_PROF_BEGIN);
// The interval that each tick was sampled, in nanoseconds
postWord64(&eventBuf, TimeToNS(RtsFlags.MiscFlags.tickInterval));
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
#endif /* PROFILING */
@@ -1415,11 +1420,11 @@ static void postTickyCounterDef(EventsBuf *eb, StgEntCounter *p)
void postTickyCounterDefs(StgEntCounter *counters)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
for (StgEntCounter *p = counters; p != NULL; p = p->link) {
postTickyCounterDef(&eventBuf, p);
}
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
static void postTickyCounterSample(EventsBuf *eb, StgEntCounter *p)
@@ -1443,13 +1448,13 @@ static void postTickyCounterSample(EventsBuf *eb, StgEntCounter *p)
void postTickyCounterSamples(StgEntCounter *counters)
{
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
ensureRoomForEvent(&eventBuf, EVENT_TICKY_COUNTER_SAMPLE);
postEventHeader(&eventBuf, EVENT_TICKY_COUNTER_BEGIN_SAMPLE);
for (StgEntCounter *p = counters; p != NULL; p = p->link) {
postTickyCounterSample(&eventBuf, p);
}
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
#endif /* TICKY_TICKY */
void postIPE(const InfoProvEnt *ipe)
@@ -1459,7 +1464,7 @@ void postIPE(const InfoProvEnt *ipe)
// See Note [Maximum event length].
const StgWord MAX_IPE_STRING_LEN = 65535;
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
StgWord table_name_len = MIN(strlen(ipe->prov.table_name), MAX_IPE_STRING_LEN);
StgWord closure_desc_len = MIN(strlen(closure_desc_buf), MAX_IPE_STRING_LEN);
StgWord ty_desc_len = MIN(strlen(ipe->prov.ty_desc), MAX_IPE_STRING_LEN);
@@ -1489,7 +1494,7 @@ void postIPE(const InfoProvEnt *ipe)
postBuf(&eventBuf, &colon, 1);
postStringLen(&eventBuf, ipe->prov.src_span, src_span_len);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
}
void printAndClearEventBuf (EventsBuf *ebuf)
@@ -1601,14 +1606,21 @@ void flushLocalEventsBuf(Capability *cap)
// Flush all capabilities' event buffers when we already hold all capabilities.
// Used during forkProcess.
void flushAllCapsEventsBufs(void)
+{
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
+ flushAllCapsEventsBufs_();
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
+}
+
+// Unsafe version that does not acquire/release eventBufMutex. You must
+// hold the eventBufMutex, which you must acquire with ACQUIRE_LOCK_ALWAYS!
+void flushAllCapsEventsBufs_(void)
{
if (!event_log_writer) {
return;
}
- ACQUIRE_LOCK(&eventBufMutex);
printAndClearEventBuf(&eventBuf);
- RELEASE_LOCK(&eventBufMutex);
for (unsigned int i=0; i < getNumCapabilities(); i++) {
flushLocalEventsBuf(getCapability(i));
@@ -1641,9 +1653,9 @@ static void flushEventLog_(Capability **cap USED_IF_THREADS)
return;
}
- ACQUIRE_LOCK(&eventBufMutex);
+ ACQUIRE_LOCK_ALWAYS(&eventBufMutex);
printAndClearEventBuf(&eventBuf);
- RELEASE_LOCK(&eventBufMutex);
+ RELEASE_LOCK_ALWAYS(&eventBufMutex);
#if defined(THREADED_RTS)
Task *task = newBoundTask();
=====================================
rts/eventlog/EventLog.h
=====================================
@@ -18,6 +18,13 @@
#if defined(TRACING)
extern bool eventlog_enabled;
+#if defined(HAVE_PREEMPTION)
+// Avoid using this mutex directly if at all possible. It is needed in the
+// implementation of forkProcess.
+//
+// All uses of this mutex must use ACQUIRE_LOCK_ALWAYS/RELEASE_LOCK_ALWAYS.
+extern Mutex eventBufMutex;
+#endif
void initEventLogging(void);
void restartEventLogging(void);
@@ -27,6 +34,7 @@ void abortEventLogging(void); // #4512 - after fork child needs to abort
void moreCapEventBufs (uint32_t from, uint32_t to);
void flushLocalEventsBuf(Capability *cap);
void flushAllCapsEventsBufs(void);
+void flushAllCapsEventsBufs_(void);
void flushAllEventsBufs(Capability *cap);
typedef void (*EventlogInitPost)(void);
=====================================
rts/include/rts/OSThreads.h
=====================================
@@ -14,6 +14,46 @@
#pragma once
+/* Note [Threads and preemption]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ All full-fat OSs that GHC works on have OS threads, and we use them even in
+ the non-threaded RTS for a few features:
+ * Haskell thread preemption;
+ * sample-based profiling;
+ * idle GC;
+ * periodic eventlog flushing.
+
+ We use defined(HAVE_PREEMPTION) to decide if these features are implemented
+ via OS threads.
+
+ On platforms like WASM/js we do not have OS threads in any conventional
+ sense, and the features above are either not available or are implemented
+ differently. See Note [No timer on wasm32].
+
+ In future if GHC is ported to platforms like bare-metal micro-controllers,
+ RTOSs or to run directly under hypervisors then such platforms may also not
+ have threads available and they should not define HAVE_PREEMPTION here. Or
+ for some micro-controller RTOSs like Zeypher one may have a choice about
+ whether to use threads or not (at a size cost). Here would be the right
+ place to control whether the feature list above is supported.
+ */
+#if defined(wasm32_HOST_ARCH)
+ // See Note [No timer on wasm32]
+ // To confuse matters, WASM _does_ have pthread.h but it doesnt work.
+#elif defined(HAVE_PTHREAD_H) || defined(HAVE_WINDOWS_H)
+#define HAVE_PREEMPTION
+#else
+#error Decide if this platform has threads and pre-emption or not.
+#endif
+// And JS does all of this differently, without using this bit of the RTS.
+
+// Configuration sanity check
+#if defined(THREADED_RTS) && !defined(HAVE_PREEMPTION)
+//TODO we would like to be able to assert this:
+// #error Configuration error: THREADED_RTS should imply HAVE_PREEMPTION
+// however at the moment we cannot due to issue #27346.
+#endif
+
#if defined(HAVE_PTHREAD_H) && !defined(mingw32_HOST_OS)
#if defined(CMINUSMINUS)
@@ -210,9 +250,29 @@ extern bool timedWaitCondition ( Condition* pCond, Mutex* pMut, Time timeout)
//
// Mutexes
//
+// Even in the non-threaded RTS we use threads and mutexes! In particular the
+// timer/ticker is implemented using a thread. And using threads needs locks.
+// In particular we need locks for the data shared between the timer/ticker
+// thread and the thread running the main capability.
+#if defined(HAVE_PREEMPTION)
extern void initMutex ( Mutex* pMut );
extern void closeMutex ( Mutex* pMut );
+// The "always" variants do locking in the threaded and non-threaded RTS.
+// The normal variants below are no-ops in the non-threaded RTS.
+#define ACQUIRE_LOCK_ALWAYS(l) OS_ACQUIRE_LOCK(l)
+#define TRY_ACQUIRE_LOCK_ALWAYS(l) OS_TRY_ACQUIRE_LOCK(l)
+#define RELEASE_LOCK_ALWAYS(l) OS_RELEASE_LOCK(l)
+#define ASSERT_LOCK_HELD_ALWAYS(l) OS_ASSERT_LOCK_HELD(l)
+#else
+// And just to be a bit confusing, the always variants are still no-ops when we
+// do not HAVE_PREEMPTION, since then we don't have threads or mutexes at all.
+#define ACQUIRE_LOCK_ALWAYS(l)
+#define TRY_ACQUIRE_LOCK_ALWAYS(l) 0
+#define RELEASE_LOCK_ALWAYS(l)
+#define ASSERT_LOCK_HELD_ALWAYS(l)
+#endif
+
// Processors and affinity
void setThreadAffinity (uint32_t n, uint32_t m);
void setThreadNode (uint32_t node);
@@ -228,6 +288,7 @@ void releaseThreadNode (void);
#else
+// No-ops in the non-threaded RTS. See also the _ALWAYS variants above.
#define ACQUIRE_LOCK(l)
#define TRY_ACQUIRE_LOCK(l) 0
#define RELEASE_LOCK(l)
=====================================
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 <unistd.h>
#include <fcntl.h>
-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);
+
-// should the ticker thread exit?
-// This can be set without holding the mutex.
-static bool exited = true;
+static Time ticker_interval = DEFAULT_TICK_INTERVAL;
-// Signaled when we want to (re)start the timer
-static Condition start_cond;
-static Mutex mutex;
-static OSThreadId thread;
+// 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;
-// fds for interrupting the ticker
-static int interruptfd_r = -1, interruptfd_w = -1;
+// Atomic variable used by other threads to communicate that they want the
+// ticker thread to exit.
+static bool exit_request;
-static void *itimer_thread_func(void *_handle_tick)
+// 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)
{
TickProc handle_tick = _handle_tick;
-#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
- struct pollfd pollfds[1];
-
- pollfds[0].fd = interruptfd_r;
- pollfds[0].events = POLLIN;
+ // 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.
- 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
+ timeout timeout;
+ fdset fdset;
+ poll_init_timeout(&timeout, ticker_interval);
+ poll_init_fdset(&fdset, notifyfd_r);
- // 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)) {
+ while (!exit) {
-#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,99 @@ 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() overwrites the fdset so we must rebuild it every time. */
+ FD_ZERO(&fds->selectfds);
+ FD_SET(fd, &fds->selectfds);
+ fds->fd = fd;
+}
+
+static int poll_no_timeout(fdset *fds)
+{
+ 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.
+ 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/6a667450ea06ed9c978caf09c169f3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a667450ea06ed9c978caf09c169f3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] 14 commits: Don't drop ticks around variables of type `IO ()`
by Sven Tennie (＠supersven) 11 Jun '26
by Sven Tennie (＠supersven) 11 Jun '26
11 Jun '26
Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC
Commits:
ce01ccb6 by sheaf at 2026-06-10T05:08:48-04:00
Don't drop ticks around variables of type `IO ()`
GHC.Core.Utils.mkTick is responsible for placing a tick on a Core
expression. It contains logic for dropping SCCs (non-counting profiling
ticks) around non-function variables, as such variables cannot
meaningfully contribute to profiles. However, the logic for what counts
as a function was incorrect: it used `isFunTy` which returns 'False' for
types such as 'IO ()' where the function arrow is hidden under a
newtype.
We now use 'mightBeFunTy' instead of 'isFunTy'. This ensures we don't
drop ticks in cases we aren't sure.
On the way, we improve the documentation of 'isFunTy', 'isPiTy' and
'mightBeFunTy', and update the latter's implementation to consistently
handle unary classes.
Fixes #27225
-------------------------
Metric Decrease:
T5642
-------------------------
- - - - -
d311c4f1 by Simon Jakobi at 2026-06-10T05:09:32-04:00
testsuite: Add regression test for #4081
Check that a strict constructor field is unboxed once outside an
enclosing loop, not re-inspected each iteration (the float-out
case-floating from 9cb20b488). Uses simonpj's `data T a = T !a` example
from the ticket; T4081.stderr captures the expected Core.
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
333df444 by sheaf at 2026-06-10T05:10:25-04:00
Check for cabal-install >= 3.12 upfront
Starting with commit 8cb99552f607f6bc4000e45ab32532d50c8bb996, Hadrian
requires cabal-install >= 3.12 in order to use the 'cabal path' command
that was introduced in version 3.12, as per
https://github.com/haskell/cabal/blob/a51c4ee1556d816ad86e90db7e6330dd51b0b…
This was not reflected in the Hadrian build script, causing a delayed
build failure instead of enforcing the version requirement upfront,
which this patch does.
Fixes #27317
- - - - -
98c20394 by sheaf at 2026-06-10T05:11:09-04:00
Fix crash in Data.Data instance for HsCtxt
The Data.Data instance for HsCtxt contained an error for the 'toConstr'
method, which could trigger for example when looking at -ddump-tc-ast
traces. Replace it with the 'abstractConstr' pattern used in the rest of
the codebase.
- - - - -
85fbf60a by Matthew Pickering at 2026-06-11T14:51:17+02:00
Add missing req_interp modifier to T18441fail3 and T18441fail19
These tests require the interpreter but they were failing in a different
way with the javascript backend because the interpreter was disabled and
stderr is ignored by the test.
- - - - -
43600236 by Matthew Pickering at 2026-06-11T14:51:17+02:00
hadrian: Fill in more of the default.host toolchain file
When you are building a cross compiler this file will be used to build
stage1 and it's libraries, so we need enough information here to work
accurately. There is still more work to be done (see for example, word
size is still fixed).
- - - - -
9183601b by Matthew Pickering at 2026-06-11T14:51:17+02:00
hadrian: Build stage 2 cross compilers
* Most of hadrian is abstracted over the stage in order to remove the
assumption that the target of all stages is the same platform. This
allows the RTS to be built for two different targets for example.
* Abstracts the bindist creation logic to allow building either normal
or cross bindists. Normal bindists use stage 1 libraries and a stage 2
compiler. Cross bindists use stage 2 libararies and a stage 2
compiler.
* hadrian: Make binary-dist-dir the default build target. This allows us
to have the logic in one place about which libraries/stages to build
with cross compilers. Fixes #24192
New hadrian target:
* `binary-dist-dir-cross`: Build a cross compiler bindist (compiler =
stage 1, libraries = stage 2)
This commit also contains various changes to make stage2 compilers
feasible.
-------------------------
Metric Decrease:
LinkableUsage02
ManyAlternatives
ManyConstructors
MultiComponentModulesRecomp
MultiLayerModulesRecomp
RecordUpdPerf
T10421
T12150
T12227
T12425
T12707
T13035
T13379
T13820
T15703
T16577
T18140
T18282
T18698a
T18698b
T18923
T1969
T20049
T21839c
T3294
T4801
T5030
T5321FD
T5321Fun
T5631
T5642
T6048
T783
T9020
T9198
T9233
T9630
T9872d
T9961
parsing001
T3064
Metric Increase:
T26989
hard_hole_fits
-------------------------
Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com>
- - - - -
b26b49e8 by Matthew Pickering at 2026-06-11T14:51:17+02:00
ci: Test cross bindists
We remove the special logic for testing in-tree cross
compilers and instead test cross compiler bindists, like we do for all
other platforms.
- - - - -
64672f85 by Matthew Pickering at 2026-06-11T14:51:17+02:00
ci: Introduce CROSS_STAGE variable
In preparation for building and testing stage3 bindists we introduce the
CROSS_STAGE variable which is used by a CI job to determine what kind of
bindist the CI job should produce.
At the moment we are only using CROSS_STAGE=2 but in the future we will
have some jobs which set CROSS_STAGE=3 to produce native bindists for a
target, but produced by a cross compiler, which can be tested on by
another CI job on the native platform.
CROSS_STAGE=2: Build a normal cross compiler bindist
CROSS_STAGE=3: Build a stage 3 bindist, one which is a native compiler and library for the target
- - - - -
ff784eae by Sven Tennie at 2026-06-11T14:51:17+02:00
ci: Increase timeout for emulators
Test runs with emulators naturally take longer than on native machines.
Generate jobs.yml
- - - - -
027ef5f1 by Matthew Pickering at 2026-06-11T14:51:17+02:00
ci: Javascript don't set CROSS_EMULATOR
There is no CROSS_EMULATOR needed to run javascript binaries, so we
don't set the CROSS_EMULATOR to some dummy value.
- - - - -
c1d11a07 by Sven Tennie at 2026-06-11T14:51:17+02:00
Javascript skip T23697
See #22355 about how HSC2HS and the Javascript target don't play well
together.
- - - - -
4d4a70fb by Sven Tennie at 2026-06-11T14:51:17+02:00
Mark T24602 as fragile
It was skipped before (due to CROSS_EMULATOR being set, which changed
for JS), so we don't make things worse by marking it as fragile.
- - - - -
3f1ef740 by Sven Tennie at 2026-06-11T14:51:17+02:00
Fix T22744 for GHCJS
In fact, this test needs Template Haskell, not necessarily an
interpreter.
- - - - -
86 changed files:
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- + changelog.d/T27225
- + changelog.d/T27317
- + changelog.d/T27359
- + changelog.d/stage2-cross-compilers
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Types/RepType.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/README.md
- hadrian/bindist/config.mk.in
- hadrian/build-cabal
- hadrian/cfg/default.host.target.in
- + hadrian/cfg/system.config.host.in
- hadrian/cfg/system.config.in
- + hadrian/cfg/system.config.target.in
- hadrian/hadrian.cabal
- hadrian/src/Base.hs
- + hadrian/src/BindistConfig.hs
- hadrian/src/Builder.hs
- hadrian/src/Context.hs
- hadrian/src/Expression.hs
- hadrian/src/Flavour.hs
- hadrian/src/Flavour/Type.hs
- hadrian/src/Hadrian/Builder.hs
- hadrian/src/Hadrian/Haskell/Hash.hs
- hadrian/src/Hadrian/Oracles/TextFile.hs
- hadrian/src/Main.hs
- hadrian/src/Oracles/Flag.hs
- hadrian/src/Oracles/Flavour.hs
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Oracles/TestSettings.hs
- hadrian/src/Packages.hs
- hadrian/src/Rules.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/CabalReinstall.hs
- hadrian/src/Rules/Changelog.hs
- hadrian/src/Rules/Compile.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Gmp.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Program.hs
- hadrian/src/Rules/Register.hs
- hadrian/src/Rules/Rts.hs
- hadrian/src/Rules/Test.hs
- hadrian/src/Settings.hs
- hadrian/src/Settings/Builders/Cabal.hs
- hadrian/src/Settings/Builders/Common.hs
- hadrian/src/Settings/Builders/Configure.hs
- hadrian/src/Settings/Builders/DeriveConstants.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Builders/Hsc2Hs.hs
- hadrian/src/Settings/Builders/RunTest.hs
- hadrian/src/Settings/Builders/SplitSections.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Flavours/GhcInGhci.hs
- hadrian/src/Settings/Flavours/Performance.hs
- hadrian/src/Settings/Flavours/QuickCross.hs
- hadrian/src/Settings/Packages.hs
- hadrian/src/Settings/Program.hs
- hadrian/src/Settings/Warnings.hs
- libraries/base/tests/all.T
- m4/fp_find_nm.m4
- m4/prep_target_file.m4
- testsuite/ghc-config/ghc-config.hs
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/ghc-e/should_fail/all.T
- testsuite/tests/javascript/closure/all.T
- testsuite/tests/perf/compiler/all.T
- + testsuite/tests/profiling/should_run/T27225.hs
- + testsuite/tests/profiling/should_run/T27225.stdout
- + testsuite/tests/profiling/should_run/T27225b.hs
- + testsuite/tests/profiling/should_run/T27225b.stdout
- testsuite/tests/profiling/should_run/all.T
- testsuite/tests/profiling/should_run/caller-cc/CallerCc1.prof.sample
- testsuite/tests/profiling/should_run/callstack001.stdout
- testsuite/tests/profiling/should_run/scc001.prof.sample
- + testsuite/tests/simplCore/should_compile/T4081.hs
- + testsuite/tests/simplCore/should_compile/T4081.stderr
- testsuite/tests/simplCore/should_compile/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/baa069c7781fcbe22014284c609577…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/baa069c7781fcbe22014284c609577…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sjakobi/multi-caret] Shorten Note [Choosing the primary and related spans]
by Simon Jakobi (＠sjakobi2) 11 Jun '26
by Simon Jakobi (＠sjakobi2) 11 Jun '26
11 Jun '26
Simon Jakobi pushed to branch wip/sjakobi/multi-caret at Glasgow Haskell Compiler / GHC
Commits:
b71eabb0 by Simon Jakobi at 2026-06-11T14:33:13+02:00
Shorten Note [Choosing the primary and related spans]
Per review by @sheaf: trim the note and present the last-occurrence-primary
handling of duplicate diagnostics as current practice rather than a
convention, noting that different diagnostics may pick and order their
spans differently.
Co-Authored-By: Claude Fable 5 <noreply(a)anthropic.com>
- - - - -
1 changed file:
- compiler/GHC/Types/Error.hs
Changes:
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -282,8 +282,7 @@ The rendering layer shows a diagnostic's locations in exactly the order given
them is the message author's job:
* Pick one real location as the primary span and list the rest as related
- locations. The primary span need not be the leftmost or smallest location
- involved; a synthetic span combining several locations is usually worse,
+ locations. A synthetic span combining several locations is usually worse,
giving a less precise prefix and a larger caret.
* Order the related spans deterministically (e.g. by sorting with
@@ -291,19 +290,14 @@ them is the message author's job:
natural order is not stable across runs. Do not repeat the primary span
among them.
- * Convention for "duplicate" diagnostics, which report the same entity
- occurring at several sites (e.g. 'TcRnDuplicateDecls',
- 'TcRnDuplicateExport'): the primary span is the /last/ occurrence in
- source order; the earlier occurrences are the related locations, in
- ascending order. The later occurrence is usually the one just added, and
- hence the one to act on; clang, rustc and TypeScript likewise point at it
- ("redefinition of 'x' / note: previous definition is here"). The carets
- are then /not/ in source order, but read well without labels: first the
- site to fix, then the prior sites. (Once per-span labels exist (#23414),
- the renderer could instead display carets in source order, as rustc does —
- its labels are what make that readable.) Diagnostics whose locations have
- a different asymmetry (a definition site versus a use site, say) pick
- their primary span on their own logic.
+Different diagnostics may want to pick and order the spans in different ways.
+For "duplicate" diagnostics, which report the same entity occurring at several
+sites (e.g. 'TcRnDuplicateDecls', 'TcRnDuplicateExport'), we currently use the
+/last/ occurrence in source order as the primary span, with the earlier
+occurrences as related locations in ascending order: the last occurrence is
+likely the one just added, and hence the most actionable; clang, rustc and
+TypeScript likewise point at it ("redefinition of 'x' / note: previous
+definition is here").
-}
-- | A class identifying a diagnostic.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b71eabb0bbd7eb11787c7a0f7ce6e53…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b71eabb0bbd7eb11787c7a0f7ce6e53…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Don't drop ticks around variables of type `IO ()`
by Marge Bot (＠marge-bot) 11 Jun '26
by Marge Bot (＠marge-bot) 11 Jun '26
11 Jun '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
ce01ccb6 by sheaf at 2026-06-10T05:08:48-04:00
Don't drop ticks around variables of type `IO ()`
GHC.Core.Utils.mkTick is responsible for placing a tick on a Core
expression. It contains logic for dropping SCCs (non-counting profiling
ticks) around non-function variables, as such variables cannot
meaningfully contribute to profiles. However, the logic for what counts
as a function was incorrect: it used `isFunTy` which returns 'False' for
types such as 'IO ()' where the function arrow is hidden under a
newtype.
We now use 'mightBeFunTy' instead of 'isFunTy'. This ensures we don't
drop ticks in cases we aren't sure.
On the way, we improve the documentation of 'isFunTy', 'isPiTy' and
'mightBeFunTy', and update the latter's implementation to consistently
handle unary classes.
Fixes #27225
-------------------------
Metric Decrease:
T5642
-------------------------
- - - - -
d311c4f1 by Simon Jakobi at 2026-06-10T05:09:32-04:00
testsuite: Add regression test for #4081
Check that a strict constructor field is unboxed once outside an
enclosing loop, not re-inspected each iteration (the float-out
case-floating from 9cb20b488). Uses simonpj's `data T a = T !a` example
from the ticket; T4081.stderr captures the expected Core.
Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com>
- - - - -
333df444 by sheaf at 2026-06-10T05:10:25-04:00
Check for cabal-install >= 3.12 upfront
Starting with commit 8cb99552f607f6bc4000e45ab32532d50c8bb996, Hadrian
requires cabal-install >= 3.12 in order to use the 'cabal path' command
that was introduced in version 3.12, as per
https://github.com/haskell/cabal/blob/a51c4ee1556d816ad86e90db7e6330dd51b0b…
This was not reflected in the Hadrian build script, causing a delayed
build failure instead of enforcing the version requirement upfront,
which this patch does.
Fixes #27317
- - - - -
98c20394 by sheaf at 2026-06-10T05:11:09-04:00
Fix crash in Data.Data instance for HsCtxt
The Data.Data instance for HsCtxt contained an error for the 'toConstr'
method, which could trigger for example when looking at -ddump-tc-ast
traces. Replace it with the 'abstractConstr' pattern used in the rest of
the codebase.
- - - - -
5ac9ce7d by Zubin Duggal at 2026-06-10T21:26:32+05:30
hadrian: Remove old package.conf files when generating new ones
Old package.conf files might exists with different hashes, causing issues like #26661
Fixes #26661
- - - - -
6b49f894 by sheaf at 2026-06-11T08:39:05-04:00
Fix AArch64 clobbering bug for MUL2
On AArch64, the code generator could clobber one of the input operands
when computing the lower bits of a MUL2 operation. This rendered invalid
the subsequent computation of the high bits.
This commit fixes that by using a temporary register. The register
allocator can remove the redundant move in the common case when the
registers do not conflict.
Fixes #27046
- - - - -
1c1bf1e3 by Rodrigo Mesquita at 2026-06-11T08:39:06-04:00
fix: make T27131 less flaky
It seems that T27131 fails flakily in a race where we check the flag
before the capability had the chance to process the mailbox which sets
the flag. This seemingly should only happen if the capability ends up
being the same for setting and checking the flag.
- - - - -
30 changed files:
- + changelog.d/T27046
- + changelog.d/T27225
- + changelog.d/T27317
- + changelog.d/T27359
- + changelog.d/hadrian-stale-package-confs-26661
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Types/RepType.hs
- hadrian/build-cabal
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- + testsuite/tests/codeGen/should_run/T27046.hs
- + testsuite/tests/codeGen/should_run/T27046_cmm.cmm
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/profiling/should_run/T27225.hs
- + testsuite/tests/profiling/should_run/T27225.stdout
- + testsuite/tests/profiling/should_run/T27225b.hs
- + testsuite/tests/profiling/should_run/T27225b.stdout
- testsuite/tests/profiling/should_run/all.T
- testsuite/tests/profiling/should_run/caller-cc/CallerCc1.prof.sample
- testsuite/tests/profiling/should_run/callstack001.stdout
- testsuite/tests/profiling/should_run/scc001.prof.sample
- testsuite/tests/rts/T27131.hs
- testsuite/tests/rts/T27131.stdout
- + testsuite/tests/simplCore/should_compile/T4081.hs
- + testsuite/tests/simplCore/should_compile/T4081.stderr
- testsuite/tests/simplCore/should_compile/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aded87749977e5dc58bea86e2b8872…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aded87749977e5dc58bea86e2b8872…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sjakobi/T27368] testsuite: Add regression test for #27368
by Simon Jakobi (＠sjakobi2) 11 Jun '26
by Simon Jakobi (＠sjakobi2) 11 Jun '26
11 Jun '26
Simon Jakobi pushed to branch wip/sjakobi/T27368 at Glasgow Haskell Compiler / GHC
Commits:
4ff5d4da by Simon Jakobi at 2026-06-11T13:45:48+02:00
testsuite: Add regression test for #27368
The test distills the code shape that made setInfoTableStackMap panic
when compiling GHC.CmmToAsm.Dwarf.Types with -O2 on top of !16168:
two branches with identical suffixes from a three-constructor case
onwards. Common block elimination merges the duplicated call blocks
across the branches and leaves the losing copies unreachable in the
block map, with a continuation label that is itself unreachable.
Also panics unfixed released compilers (GHC 9.12.2 and 9.14.1).
Co-Authored-By: Claude Fable 5 <noreply(a)anthropic.com>
- - - - -
2 changed files:
- + testsuite/tests/codeGen/should_compile/T27368.hs
- testsuite/tests/codeGen/should_compile/all.T
Changes:
=====================================
testsuite/tests/codeGen/should_compile/T27368.hs
=====================================
@@ -0,0 +1,20 @@
+-- Regression test for #27368: setInfoTableStackMap panicked because
+-- callProcPoints collected the continuation of a call in an unreachable
+-- block. The two branches below have identical suffixes from the inner
+-- case onwards; common block elimination merges the duplicated call
+-- blocks but leaves the losing copies in the block map, where the dead
+-- call's continuation label is itself unreachable.
+module T27368 (f) where
+
+{-# NOINLINE put #-}
+put :: Int -> Int -> IO ()
+put h x = if h + x == 12345 then errorWithoutStackTrace "boom" else pure ()
+
+data T = N | J Int | K
+
+f :: Int -> Bool -> T -> IO ()
+f h a t = do
+ if a
+ then do put h 1; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0
+ else do put h 2; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0
+ put h 0
=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -150,3 +150,5 @@ test('T16351', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppres
test('T20298a', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques'])
test('T20298b', normal, compile, ['-O2 -dno-bignum-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques'])
test('T20298c', normal, compile, ['-O2 -dno-builtin-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques'])
+
+test('T27368', normal, compile, ['-O2'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ff5d4daff5bde31cd051aa1e5a6295…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ff5d4daff5bde31cd051aa1e5a6295…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/terrorjack/drop-long-reg
by Cheng Shao (＠TerrorJack) 11 Jun '26
by Cheng Shao (＠TerrorJack) 11 Jun '26
11 Jun '26
Cheng Shao pushed new branch wip/terrorjack/drop-long-reg at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/terrorjack/drop-long-reg
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/external-unit-db-cache] WIP: Introduce UnitIndex for global data
by Hannes Siebenhandl (＠fendor) 11 Jun '26
by Hannes Siebenhandl (＠fendor) 11 Jun '26
11 Jun '26
Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC
Commits:
a00ce157 by fendor at 2026-06-11T12:12:41+02:00
WIP: Introduce UnitIndex for global data
- - - - -
9 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- libraries/ghc-boot/GHC/Unit/Database.hs
- utils/haddock/haddock-api/src/Haddock.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -671,7 +671,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do
logger <- getLogger
hsc_env <- getSession
- (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env)
+ (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hsc_unit_index hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -760,7 +760,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = HUG.allUnits (ue_home_unit_graph old_unit_env)
- (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_eud old_unit_env) home_units
+ (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index old_unit_env) (ue_eud old_unit_env) home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -779,6 +779,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_module_graph = ue_module_graph old_unit_env
, ue_eps = ue_eps old_unit_env
, ue_eud = ue_eud old_unit_env
+ , ue_unit_index = ue_unit_index old_unit_env
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
@@ -837,6 +838,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do
, ue_eps = ue_eps unit_env0
, ue_module_graph = ue_module_graph unit_env0
, ue_eud = ue_eud unit_env0
+ , ue_unit_index = ue_unit_index unit_env0
}
modifySession $ \h ->
-- hscSetFlags takes care of updating the logger as well.
@@ -884,7 +886,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = HUG.allUnits (ue_home_unit_graph unit_env)
- (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_eud unit_env) home_units
+ (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index unit_env) (ue_eud unit_env) home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure HomeUnitEnv
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -174,6 +174,8 @@ withBkpSession :: UnitId
-> BkpM a
withBkpSession cid insts deps session_type do_this = do
dflags <- getDynFlags
+ env <- getSession
+ unitIndex <- liftIO $ hscUnitIndex env
let cid_fs = unitFS cid
is_primary = False
uid_str = unpackFS (mkInstantiatedUnitHash cid insts)
@@ -193,8 +195,8 @@ withBkpSession cid insts deps session_type do_this = do
| otherwise = sub_comp (key_base p)
mk_temp_env hsc_env =
- hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env
- mk_temp_dflags unit_state dflags = dflags
+ hscUpdateFlags (\dflags -> mk_temp_dflags unitIndex (hsc_units hsc_env) dflags) hsc_env
+ mk_temp_dflags unit_index unit_state dflags = dflags
{ backend = case session_type of
TcSession -> noBackend
_ -> backend dflags
@@ -241,7 +243,7 @@ withBkpSession cid insts deps session_type do_this = do
, importPaths = []
-- Synthesize the flags
, packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
- let uid = unwireUnit unit_state
+ let uid = unwireUnit unit_index
$ improveUnit unit_state
$ renameHoleUnit unit_state (listToUFM insts) uid0
in ExposePackage
@@ -352,9 +354,9 @@ buildUnit session cid insts lunit = do
| otherwise
= [Nothing]
linkables <- liftIO $ catMaybes <$> concatHpt takeLinkables (hsc_HPT hsc_env)
+ unit_index <- liftIO $ hscUnitIndex hsc_env
let
obj_files = concatMap linkableFiles linkables
- state = hsc_units hsc_env
compat_fs = unitIdFS cid
compat_pn = PackageName compat_fs
@@ -380,7 +382,7 @@ buildUnit session cid insts lunit = do
-- really used for anything, so we leave it
-- blank for now.
TcSession -> []
- _ -> map (toUnitId . unwireUnit state)
+ _ -> map (toUnitId . unwireUnit unit_index)
$ deps ++ [ moduleUnit mod
| (_, mod) <- insts
, not (isHoleModule mod) ],
@@ -452,7 +454,7 @@ addUnit u = do
{ packageDBFlags = packageDBFlags dflags0 ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))]
}
- (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 eud (hsc_all_home_unit_ids hsc_env)
+ (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_unit_index old_unit_env) eud (hsc_all_home_unit_ids hsc_env)
-- update platform constants
@@ -470,6 +472,7 @@ addUnit u = do
, ue_eps = ue_eps old_unit_env
, ue_module_graph = ue_module_graph old_unit_env
, ue_eud = ue_eud old_unit_env
+ , ue_unit_index = ue_unit_index old_unit_env
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -13,6 +13,8 @@ module GHC.Driver.Env
, hsc_HUE
, hsc_HUG
, hsc_all_home_unit_ids
+ , hscUnitIndex
+ , hsc_unit_index
, hscUpdateLoggerFlags
, hscUpdateHUG
, hscInsertHPT
@@ -230,6 +232,12 @@ hscEUD = readExternalUnitDatabases . hscEUDC
hscEUDC :: HscEnv -> ExternalUnitDatabaseCache UnitId
hscEUDC hsc_env = ue_eud (hsc_unit_env hsc_env)
+hscUnitIndex :: HscEnv -> IO UnitIndex
+hscUnitIndex hsc_env = readIORef $ ue_unit_index (hsc_unit_env hsc_env)
+
+hsc_unit_index :: HscEnv -> IORef UnitIndex
+hsc_unit_index hsc_env = ue_unit_index (hsc_unit_env hsc_env)
+
--------------------------------------------------------------------------------
-- * Queries on Transitive Closure
--------------------------------------------------------------------------------
=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -131,7 +131,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
let hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscEUDC hsc_env) home_units
+ (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hsc_unit_index hsc_env) (hscEUDC hsc_env) home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
emptyHpt <- liftIO $ emptyHomePackageTable
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -131,6 +131,7 @@ import GHC.Types.Annotations
import GHC.Types.CompleteMatch
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
+import Data.IORef
--------------------------------------------------------------------------------
-- The hard queries
@@ -177,6 +178,8 @@ data UnitEnv = UnitEnv
, ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId)
-- TODO: @fendor Docs
+ , ue_unit_index :: {-# UNPACK #-} !(IORef UnitIndex)
+ -- TODO: @fendor Docs
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -186,6 +189,7 @@ initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitE
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
eud <- initExternalUnitDatabaseCache
+ unit_index <- newIORef (initUnitIndex)
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
@@ -194,6 +198,7 @@ initUnitEnv cur_unit hug namever platform = do
, ue_platform = platform
, ue_namever = namever
, ue_eud = eud
+ , ue_unit_index = unit_index
}
updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -5,6 +5,13 @@
module GHC.Unit.State (
module GHC.Unit.Info,
+ UnitIndex(..),
+ initUnitIndex,
+ setWireMap,
+ isWireMapEmpty,
+ addUnitInfoMap,
+ lookupUnitInfoMap,
+
-- * Reading the package config, and processing cmdline args
UnitState(..),
PreloadUnitClosure,
@@ -28,7 +35,7 @@ module GHC.Unit.State (
lookupUnitId',
unsafeLookupUnitId,
isUnitTrusted,
- isUnitIdTrusted,
+ isUnitIdTrusted,
isUnitInfoTrusted,
lookupPackageName,
@@ -125,6 +132,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import Control.Applicative
import GHC.Unit.External.Database
+import Data.IORef
+import Data.Either (partitionEithers)
-- ---------------------------------------------------------------------------
-- The Unit state
@@ -428,6 +437,40 @@ initUnitConfig dflags cached_dbs home_units =
type ModuleNameProvidersMap =
UniqMap ModuleName (UniqMap Module ModuleOrigin)
+data UnitIndex = UnitIndex
+ { ui_wireMap :: WiringMap
+ , ui_unwireMap :: UnwiringMap
+ , ui_unitInfoMap :: UnitInfoMap
+ }
+
+initUnitIndex :: UnitIndex
+initUnitIndex = UnitIndex
+ { ui_wireMap = emptyUniqMap
+ , ui_unwireMap = emptyUniqMap
+ , ui_unitInfoMap = emptyUniqMap
+ }
+
+setWireMap :: WiringMap -> UnitIndex -> UnitIndex
+setWireMap wired_map unit_index =
+ unit_index
+ { ui_wireMap = wired_map
+ , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
+ }
+
+isWireMapEmpty :: UnitIndex -> Bool
+isWireMapEmpty unit_index =
+ isNullUniqMap (ui_wireMap unit_index)
+
+addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex
+addUnitInfoMap unit_info_map unit_index =
+ unit_index
+ { ui_unitInfoMap = unit_info_map `plusUniqMap` ui_unitInfoMap unit_index
+ }
+
+lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo
+lookupUnitInfoMap unit_index unit_id =
+ lookupUniqMap (ui_unitInfoMap unit_index) unit_id
+
data UnitState = UnitState {
-- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted
-- so that only valid units are here. 'UnitInfo' reflects
@@ -452,11 +495,11 @@ data UnitState = UnitState {
-- And also to resolve package qualifiers with the PackageImports extension.
packageNameMap :: UniqFM PackageName UnitId,
- -- | A mapping from database unit keys to wired in unit ids.
- wireMap :: UniqMap UnitId UnitId,
+ -- -- | A mapping from database unit keys to wired in unit ids.
+ -- wireMap :: WiringMap,
- -- | A mapping from wired in unit ids to unit keys from the database.
- unwireMap :: UniqMap UnitId UnitId,
+ -- -- | A mapping from wired in unit ids to unit keys from the database.
+ -- unwireMap :: UnwiringMap,
-- | The units we're going to link in eagerly. This list
-- should be in reverse dependency order; that is, a unit
@@ -502,8 +545,8 @@ emptyUnitState = UnitState {
distrustedUnits = Set.empty,
preloadClosure = emptyUniqSet,
packageNameMap = emptyUFM,
- wireMap = emptyUniqMap,
- unwireMap = emptyUniqMap,
+ -- wireMap = emptyUniqMap,
+ -- unwireMap = emptyUniqMap,
preloadUnits = [],
explicitUnits = [],
homeUnitDepends = Set.empty,
@@ -657,20 +700,22 @@ isUnitInfoTrusted ue unit_info =
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> IORef UnitIndex -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags unit_index cached_dbs home_units = do
let forceUnitInfoMap state = unitInfoMap state `seq` ()
unit_state <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger unit_index (initUnitConfig dflags cached_dbs home_units)
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
$ pprModuleMap (moduleNameProvidersMap unit_state))
- let home_unit = mkHomeUnit unit_state
+ wireMap <- ui_wireMap <$> readIORef unit_index
+
+ let home_unit = mkHomeUnit wireMap
(homeUnitId_ dflags)
(homeUnitInstanceOf_ dflags)
(homeUnitInstantiations_ dflags)
@@ -695,16 +740,15 @@ initUnits logger dflags cached_dbs home_units = do
return (unit_state,home_unit,mconstants)
mkHomeUnit
- :: UnitState
+ :: WiringMap
-> UnitId -- ^ Home unit id
-> Maybe UnitId -- ^ Home unit instance of
-> [(ModuleName, Module)] -- ^ Home unit instantiations
-> HomeUnit
-mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ =
+mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ =
let
-- Some wired units can be used to instantiate the home unit. We need to
-- replace their unit keys with their wired unit ids.
- wmap = wireMap unit_state
hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_
in case (hu_instanceof, hu_instantiations) of
(Nothing,[]) -> DefiniteHomeUnit hu_id Nothing
@@ -823,7 +867,8 @@ readUnitDatabase logger cfg conf_file = do
pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
proto_pkg_configs
--
- return $ UnitDatabase conf_file' pkg_configs1
+ pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1
+ return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2
where
readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
readDirStyleUnitInfo conf_dir = do
@@ -902,6 +947,29 @@ mungeBytecodeLibFields pkg =
ds -> ds
}
+evaluateUnitInfo :: UnitInfo -> IO UnitInfo
+evaluateUnitInfo ui = do
+ importDirs <- evaluate $ unitImportDirs ui
+ includeDirs <- evaluate $ unitIncludeDirs ui
+ libraryDirs <- evaluate $ unitLibraryDirs ui
+ libraryBytecodeDirs <- evaluate $ unitLibraryBytecodeDirs ui
+ extDepFrameworkDirs <- evaluate $ unitExtDepFrameworkDirs ui
+ haddockInterfaces <- evaluate $ unitHaddockInterfaces ui
+ haddockHTMLs <- evaluate $ unitHaddockHTMLs ui
+ libraryDynDirs <- evaluate $ unitLibraryDynDirs ui
+ libraryDirsStatic <- evaluate $ unitLibraryDirsStatic ui
+ evaluate ui
+ { unitImportDirs = importDirs
+ , unitIncludeDirs = includeDirs
+ , unitLibraryDirs = libraryDirs
+ , unitLibraryDynDirs = libraryDynDirs
+ , unitLibraryDirsStatic = libraryDirsStatic
+ , unitLibraryBytecodeDirs = libraryBytecodeDirs
+ , unitExtDepFrameworkDirs = extDepFrameworkDirs
+ , unitHaddockInterfaces = haddockInterfaces
+ , unitHaddockHTMLs = haddockHTMLs
+ }
+
-- -----------------------------------------------------------------------------
-- Modify our copy of the unit database based on trust flags,
-- -trust and -distrust.
@@ -1137,6 +1205,7 @@ pprTrustFlag flag = case flag of
-- See Note [Wired-in units] in GHC.Unit.Types
type WiringMap = UniqMap UnitId UnitId
+type UnwiringMap = UniqMap UnitId UnitId
findWiredInUnits
:: Logger
@@ -1144,9 +1213,7 @@ findWiredInUnits
-> [UnitInfo] -- database
-> VisibilityMap -- info on what units are visible
-- for wired in selection
- -> IO ([UnitInfo], -- unit database updated for wired in
- WiringMap) -- map from unit id to wired identity
-
+ -> IO WiringMap -- map from unit id to wired identity
findWiredInUnits logger prec_map pkgs vis_map = do
-- Now we must find our wired-in units, and rename them to
-- their canonical names (eg. base-1.0 ==> base), as described
@@ -1209,27 +1276,41 @@ findWiredInUnits logger prec_map pkgs vis_map = do
, not (unitIsIndefinite realUnitInfo)
]
- updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
- where upd_pkg pkg
- | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg)
- = pkg { unitId = wiredInUnitId
- , unitInstanceOf = wiredInUnitId
- -- every non instantiated unit is an instance of
- -- itself (required by Backpack...)
- --
- -- See Note [About units] in GHC.Unit
- }
- | otherwise
- = pkg
- upd_deps pkg = pkg {
- unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),
- unitExposedModules
- = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))
- (unitExposedModules pkg)
- }
-
-
- return (updateWiredInDependencies pkgs, wiredInMap)
+ return wiredInMap
+
+updateWiredInUnits :: WiringMap -> UnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo]
+updateWiredInUnits wiredInMap knownInfos pkgs =
+ map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs
+
+updateWiredInUnitsInUnitInfo :: WiringMap -> UnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo
+updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg =
+ let
+ upd_pkg pkg
+ | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg)
+ = pkg { unitId = wiredInUnitId
+ , unitInstanceOf = wiredInUnitId
+ -- every non instantiated unit is an instance of
+ -- itself (required by Backpack...)
+ --
+ -- See Note [About units] in GHC.Unit
+ }
+ | otherwise
+ = pkg
+ upd_deps pkg = pkg {
+ unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),
+ unitExposedModules
+ = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))
+ (unitExposedModules pkg)
+ }
+ in
+ case lookupUniqMap knownInfos (unitId pkg) of
+ Just ui ->
+ Right ui
+ Nothing ->
+ let
+ updated_pkg = upd_deps $ upd_pkg pkg
+ in
+ Left updated_pkg
-- Helper functions for rewiring Module and Unit. These
-- rewrite Units of modules in wired-in packages to the form known to the
@@ -1512,9 +1593,10 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
+ -> IORef UnitIndex
-> UnitConfig
-> IO UnitState
-mkUnitState logger cfg = do
+mkUnitState logger unit_index cfg = do
{-
Plan.
@@ -1605,7 +1687,7 @@ mkUnitState logger cfg = do
-- Compute trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
- (trusted, distrusted) <- mayThrowUnitErr
+ (!trusted, !distrusted) <- mayThrowUnitErr
$ foldM (applyTrustFlag prec_map unusable (nonDetEltsUniqMap pkg_map2))
(trustedUnits, distrustedUnits) (reverse (unitConfigFlagsTrusted cfg))
let pkgs1 = nonDetEltsUniqMap pkg_map2
@@ -1674,7 +1756,21 @@ mkUnitState logger cfg = do
-- it modifies the unit ids of wired in packages, but when we process
-- package arguments we need to key against the old versions.
--
- (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
+ ui <- readIORef unit_index
+ (wired_map, pkgs2) <- do
+ wireMap <- if isWireMapEmpty ui
+ then do
+ wmap <- findWiredInUnits logger prec_map pkgs1 vis_map2
+ modifyIORef' unit_index (setWireMap wmap)
+ pure wmap
+ else do
+ pure $ ui_wireMap ui
+
+ let (new_pkgs, pkgs_set) = partitionEithers $ updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1
+
+ modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs)
+ pure (wireMap, pkgs_set ++ new_pkgs)
+
let pkg_db = mkUnitInfoMap pkgs2
-- Update the visibility map, so we treat wired packages as visible.
@@ -1762,8 +1858,8 @@ mkUnitState logger cfg = do
, moduleNameProvidersMap = mod_map
, pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
, packageNameMap = pkgname_map
- , wireMap = wired_map
- , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
+ -- , wireMap = wired_map
+ -- , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
, requirementContext = req_ctx
, allowVirtualUnits = unitConfigAllowVirtual cfg
}
@@ -1784,9 +1880,9 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags
-- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
-- that it was recorded as in the package database.
-unwireUnit :: UnitState -> Unit -> Unit
+unwireUnit :: UnitIndex -> Unit -> Unit
unwireUnit state uid@(RealUnit (Definite def_uid)) =
- maybe uid (RealUnit . Definite) (lookupUniqMap (unwireMap state) def_uid)
+ maybe uid (RealUnit . Definite) (lookupUniqMap (ui_unwireMap state) def_uid)
unwireUnit _ uid = uid
-- -----------------------------------------------------------------------------
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -856,8 +856,9 @@ installInteractiveHomeUnits dflags = do
setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> m HomeUnitEnv
setupHomeUnitFor logger dflags all_home_units = do
env <- GHC.getSession
+ let unit_index = hsc_unit_index env
(unit_state,home_unit,_mconstants) <-
- liftIO $ initUnits logger dflags (hscEUDC env) all_home_units
+ liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units
hpt <- liftIO emptyHomePackageTable
pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit))
=====================================
libraries/ghc-boot/GHC/Unit/Database.hs
=====================================
@@ -746,11 +746,20 @@ mungeUnitInfoPaths top_dir pkgroot pkg =
, unitHaddockHTMLs = munge_paths (munge_urls (unitHaddockHTMLs pkg))
}
where
- munge_paths = map munge_path
- munge_urls = map munge_url
+ munge_paths = strictMap munge_path
+ munge_urls = strictMap munge_url
(munge_path,munge_url) = mkMungePathUrl top_dir pkgroot
-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
-- Prefer 'decodeUtf' and gracious error handling.
unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath
unsafeDecodeUtf = OsPath.Internal.so
+
+strictMap :: (a -> b) -> [a] -> [b]
+strictMap _ [] = []
+strictMap f (x:xs) =
+ let
+ !x' = f x
+ !xs' = strictMap f xs
+ in
+ x' : xs'
=====================================
utils/haddock/haddock-api/src/Haddock.hs
=====================================
@@ -211,7 +211,9 @@ haddockWithGhc ghc args = handleTopExceptions $ do
logger' <- getLogger
let logger = setLogFlags logger' (initLogFlags dflags)
let parserOpts = Parser.initParserOpts dflags
- !unit_state <- hsc_units <$> getSession
+ env <- getSession
+ let !unit_state = hsc_units env
+ !unit_index <- liftIO $ hscUnitIndex env
-- If any --show-interface was used, show the given interfaces
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
@@ -238,7 +240,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
}
-- Render the interfaces.
- liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages ifaces
+ liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual packages ifaces
-- If we were not given any input files, error if documentation was
-- requested
@@ -251,7 +253,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
- liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual packages []
+ liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual packages []
-- | Run the GHC action using a temporary output directory
withTempOutputDir :: Ghc a -> Ghc a
@@ -307,6 +309,7 @@ renderStep
:: DynFlags
-> ParserOpts
-> Logger
+ -> UnitIndex
-> UnitState
-> [Flag]
-> SinceQual
@@ -314,7 +317,7 @@ renderStep
-> [(DocPaths, Visibility, FilePath, InterfaceFile)]
-> [Interface]
-> IO ()
-renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs interfaces = do
+renderStep dflags parserOpts logger unit_index unit_state flags sinceQual nameQual pkgs interfaces = do
updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) ->
( case baseUrl flags of
Nothing -> docPathsHtml docPath
@@ -330,7 +333,7 @@ renderStep dflags parserOpts logger unit_state flags sinceQual nameQual pkgs int
(DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs
iface <- ifInstalledIfaces ifile
return (instMod iface, path)
- render dflags parserOpts logger unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
+ render dflags parserOpts logger unit_index unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
where
-- get package name from unit-id
packageName :: Unit -> String
@@ -344,6 +347,7 @@ render
:: DynFlags
-> ParserOpts
-> Logger
+ -> UnitIndex
-> UnitState
-> [Flag]
-> SinceQual
@@ -352,7 +356,7 @@ render
-> [(FilePath, PackageInterfaces)]
-> Map Module FilePath
-> IO ()
-render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages extSrcMap = do
+render dflags parserOpts logger unit_index unit_state flags sinceQual qual ifaces packages extSrcMap = do
let
packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty)
$ optPackageName flags
@@ -454,7 +458,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual ifaces packages
-- records the *wired in* identity base. So untranslate it
-- so that we can service the request.
unwire :: Module -> Module
- unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) }
+ unwire m = m { moduleUnit = unwireUnit unit_index (moduleUnit m) }
reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do
let warn' = hPutStrLn stderr . ("Warning: " ++)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a00ce157046e07ddea7d35426983d25…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a00ce157046e07ddea7d35426983d25…
You're receiving this email because of your account on gitlab.haskell.org.
1
0