May 2026 - ghc-commits

[Git][ghc/ghc][wip/27113-retry] rts: Retry SIGPIPE delivery for interruptible FFI calls (#27113)
by Zubin (＠wz1000) 19 May '26

19 May '26

Zubin pushed to branch wip/27113-retry at Glasgow Haskell Compiler / GHC Commits: a422bdb4 by Zubin Duggal at 2026-05-19T18:32:23+05:30 rts: Retry SIGPIPE delivery for interruptible FFI calls (#27113) Closes a race in the threaded RTS where a SIGPIPE fired by throwTo to cancel an interruptible foreign call may land in the user-space prologue of the FFI wrapper, between suspendThread releasing the capability and the kernel syscall starting. GHC's empty SIGPIPE handler swallows the signal and the syscall then blocks forever. - - - - - 11 changed files: - rts/RaiseAsync.c - rts/Schedule.c - rts/Schedule.h - rts/Task.c - rts/Task.h - rts/Timer.c - testsuite/tests/concurrent/should_run/T27113.hs - testsuite/tests/concurrent/should_run/T27113_c.c - + testsuite/tests/concurrent/should_run/T27113b.hs - + testsuite/tests/concurrent/should_run/T27113c.hs - testsuite/tests/concurrent/should_run/all.T Changes: ===================================== rts/RaiseAsync.c ===================================== @@ -36,6 +36,11 @@ static void throwToSendMsg (Capability *cap USED_IF_THREADS, Capability *target_cap USED_IF_THREADS, MessageThrowTo *msg USED_IF_THREADS); +#if defined(THREADED_RTS) +static void clear_interrupt_pending_if_no_live_throw (Capability *cap, + StgTSO *target); +#endif + /* ----------------------------------------------------------------------------- throwToSingleThreaded @@ -338,7 +343,14 @@ check_target: } // nobody else can wake up this TSO after we claim the message +#if defined(THREADED_RTS) + // #27113: snapshot m->target before doneWithMsgThrowTo nulls m. + StgTSO *m_target = m->target; +#endif doneWithMsgThrowTo(cap, m); +#if defined(THREADED_RTS) + clear_interrupt_pending_if_no_live_throw(cap, m_target); +#endif raiseAsync(cap, target, msg->exception, false, NULL); return THROWTO_SUCCESS; @@ -433,11 +445,12 @@ check_target: #if defined(THREADED_RTS) { Task *task = NULL; - // walk suspended_ccalls to find the correct worker thread + InCall *target_incall = NULL; InCall *incall; for (incall = cap->suspended_ccalls; incall != NULL; incall = incall->next) { if (incall->suspended_tso == target) { task = incall->task; + target_incall = incall; break; } } @@ -446,6 +459,8 @@ check_target: if (!((target->flags & TSO_BLOCKEX) && ((target->flags & TSO_INTERRUPTIBLE) == 0))) { interruptWorkerTask(task); + // #27113: ticker re-fires interruptOSThread while this is set. + RELEASE_STORE(&target_incall->interrupt_pending, 1); } return THROWTO_BLOCKED; } else { @@ -511,6 +526,9 @@ throwToSendMsg (Capability *cap STG_UNUSED, // Block a throwTo message on the target TSO's blocked_exceptions // queue. The current Capability must own the target TSO in order to // modify the blocked_exceptions queue. +// +// #27113: cap->lock serialises the queue mutation with the cross-cap revoke +// walk in clear_interrupt_pending_if_no_live_throw. void blockedThrowTo (Capability *cap, StgTSO *target, MessageThrowTo *msg) { @@ -520,8 +538,14 @@ blockedThrowTo (Capability *cap, StgTSO *target, MessageThrowTo *msg) ASSERT(target->cap == cap); dirty_TSO(cap,target); // we will modify the blocked_exceptions queue +#if defined(THREADED_RTS) + ACQUIRE_LOCK(&cap->lock); +#endif msg->link = target->blocked_exceptions; - target->blocked_exceptions = msg; + RELEASE_STORE(&target->blocked_exceptions, msg); +#if defined(THREADED_RTS) + RELEASE_LOCK(&cap->lock); +#endif } /* ----------------------------------------------------------------------------- @@ -581,6 +605,8 @@ maybePerformBlockedException (Capability *cap, StgTSO *tso) throwToSingleThreaded(cap, msg->target, msg->exception); source = msg->source; + // #27113: msg->target == tso; its own resumeThread already cleared + // (or is about to clear) interrupt_pending, so no helper call here. doneWithMsgThrowTo(cap, msg); tryWakeupThread(cap, source); return 1; @@ -603,6 +629,7 @@ awakenBlockedExceptionQueue (Capability *cap, StgTSO *tso) i = lockClosure((StgClosure *)msg); if (i != &stg_MSG_NULL_info) { source = msg->source; + // #27113: msg->target == tso; its own resumeThread clears the flag. doneWithMsgThrowTo(cap, msg); tryWakeupThread(cap, source); } else { @@ -664,6 +691,54 @@ removeFromMVarBlockedQueue (StgTSO *tso) tso->_link = END_TSO_QUEUE; } +#if defined(THREADED_RTS) +// #27113: clear an interruptible-FFI target's interrupt_pending flag once +// a revoke leaves no live (non-MSG_NULL) entry on its blocked_exceptions +// queue. target->cap is stable while target is suspended in an interruptible +// FFI call (no migration off the run queue), so the InCall lives on +// target_cap->suspended_ccalls. target_cap->lock is taken unconditionally: +// it serialises us with blockedThrowTo, suspendThread's re-arm, and +// resumeThread's unlink — and also with the ticker's TRY_ACQUIRE_LOCK, so +// the clear is not raced by a ticker reading the pre-clear flag. +static void +clear_interrupt_pending_if_no_live_throw (Capability *cap, StgTSO *target) +{ + if (target == NULL) return; + if (ACQUIRE_LOAD(&target->why_blocked) != BlockedOnCCall_Interruptible) + return; + + Capability *target_cap = ACQUIRE_LOAD(&target->cap); + ACQUIRE_LOCK(&target_cap->lock); + + // Find the InCall on target_cap. If target has already resumed (or + // wasn't really suspended on this cap), do nothing. + InCall *found = NULL; + for (InCall *ic = target_cap->suspended_ccalls; ic != NULL; ic = ic->next) { + if (ic->suspended_tso == target) { found = ic; break; } + } + if (found == NULL) { + RELEASE_LOCK(&target_cap->lock); + return; + } + + bool live = false; + for (MessageThrowTo *t = ACQUIRE_LOAD(&target->blocked_exceptions); + t != END_BLOCKED_EXCEPTIONS_QUEUE; + t = (MessageThrowTo*)t->link) { + if (RELAXED_LOAD((StgWord*)&t->header.info) + != (StgWord)&stg_MSG_NULL_info) { + live = true; break; + } + } + if (!live) { + RELEASE_STORE(&found->interrupt_pending, 0); + } + + RELEASE_LOCK(&target_cap->lock); + (void)cap; +} +#endif + static void removeFromQueues(Capability *cap, StgTSO *tso) { @@ -699,8 +774,17 @@ removeFromQueues(Capability *cap, StgTSO *tso) // capabilities. // ASSERT(m->header.info == &stg_WHITEHOLE_info); +#if defined(THREADED_RTS) + // #27113: snapshot m->target before doneWithMsgThrowTo nulls m. + StgTSO *m_target = m->target; +#endif + // unlock and revoke it at the same time doneWithMsgThrowTo(cap, m); + +#if defined(THREADED_RTS) + clear_interrupt_pending_if_no_live_throw(cap, m_target); +#endif break; } ===================================== rts/Schedule.c ===================================== @@ -2536,6 +2536,30 @@ suspendThread (StgRegTable *reg, bool interruptible) suspendTask(cap,task); cap->in_haskell = false; + +#if defined(THREADED_RTS) + // #27113: re-arm interrupt_pending if entering an interruptible call with + // a live throw already queued. Covers under-mask EINTR-retry: throwToMsg + // set the flag, resumeThread cleared it, and we're now re-entering pause. + // Under cap->lock, after suspendTask, so the scan and store are serialised + // with the revoke walk. + if (interruptible + && !((tso->flags & TSO_BLOCKEX) && + ((tso->flags & TSO_INTERRUPTIBLE) == 0))) { + MessageThrowTo *head = ACQUIRE_LOAD(&tso->blocked_exceptions); + bool live = false; + for (MessageThrowTo *m = head; + m != END_BLOCKED_EXCEPTIONS_QUEUE; + m = (MessageThrowTo*)m->link) { + if (RELAXED_LOAD((StgWord*)&m->header.info) + != (StgWord)&stg_MSG_NULL_info) { live = true; break; } + } + if (live) { + RELEASE_STORE(&task->incall->interrupt_pending, 1); + } + } +#endif + releaseCapability_(cap,false); RELEASE_LOCK(&cap->lock); @@ -2574,8 +2598,14 @@ resumeThread (void *task_) // entry on the suspended_ccalls list will also have been // migrated. - // Remove the thread from the suspended list + // #27113: clear interrupt_pending and unlink under cap->lock so the + // ticker's TRY_ACQUIRE_LOCK serialises with us. Without the lock, the + // ticker can read a stale flag and SIGPIPE the worker after it has + // already returned from the FFI call onto an unrelated syscall. + ACQUIRE_LOCK(&cap->lock); + RELEASE_STORE(&incall->interrupt_pending, 0); recoverSuspendedTask(cap,task); + RELEASE_LOCK(&cap->lock); tso = incall->suspended_tso; incall->suspended_tso = NULL; @@ -2614,6 +2644,49 @@ resumeThread (void *task_) return &cap->r; } +#if defined(THREADED_RTS) +// #27113: re-fire interruptOSThread for InCalls whose interrupt_pending is +// still set. Reads only InCall fields, never TSO heap state, so no GC race. +// +// cap->lock is held across the OS interrupt call. This pairs with the +// same lock taken by resumeThread around its clear+unlink: when we fire +// interruptOSThread, resumeThread is either blocked behind us on the lock +// (signal lands harmlessly on a thread inside pthread sync) or has not yet +// run (signal lands inside the FFI call where it belongs). Releasing the +// lock before signalling would let resumeThread complete and re-enter +// Haskell first, so SIGPIPE / CancelSynchronousIo would hit an unrelated +// later syscall. +// +// The per-OS-call cost is small (~µs for pthread_kill on POSIX, ~tens of +// µs for OpenThread+CancelSynchronousIo+CloseHandle on Windows), but the +// per-tick lock-hold time scales linearly with the number of pending +// interruptible calls on this cap. For typical workloads this is well +// below the tick interval; FFI-heavy workloads with many concurrent +// interruptible calls per cap may want empirical measurement. +void +retryInterruptibleSignals(void) +{ + bool any_pending = false; + uint32_t n = getNumCapabilities(); + for (uint32_t i = 0; i < n; i++) { + Capability *cap = getCapability(i); + if (RELAXED_LOAD(&cap->n_suspended_ccalls) == 0) continue; + if (TRY_ACQUIRE_LOCK(&cap->lock) != 0) continue; + for (InCall *ic = cap->suspended_ccalls; ic != NULL; ic = ic->next) { + if (ACQUIRE_LOAD(&ic->interrupt_pending) == 0) continue; + // ic->task is set by newInCall and never cleared. + if (ic->task != NULL) { + any_pending = true; + interruptOSThread(ic->task->id); + } + } + RELEASE_LOCK(&cap->lock); + } + // Keep the timer alive; handle_tick's idle path would otherwise stop it. + if (any_pending) setRecentActivity(ACTIVITY_YES); +} +#endif + /* --------------------------------------------------------------------------- * scheduleThread() * ===================================== rts/Schedule.h ===================================== @@ -43,6 +43,10 @@ void scheduleThreadOn(Capability *cap, StgWord cpu, StgTSO *tso); void wakeUpRts(void); #endif +#if defined(THREADED_RTS) +void retryInterruptibleSignals(void); +#endif + /* raiseExceptionHelper */ StgWord raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception); ===================================== rts/Task.c ===================================== @@ -267,6 +267,7 @@ newInCall (Task *task) incall->next = NULL; incall->prev = NULL; incall->prev_stack = task->incall; + incall->interrupt_pending = 0; task->incall = incall; } ===================================== rts/Task.h ===================================== @@ -106,6 +106,15 @@ typedef struct InCall_ { // Links InCalls onto suspended_ccalls, spare_incalls struct InCall_ *prev; struct InCall_ *next; + + // #27113. Set (atomically) by throwToMsg once it has fired + // interruptOSThread for this call's worker; cleared by resumeThread + // (when the call returns) and by the revoke paths in + // doneWithMsgThrowTo (when all queued throws against the target are + // MSG_NULL). The ticker reads this and re-fires interruptOSThread + // while it is set. Not GC-managed — lives in malloc'd memory with + // the Task that owns this InCall. + StgWord interrupt_pending; } InCall; typedef struct Task_ { ===================================== rts/Timer.c ===================================== @@ -131,6 +131,11 @@ handle_tick(int unused STG_UNUSED) flushEventLog(NULL); } } + // #27113 retry; gated on timer_disabled like the context-switch path + // above so that setNumCapabilities's resize pause is respected (#17289). + if (SEQ_CST_LOAD_ALWAYS(&timer_disabled) == 0) { + retryInterruptibleSignals(); + } #endif /* ===================================== testsuite/tests/concurrent/should_run/T27113.hs ===================================== @@ -10,7 +10,7 @@ import System.IO import System.Timeout foreign import ccall interruptible "cpu_then_pause" - c_cpu_then_pause :: CLong -> IO () + c_cpu_then_pause :: CLLong -> IO () killDelay :: Int killDelay = 200_000 @@ -18,7 +18,7 @@ killDelay = 200_000 joinTimeout :: Int joinTimeout = 3_000_000 -runCase :: String -> CLong -> IO () +runCase :: String -> CLLong -> IO () runCase name spinNs = do tid <- forkIO $ c_cpu_then_pause spinNs ===================================== testsuite/tests/concurrent/should_run/T27113_c.c ===================================== @@ -1,17 +1,18 @@ #include <errno.h> +#include <stdint.h> #include <time.h> #include <unistd.h> -static long now_ns(void) { +static int64_t now_ns(void) { struct timespec t; while (clock_gettime(CLOCK_MONOTONIC, &t) != 0) { if (errno != EINTR) return 0; } - return (long)t.tv_sec * 1000000000L + (long)t.tv_nsec; + return (int64_t)t.tv_sec * 1000000000LL + (int64_t)t.tv_nsec; } -int cpu_then_pause(long spin_ns) { - long deadline = now_ns() + spin_ns; +int cpu_then_pause(int64_t spin_ns) { + int64_t deadline = now_ns() + spin_ns; while (now_ns() < deadline) { } return pause(); ===================================== testsuite/tests/concurrent/should_run/T27113b.hs ===================================== @@ -0,0 +1,48 @@ +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Foreign.C.Types +import System.IO +import System.Timeout + +foreign import ccall interruptible "cpu_then_pause" + c_cpu_then_pause :: CLLong -> IO () + +-- Recommended pattern: under mask, with allowInterrupt as the explicit +-- interruption point. After a SIGPIPE-driven pause EINTR, control +-- returns to Haskell still under mask, so the queued throw isn't +-- delivered until allowInterrupt. For the kill to complete, the SIGPIPE +-- retry must fire when the initial SIGPIPE is lost in the user-space +-- prologue (the spin loop) — otherwise pause blocks forever and +-- killThread hangs. +myCall :: CLLong -> IO () +myCall spinNs = mask_ $ do + allowInterrupt + c_cpu_then_pause spinNs + allowInterrupt + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + started <- newEmptyMVar + done <- newEmptyMVar + -- mask_ around the forkIOWithUnmask ensures the child inherits + -- MaskedInterruptible, so finally is set up before our killThread + -- below can be delivered. + tid <- mask_ $ forkIOWithUnmask $ \unmask -> + flip finally (putMVar done ()) $ do + putMVar started () + unmask (myCall 2_000_000_000) + `catch` (\(_ :: SomeException) -> return ()) + takeMVar started + threadDelay 200_000 + result <- timeout 5_000_000 (killThread tid >> takeMVar done) + case result of + Just () -> putStrLn "ok" + Nothing -> do + hPutStrLn stderr "FAIL: killThread hung" + error "hung" ===================================== testsuite/tests/concurrent/should_run/T27113c.hs ===================================== @@ -0,0 +1,63 @@ +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.IORef +import Foreign.C.Types +import System.Exit +import System.IO + +foreign import ccall interruptible "pause" c_pause :: IO CInt + +postRevokeWindow :: Int +postRevokeWindow = 2_000_000 + +postRevokeThreshold :: Int +postRevokeThreshold = 5 + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + iters <- newIORef (0 :: Int) + + workerStarted <- newEmptyMVar + worker <- forkIO $ mask_ $ do + putMVar workerStarted () + (forever $ do + atomicModifyIORef' iters (\n -> (n + 1, ())) + _ <- c_pause + return ()) + `catch` (\(_ :: SomeException) -> return ()) + + takeMVar workerStarted + threadDelay 100_000 + + killer1Ready <- newEmptyMVar + killer1 <- forkIO $ do + putMVar killer1Ready () + killThread worker + + takeMVar killer1Ready + threadDelay 100_000 + + preRevoke <- readIORef iters + + killThread killer1 + + threadDelay postRevokeWindow + + postRevoke <- readIORef iters + let storm = postRevoke - preRevoke + if storm > postRevokeThreshold + then do + hPutStrLn stderr ("FAIL: post-revoke EINTR storm, iterations=" + ++ show storm + ++ " (pre=" ++ show preRevoke + ++ " post=" ++ show postRevoke ++ ")") + exitFailure + else + putStrLn ("ok (post-revoke iterations=" ++ show storm ++ ")") ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -208,11 +208,24 @@ test('foreignInterruptible', [when(fast(), skip), test('T27113', [when(opsys('mingw32'), skip), + only_threaded_ways, + req_c], + compile_and_run, ['T27113_c.c']) + +test('T27113b', + [extra_files(['T27113_c.c']), + when(opsys('mingw32'), skip), only_threaded_ways, req_c, - expect_broken(27113)], + ignore_stdout], compile_and_run, ['T27113_c.c']) +test('T27113c', + [when(opsys('mingw32'), skip), + only_threaded_ways, + ignore_stdout], + compile_and_run, ['']) + test('conc037', only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), compile_and_run, ['']) test('conc038', only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a422bdb48a8c34bf44de8d70859ee48… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a422bdb48a8c34bf44de8d70859ee48… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/27113-retry] rts: Retry SIGPIPE delivery for interruptible FFI calls (#27113)
by Zubin (＠wz1000) 19 May '26

19 May '26

Zubin pushed to branch wip/27113-retry at Glasgow Haskell Compiler / GHC Commits: dc4d1c48 by Zubin Duggal at 2026-05-19T18:21:00+05:30 rts: Retry SIGPIPE delivery for interruptible FFI calls (#27113) Closes a race in the threaded RTS where a SIGPIPE fired by throwTo to cancel an interruptible foreign call may land in the user-space prologue of the FFI wrapper, between suspendThread releasing the capability and the kernel syscall starting. GHC's empty SIGPIPE handler swallows the signal and the syscall then blocks forever. The original retry implementation walked cap->suspended_ccalls from the ticker and read TSO heap fields (why_blocked, blocked_exceptions, flags) to decide whether to re-fire interruptOSThread. Review (review.md) identified two real bugs in that design: H1. TSO reads from outside cap ownership race with moving GC's evacuation of suspended_ccalls TSOs and with descheduling between the load of incall->suspended_tso and the subsequent field reads. Spurious-driven SIGPIPE EINTRs unrelated unsafe syscalls on the same OS thread once the worker has moved on. H2. blocked_exceptions \!= END is not a live-throw predicate. A MessageThrowTo overwritten with MSG_NULL by doneWithMsgThrowTo persists on the queue under mask_, causing an EINTR storm in throwErrnoIfMinus1Retry-style wrappers. This commit reworks the fix to address both: * A per-InCall atomic flag `interrupt_pending` is set by throwToMsg after it fires interruptOSThread and cleared by resumeThread (before recoverSuspendedTask, so the ticker cannot observe a stale set flag after the InCall has been unlinked). * throwToMsg's BlockedOnCCall_Interruptible search is extended to walk every capability's suspended_ccalls (under cap->lock), so the flag is set even when the target migrated to a different cap from the throwing thread. * doneWithMsgThrowTo's revoke path (removeFromQueues') re-scans the target's blocked_exceptions for any non-MSG_NULL entries; if none remain, clears the InCall's interrupt_pending so the retry stops. Fixes H2. * The ticker now reads only InCall fields (interrupt_pending, task->id) — never TSO heap state — and fires interruptOSThread while interrupt_pending is set. Fixes H1. * The retry hook in handle_tick is gated on timer_disabled, matching the context-switch path (review M1). * T27113_c.c switched to int64_t to avoid 32-bit `long` overflow on 32-bit POSIX (review L1). * Adds T27113c, a regression test for H2: a MessageThrowTo against an interruptible-FFI target is revoked (via killing the throwing thread), and the target's masked EINTR-retry loop is checked for forward progress (no EINTR storm). Build: T27113 and T27113c pass on ghci/threaded1/threaded2 ways; no regressions in conc014/015/015a/016/017/017a/058/foreignInterruptible on threaded2. - - - - - 11 changed files: - rts/RaiseAsync.c - rts/Schedule.c - rts/Schedule.h - rts/Task.c - rts/Task.h - rts/Timer.c - testsuite/tests/concurrent/should_run/T27113.hs - testsuite/tests/concurrent/should_run/T27113_c.c - + testsuite/tests/concurrent/should_run/T27113b.hs - + testsuite/tests/concurrent/should_run/T27113c.hs - testsuite/tests/concurrent/should_run/all.T Changes: ===================================== rts/RaiseAsync.c ===================================== @@ -36,6 +36,11 @@ static void throwToSendMsg (Capability *cap USED_IF_THREADS, Capability *target_cap USED_IF_THREADS, MessageThrowTo *msg USED_IF_THREADS); +#if defined(THREADED_RTS) +static void clear_interrupt_pending_if_no_live_throw (Capability *cap, + StgTSO *target); +#endif + /* ----------------------------------------------------------------------------- throwToSingleThreaded @@ -338,7 +343,14 @@ check_target: } // nobody else can wake up this TSO after we claim the message +#if defined(THREADED_RTS) + // #27113: snapshot m->target before doneWithMsgThrowTo nulls m. + StgTSO *m_target = m->target; +#endif doneWithMsgThrowTo(cap, m); +#if defined(THREADED_RTS) + clear_interrupt_pending_if_no_live_throw(cap, m_target); +#endif raiseAsync(cap, target, msg->exception, false, NULL); return THROWTO_SUCCESS; @@ -433,11 +445,12 @@ check_target: #if defined(THREADED_RTS) { Task *task = NULL; - // walk suspended_ccalls to find the correct worker thread + InCall *target_incall = NULL; InCall *incall; for (incall = cap->suspended_ccalls; incall != NULL; incall = incall->next) { if (incall->suspended_tso == target) { task = incall->task; + target_incall = incall; break; } } @@ -446,6 +459,8 @@ check_target: if (!((target->flags & TSO_BLOCKEX) && ((target->flags & TSO_INTERRUPTIBLE) == 0))) { interruptWorkerTask(task); + // #27113: ticker re-fires interruptOSThread while this is set. + RELEASE_STORE(&target_incall->interrupt_pending, 1); } return THROWTO_BLOCKED; } else { @@ -511,6 +526,9 @@ throwToSendMsg (Capability *cap STG_UNUSED, // Block a throwTo message on the target TSO's blocked_exceptions // queue. The current Capability must own the target TSO in order to // modify the blocked_exceptions queue. +// +// #27113: cap->lock serialises the queue mutation with the cross-cap revoke +// walk in clear_interrupt_pending_if_no_live_throw. void blockedThrowTo (Capability *cap, StgTSO *target, MessageThrowTo *msg) { @@ -520,8 +538,14 @@ blockedThrowTo (Capability *cap, StgTSO *target, MessageThrowTo *msg) ASSERT(target->cap == cap); dirty_TSO(cap,target); // we will modify the blocked_exceptions queue +#if defined(THREADED_RTS) + ACQUIRE_LOCK(&cap->lock); +#endif msg->link = target->blocked_exceptions; - target->blocked_exceptions = msg; + RELEASE_STORE(&target->blocked_exceptions, msg); +#if defined(THREADED_RTS) + RELEASE_LOCK(&cap->lock); +#endif } /* ----------------------------------------------------------------------------- @@ -581,6 +605,8 @@ maybePerformBlockedException (Capability *cap, StgTSO *tso) throwToSingleThreaded(cap, msg->target, msg->exception); source = msg->source; + // #27113: msg->target == tso; its own resumeThread already cleared + // (or is about to clear) interrupt_pending, so no helper call here. doneWithMsgThrowTo(cap, msg); tryWakeupThread(cap, source); return 1; @@ -603,6 +629,7 @@ awakenBlockedExceptionQueue (Capability *cap, StgTSO *tso) i = lockClosure((StgClosure *)msg); if (i != &stg_MSG_NULL_info) { source = msg->source; + // #27113: msg->target == tso; its own resumeThread clears the flag. doneWithMsgThrowTo(cap, msg); tryWakeupThread(cap, source); } else { @@ -664,6 +691,54 @@ removeFromMVarBlockedQueue (StgTSO *tso) tso->_link = END_TSO_QUEUE; } +#if defined(THREADED_RTS) +// #27113: clear an interruptible-FFI target's interrupt_pending flag once +// a revoke leaves no live (non-MSG_NULL) entry on its blocked_exceptions +// queue. target->cap is stable while target is suspended in an interruptible +// FFI call (no migration off the run queue), so the InCall lives on +// target_cap->suspended_ccalls. target_cap->lock is taken unconditionally: +// it serialises us with blockedThrowTo, suspendThread's re-arm, and +// resumeThread's unlink — and also with the ticker's TRY_ACQUIRE_LOCK, so +// the clear is not raced by a ticker reading the pre-clear flag. +static void +clear_interrupt_pending_if_no_live_throw (Capability *cap, StgTSO *target) +{ + if (target == NULL) return; + if (ACQUIRE_LOAD(&target->why_blocked) != BlockedOnCCall_Interruptible) + return; + + Capability *target_cap = ACQUIRE_LOAD(&target->cap); + ACQUIRE_LOCK(&target_cap->lock); + + // Find the InCall on target_cap. If target has already resumed (or + // wasn't really suspended on this cap), do nothing. + InCall *found = NULL; + for (InCall *ic = target_cap->suspended_ccalls; ic != NULL; ic = ic->next) { + if (ic->suspended_tso == target) { found = ic; break; } + } + if (found == NULL) { + RELEASE_LOCK(&target_cap->lock); + return; + } + + bool live = false; + for (MessageThrowTo *t = ACQUIRE_LOAD(&target->blocked_exceptions); + t != END_BLOCKED_EXCEPTIONS_QUEUE; + t = (MessageThrowTo*)t->link) { + if (RELAXED_LOAD((StgWord*)&t->header.info) + != (StgWord)&stg_MSG_NULL_info) { + live = true; break; + } + } + if (!live) { + RELEASE_STORE(&found->interrupt_pending, 0); + } + + RELEASE_LOCK(&target_cap->lock); + (void)cap; +} +#endif + static void removeFromQueues(Capability *cap, StgTSO *tso) { @@ -699,8 +774,17 @@ removeFromQueues(Capability *cap, StgTSO *tso) // capabilities. // ASSERT(m->header.info == &stg_WHITEHOLE_info); +#if defined(THREADED_RTS) + // #27113: snapshot m->target before doneWithMsgThrowTo nulls m. + StgTSO *m_target = m->target; +#endif + // unlock and revoke it at the same time doneWithMsgThrowTo(cap, m); + +#if defined(THREADED_RTS) + clear_interrupt_pending_if_no_live_throw(cap, m_target); +#endif break; } ===================================== rts/Schedule.c ===================================== @@ -2536,6 +2536,30 @@ suspendThread (StgRegTable *reg, bool interruptible) suspendTask(cap,task); cap->in_haskell = false; + +#if defined(THREADED_RTS) + // #27113: re-arm interrupt_pending if entering an interruptible call with + // a live throw already queued. Covers under-mask EINTR-retry: throwToMsg + // set the flag, resumeThread cleared it, and we're now re-entering pause. + // Under cap->lock, after suspendTask, so the scan and store are serialised + // with the revoke walk. + if (interruptible + && !((tso->flags & TSO_BLOCKEX) && + ((tso->flags & TSO_INTERRUPTIBLE) == 0))) { + MessageThrowTo *head = ACQUIRE_LOAD(&tso->blocked_exceptions); + bool live = false; + for (MessageThrowTo *m = head; + m != END_BLOCKED_EXCEPTIONS_QUEUE; + m = (MessageThrowTo*)m->link) { + if (RELAXED_LOAD((StgWord*)&m->header.info) + != (StgWord)&stg_MSG_NULL_info) { live = true; break; } + } + if (live) { + RELEASE_STORE(&task->incall->interrupt_pending, 1); + } + } +#endif + releaseCapability_(cap,false); RELEASE_LOCK(&cap->lock); @@ -2574,8 +2598,14 @@ resumeThread (void *task_) // entry on the suspended_ccalls list will also have been // migrated. - // Remove the thread from the suspended list + // #27113: clear interrupt_pending and unlink under cap->lock so the + // ticker's TRY_ACQUIRE_LOCK serialises with us. Without the lock, the + // ticker can read a stale flag and SIGPIPE the worker after it has + // already returned from the FFI call onto an unrelated syscall. + ACQUIRE_LOCK(&cap->lock); + RELEASE_STORE(&incall->interrupt_pending, 0); recoverSuspendedTask(cap,task); + RELEASE_LOCK(&cap->lock); tso = incall->suspended_tso; incall->suspended_tso = NULL; @@ -2614,6 +2644,49 @@ resumeThread (void *task_) return &cap->r; } +#if defined(THREADED_RTS) +// #27113: re-fire interruptOSThread for InCalls whose interrupt_pending is +// still set. Reads only InCall fields, never TSO heap state, so no GC race. +// +// cap->lock is held across the OS interrupt call. This pairs with the +// same lock taken by resumeThread around its clear+unlink: when we fire +// interruptOSThread, resumeThread is either blocked behind us on the lock +// (signal lands harmlessly on a thread inside pthread sync) or has not yet +// run (signal lands inside the FFI call where it belongs). Releasing the +// lock before signalling would let resumeThread complete and re-enter +// Haskell first, so SIGPIPE / CancelSynchronousIo would hit an unrelated +// later syscall. +// +// The per-OS-call cost is small (~µs for pthread_kill on POSIX, ~tens of +// µs for OpenThread+CancelSynchronousIo+CloseHandle on Windows), but the +// per-tick lock-hold time scales linearly with the number of pending +// interruptible calls on this cap. For typical workloads this is well +// below the tick interval; FFI-heavy workloads with many concurrent +// interruptible calls per cap may want empirical measurement. +void +retryInterruptibleSignals(void) +{ + bool any_pending = false; + uint32_t n = getNumCapabilities(); + for (uint32_t i = 0; i < n; i++) { + Capability *cap = getCapability(i); + if (RELAXED_LOAD(&cap->n_suspended_ccalls) == 0) continue; + if (TRY_ACQUIRE_LOCK(&cap->lock) != 0) continue; + for (InCall *ic = cap->suspended_ccalls; ic != NULL; ic = ic->next) { + if (ACQUIRE_LOAD(&ic->interrupt_pending) == 0) continue; + // ic->task is set by newInCall and never cleared. + if (ic->task != NULL) { + any_pending = true; + interruptOSThread(ic->task->id); + } + } + RELEASE_LOCK(&cap->lock); + } + // Keep the timer alive; handle_tick's idle path would otherwise stop it. + if (any_pending) setRecentActivity(ACTIVITY_YES); +} +#endif + /* --------------------------------------------------------------------------- * scheduleThread() * ===================================== rts/Schedule.h ===================================== @@ -43,6 +43,10 @@ void scheduleThreadOn(Capability *cap, StgWord cpu, StgTSO *tso); void wakeUpRts(void); #endif +#if defined(THREADED_RTS) +void retryInterruptibleSignals(void); +#endif + /* raiseExceptionHelper */ StgWord raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception); ===================================== rts/Task.c ===================================== @@ -267,6 +267,7 @@ newInCall (Task *task) incall->next = NULL; incall->prev = NULL; incall->prev_stack = task->incall; + incall->interrupt_pending = 0; task->incall = incall; } ===================================== rts/Task.h ===================================== @@ -106,6 +106,15 @@ typedef struct InCall_ { // Links InCalls onto suspended_ccalls, spare_incalls struct InCall_ *prev; struct InCall_ *next; + + // #27113. Set (atomically) by throwToMsg once it has fired + // interruptOSThread for this call's worker; cleared by resumeThread + // (when the call returns) and by the revoke paths in + // doneWithMsgThrowTo (when all queued throws against the target are + // MSG_NULL). The ticker reads this and re-fires interruptOSThread + // while it is set. Not GC-managed — lives in malloc'd memory with + // the Task that owns this InCall. + StgWord interrupt_pending; } InCall; typedef struct Task_ { ===================================== rts/Timer.c ===================================== @@ -131,6 +131,11 @@ handle_tick(int unused STG_UNUSED) flushEventLog(NULL); } } + // #27113 retry; gated on timer_disabled like the context-switch path + // above so that setNumCapabilities's resize pause is respected (#17289). + if (SEQ_CST_LOAD_ALWAYS(&timer_disabled) == 0) { + retryInterruptibleSignals(); + } #endif /* ===================================== testsuite/tests/concurrent/should_run/T27113.hs ===================================== @@ -10,7 +10,7 @@ import System.IO import System.Timeout foreign import ccall interruptible "cpu_then_pause" - c_cpu_then_pause :: CLong -> IO () + c_cpu_then_pause :: CLLong -> IO () killDelay :: Int killDelay = 200_000 @@ -18,7 +18,7 @@ killDelay = 200_000 joinTimeout :: Int joinTimeout = 3_000_000 -runCase :: String -> CLong -> IO () +runCase :: String -> CLLong -> IO () runCase name spinNs = do tid <- forkIO $ c_cpu_then_pause spinNs ===================================== testsuite/tests/concurrent/should_run/T27113_c.c ===================================== @@ -1,17 +1,18 @@ #include <errno.h> +#include <stdint.h> #include <time.h> #include <unistd.h> -static long now_ns(void) { +static int64_t now_ns(void) { struct timespec t; while (clock_gettime(CLOCK_MONOTONIC, &t) != 0) { if (errno != EINTR) return 0; } - return (long)t.tv_sec * 1000000000L + (long)t.tv_nsec; + return (int64_t)t.tv_sec * 1000000000LL + (int64_t)t.tv_nsec; } -int cpu_then_pause(long spin_ns) { - long deadline = now_ns() + spin_ns; +int cpu_then_pause(int64_t spin_ns) { + int64_t deadline = now_ns() + spin_ns; while (now_ns() < deadline) { } return pause(); ===================================== testsuite/tests/concurrent/should_run/T27113b.hs ===================================== @@ -0,0 +1,48 @@ +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Foreign.C.Types +import System.IO +import System.Timeout + +foreign import ccall interruptible "cpu_then_pause" + c_cpu_then_pause :: CLLong -> IO () + +-- Recommended pattern: under mask, with allowInterrupt as the explicit +-- interruption point. After a SIGPIPE-driven pause EINTR, control +-- returns to Haskell still under mask, so the queued throw isn't +-- delivered until allowInterrupt. For the kill to complete, the SIGPIPE +-- retry must fire when the initial SIGPIPE is lost in the user-space +-- prologue (the spin loop) — otherwise pause blocks forever and +-- killThread hangs. +myCall :: CLLong -> IO () +myCall spinNs = mask_ $ do + allowInterrupt + c_cpu_then_pause spinNs + allowInterrupt + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + started <- newEmptyMVar + done <- newEmptyMVar + -- mask_ around the forkIOWithUnmask ensures the child inherits + -- MaskedInterruptible, so finally is set up before our killThread + -- below can be delivered. + tid <- mask_ $ forkIOWithUnmask $ \unmask -> + flip finally (putMVar done ()) $ do + putMVar started () + unmask (myCall 2_000_000_000) + `catch` (\(_ :: SomeException) -> return ()) + takeMVar started + threadDelay 200_000 + result <- timeout 5_000_000 (killThread tid >> takeMVar done) + case result of + Just () -> putStrLn "ok" + Nothing -> do + hPutStrLn stderr "FAIL: killThread hung" + error "hung" ===================================== testsuite/tests/concurrent/should_run/T27113c.hs ===================================== @@ -0,0 +1,63 @@ +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.IORef +import Foreign.C.Types +import System.Exit +import System.IO + +foreign import ccall interruptible "pause" c_pause :: IO CInt + +postRevokeWindow :: Int +postRevokeWindow = 2_000_000 + +postRevokeThreshold :: Int +postRevokeThreshold = 5 + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + iters <- newIORef (0 :: Int) + + workerStarted <- newEmptyMVar + worker <- forkIO $ mask_ $ do + putMVar workerStarted () + (forever $ do + atomicModifyIORef' iters (\n -> (n + 1, ())) + _ <- c_pause + return ()) + `catch` (\(_ :: SomeException) -> return ()) + + takeMVar workerStarted + threadDelay 100_000 + + killer1Ready <- newEmptyMVar + killer1 <- forkIO $ do + putMVar killer1Ready () + killThread worker + + takeMVar killer1Ready + threadDelay 100_000 + + preRevoke <- readIORef iters + + killThread killer1 + + threadDelay postRevokeWindow + + postRevoke <- readIORef iters + let storm = postRevoke - preRevoke + if storm > postRevokeThreshold + then do + hPutStrLn stderr ("FAIL: post-revoke EINTR storm, iterations=" + ++ show storm + ++ " (pre=" ++ show preRevoke + ++ " post=" ++ show postRevoke ++ ")") + exitFailure + else + putStrLn ("ok (post-revoke iterations=" ++ show storm ++ ")") ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -208,11 +208,24 @@ test('foreignInterruptible', [when(fast(), skip), test('T27113', [when(opsys('mingw32'), skip), + only_threaded_ways, + req_c], + compile_and_run, ['T27113_c.c']) + +test('T27113b', + [extra_files(['T27113_c.c']), + when(opsys('mingw32'), skip), only_threaded_ways, req_c, - expect_broken(27113)], + ignore_stdout], compile_and_run, ['T27113_c.c']) +test('T27113c', + [when(opsys('mingw32'), skip), + only_threaded_ways, + ignore_stdout], + compile_and_run, ['']) + test('conc037', only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), compile_and_run, ['']) test('conc038', only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc4d1c487e66cd6c2e222b4ac9390bf… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc4d1c487e66cd6c2e222b4ac9390bf… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] 5 commits: Drop unnecessary -fdefines-known-key-names
by Rodrigo Mesquita (＠alt-romes) 19 May '26

19 May '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 76f5f329 by Rodrigo Mesquita at 2026-05-19T12:06:58+01:00 Drop unnecessary -fdefines-known-key-names - - - - - 6346d73d by Rodrigo Mesquita at 2026-05-19T13:40:39+01:00 💀 - - - - - cda7e91c by Rodrigo Mesquita at 2026-05-19T13:47:38+01:00 missing KnownOcc from Essentials - - - - - 70633b45 by Rodrigo Mesquita at 2026-05-19T13:48:24+01:00 GHCziInternalziCString -> GHCziInternalziTypes - - - - - ab374c8e by Rodrigo Mesquita at 2026-05-19T13:50:36+01:00 URec data instance fields - - - - - 9 changed files: - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/KnownOccs.hs - libraries/base/src/GHC/Essentials.hs - libraries/ghc-internal/include/RtsIfaceSymbols.h - libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs - libraries/ghc-internal/src/GHC/Internal/Control/Category.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs - libraries/ghc-internal/src/GHC/Internal/OverloadedLabels.hs Changes: ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -173,7 +173,7 @@ knownKeyTable , (mkTcOcc "Ptr", ptrTyConKey) , (mkTcOcc "FunPtr", funPtrTyConKey) - -- Class Monad, MonadFix, MonadZip + -- Class Monad , (mkTcOcc "Monad", monadClassKey) , (thenMClassOpOcc, thenMClassOpKey) , (returnMClassOpOcc, returnMClassOpKey) ===================================== compiler/GHC/Builtin/KnownOccs.hs ===================================== @@ -194,8 +194,8 @@ returnIOIdOcc = mkVarOcc "returnIO" bindIOIdOcc = mkVarOcc "bindIO" thenIOIdOcc = mkVarOcc "thenIO" printIdOcc = mkVarOcc "print" -ioTyConOcc = mkTcOcc "IO" -ioDataConOcc = mkTcOcc "IO" +ioTyConOcc = mkTcOcc "IO" +ioDataConOcc = mkDataOcc "IO" -- Enumerations enumFromClassOpOcc, enumFromThenClassOpOcc, ===================================== libraries/base/src/GHC/Essentials.hs ===================================== @@ -62,6 +62,7 @@ module GHC.Essentials , U1(..), Par1(..), Rec0, Rec1(..), K1(..), M1(..), S1, C1, D1 , V1, (:+:)(L1, R1), (:*:)((:*:)), (:.:)(Comp1, unComp1) , UAddr, UChar, UDouble, UFloat, UInt, UWord, Meta(..) + , uAddr#, uChar#, uDouble#, uFloat#, uInt#, uWord# , FixityI(..), Associativity(..), SourceUnpackedness(..), SourceStrictness(..) , DecidedStrictness(..) @@ -75,6 +76,7 @@ module GHC.Essentials -- Other data types , Either(..) , Void + , NonEmpty -- FFI , Ptr, FunPtr @@ -273,6 +275,9 @@ module GHC.Essentials , toAnnotationWrapper + -- Debug + , trace + #if defined(javascript_HOST_ARCH) -- JS primitives , unsafeUnpackJSStringUtf8## @@ -280,6 +285,7 @@ module GHC.Essentials ) where import GHC.Internal.Base hiding( foldr ) +import GHC.Internal.Debug.Trace( trace ) import GHC.Internal.Show import GHC.Internal.Read import GHC.Internal.Num ===================================== libraries/ghc-internal/include/RtsIfaceSymbols.h ===================================== @@ -57,8 +57,8 @@ CLOSURE(GHCziInternalziStackziCloneStack, StackSnapshot_closure) CLOSURE(GHCziInternalziExceptionziType, divZZeroException_closure) CLOSURE(GHCziInternalziExceptionziType, underflowException_closure) CLOSURE(GHCziInternalziExceptionziType, overflowException_closure) -INFO_TBL(GHCziInternalziCString, unpackCStringzh_info) -INFO_TBL(GHCziInternalziCString, unpackCStringUtf8zh_info) +INFO_TBL(GHCziInternalziTypes, unpackCStringzh_info) +INFO_TBL(GHCziInternalziTypes, unpackCStringUtf8zh_info) #if defined(wasm32_HOST_ARCH) && defined(__PIC__) CLOSURE(GHCziInternalziWasmziPrimziImports, raiseJSException_closure) INFO_TBL(GHCziInternalziWasmziPrimziTypes, JSVal_con_info) ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs ===================================== @@ -4,9 +4,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fdefines-known-key-names #-} - -- Defines Arrow and its methods - {-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} -- The RULES for the methods of class Arrow may never fire -- e.g. compose/arr; see #10528 ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Category.hs ===================================== @@ -3,12 +3,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PolyKinds #-} -{-# OPTIONS_GHC -fdefines-known-key-names #-} - -- Defines (>>>) -{-# OPTIONS_GHC -fexclude-known-key-define=. #-} - -- Careful! The (.) method in the Category class is not - -- the known-key name; that is in GHC.Internal.Base - {-# OPTIONS_GHC -Wno-inline-rule-shadowing #-} -- The RULES for the methods of class Category may never fire -- e.g. identity/left, identity/right, association; see #10528 ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs ===================================== @@ -1,9 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -fdefines-known-key-names #-} - -- Defines guard - ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Control.Monad ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs ===================================== @@ -2,9 +2,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fdefines-known-key-names #-} - -- Defines loop, mfix - -- For head in instance MonadFix [] {-# OPTIONS_GHC -Wno-x-partial #-} ===================================== libraries/ghc-internal/src/GHC/Internal/OverloadedLabels.hs ===================================== @@ -5,9 +5,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fdefines-known-key-names #-} - -- Defines fromLabel - ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.OverloadedLabels View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5197d507465c531cd1cd12cca45c8b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5197d507465c531cd1cd12cca45c8b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/27113
by Zubin (＠wz1000) 19 May '26

19 May '26

Zubin pushed new branch wip/27113 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/27113 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/base-buildable-with-ghc-9-14] Make `unicodeVersion` available for GHC 9.14
by Wolfgang Jeltsch (＠jeltsch) 19 May '26

19 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/base-buildable-with-ghc-9-14 at Glasgow Haskell Compiler / GHC Commits: 4b404918 by Wolfgang Jeltsch at 2026-05-19T15:35:18+03:00 Make `unicodeVersion` available for GHC 9.14 - - - - - 1 changed file: - libraries/base/src/GHC/Unicode.hs Changes: ===================================== libraries/base/src/GHC/Unicode.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS_HADDOCK not-home #-} @@ -44,4 +45,22 @@ module GHC.Unicode ) where import GHC.Internal.Unicode + +#if __GLASGOW_HASKELL__ < 914 + +#error Unknown Unicode version + +#elif __GLASGOW_HASKELL__ < 1000 + +-- | Version of Unicode standard used by @base@: +-- [17.0.0](https://www.unicode.org/versions/Unicode17.0.0/). +-- +-- @since base-4.15.0.0 +unicodeVersion :: Version +unicodeVersion = makeVersion [17, 0, 0] + +#else + import GHC.Internal.Unicode.Version + +#endif View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b404918e10366d02345cd3d4d850a0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b404918e10366d02345cd3d4d850a0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/27162/remove-hadrian-so-symlinks] Hadrian: remove legacy rts .so symlinks
by David Eichmann (＠DavidEichmann) 19 May '26

19 May '26

David Eichmann pushed to branch wip/27162/remove-hadrian-so-symlinks at Glasgow Haskell Compiler / GHC Commits: 6419a403 by Duncan Coutts at 2026-05-19T12:53:24+01:00 Hadrian: remove legacy rts .so symlinks For compatibility with the old makefile based build system, hadrian had rules to generate symlinks from unversioned to versioned names for the rts .so/.dynlib file, like libHSrts-ghcx.y.so -> libHSrts-1.0.3-ghcx.y.so We no longer need these symlinks since the makefile build system has been retired some time ago. The need for these symlinks is awkward on windows where we cannot (in practice) create symlinks. So rather than make them conditional (non-windows), just remove them entirely. - - - - - 3 changed files: - + changelog.d/rts_symlinks.md - hadrian/src/Rules/Register.hs - hadrian/src/Rules/Rts.hs Changes: ===================================== changelog.d/rts_symlinks.md ===================================== @@ -0,0 +1,11 @@ +section: packaging +issues: #27162 +mrs: !15913 +synopsis: + GHC binary distributions no longer ship with unversioned symlinks of the RTS libraries (.so/.dylib) +description: + Whith dynamic linking, an RTS with explicit version number is already linked by default e.g. + `libHSrts-1.0.3-ghc9.14.1.so`. GHC's binary distributions previously included symlinks without + an explicit RTS versions number e.g. `libHSrts-ghc9.14.1.so -> libHSrts-1.0.3-ghc9.14.1.so`. + As they are not used, such unversioned symlinks are no longer included in binary distributions. + Custom tooling that makes use of the removed symlinks, should now use the versioned file name instead. ===================================== hadrian/src/Rules/Register.hs ===================================== @@ -12,7 +12,6 @@ import Hadrian.BuildPath import Hadrian.Expression import Hadrian.Haskell.Cabal import Packages -import Rules.Rts import Settings import Target import Utilities @@ -88,14 +87,9 @@ parseToBuildSubdirectory root = do -- * Registering registerPackages :: [Context] -> Action () -registerPackages ctxs = do +registerPackages ctxs = need =<< mapM pkgRegisteredLibraryFile ctxs - -- Dynamic RTS library files need symlinks (Rules.Rts.rtsRules). - forM_ ctxs $ \ ctx -> when (package ctx == rts) $ do - ways <- interpretInContext ctx (getLibraryWays <> getRtsWays) - needRtsSymLinks (stage ctx) ways - -- | Register a package and initialise the corresponding package database if -- need be. Note that we only register packages in 'Stage0' and 'Stage1'. registerPackageRules :: [(Resource, Int)] -> Stage -> Inplace -> Rules () ===================================== hadrian/src/Rules/Rts.hs ===================================== @@ -1,10 +1,5 @@ -{-# LANGUAGE MultiWayIf #-} +module Rules.Rts (rtsRules) where -module Rules.Rts (rtsRules, needRtsSymLinks) where - -import qualified Data.Set as Set - -import Packages (rts) import Hadrian.Utilities import Settings.Builders.Common @@ -12,18 +7,7 @@ import Settings.Builders.Common -- library files (see Rules.Library.libraryRules). rtsRules :: Rules () rtsRules = priority 3 $ do - -- Dynamic RTS library files need symlinks without the dummy version number. - -- This is for backwards compatibility (the old make build system omitted the - -- dummy version number). root <- buildRootRules - [ root -/- "**/libHSrts_*-ghc*.so", - root -/- "**/libHSrts_*-ghc*.dylib", - root -/- "**/libHSrts-ghc*.so", - root -/- "**/libHSrts-ghc*.dylib"] - |%> \ rtsLibFilePath' -> createFileLink - (addRtsDummyVersion $ takeFileName rtsLibFilePath') - rtsLibFilePath' - -- Solve the recursive dependency between the rts and ghc-internal -- on Windows by creating an import lib for the ghc-internal dll, -- to be linked into the rts dll. @@ -37,35 +21,3 @@ buildGhcInternalImportLib target = do output = target -- the .dll.a import lib need [input] runBuilder Dlltool ["-d", input, "-l", output] [input] [output] - --- Need symlinks generated by rtsRules. -needRtsSymLinks :: Stage -> Set.Set Way -> Action () -needRtsSymLinks stage rtsWays - = forM_ (Set.filter (wayUnit Dynamic) rtsWays) $ \ way -> do - let ctx = Context stage rts way Final - distDir <- distDynDir ctx - rtsLibFile <- takeFileName <$> pkgLibraryFile ctx - need [removeRtsDummyVersion (distDir </> rtsLibFile)] - -prefix, versionlessPrefix :: String -versionlessPrefix = "libHSrts" -prefix = versionlessPrefix ++ "-1.0.3" - --- removeRtsDummyVersion "a/libHSrts-1.0-ghc1.2.3.4.so" --- == "a/libHSrts-ghc1.2.3.4.so" -removeRtsDummyVersion :: FilePath -> FilePath -removeRtsDummyVersion = replaceLibFilePrefix prefix versionlessPrefix - --- addRtsDummyVersion "a/libHSrts-ghc1.2.3.4.so" --- == "a/libHSrts-1.0-ghc1.2.3.4.so" -addRtsDummyVersion :: FilePath -> FilePath -addRtsDummyVersion = replaceLibFilePrefix versionlessPrefix prefix - -replaceLibFilePrefix :: String -> String -> FilePath -> FilePath -replaceLibFilePrefix oldPrefix newPrefix oldFilePath = let - oldFileName = takeFileName oldFilePath - newFileName = maybe - (error $ "Expected RTS library file to start with " ++ oldPrefix) - (newPrefix ++) - (stripPrefix oldPrefix oldFileName) - in replaceFileName oldFilePath newFileName View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6419a403984ea71d4f884d6eb4fe31e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6419a403984ea71d4f884d6eb4fe31e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/27162/remove-hadrian-so-symlinks] Hadrian: remove legacy rts .so symlinks
by David Eichmann (＠DavidEichmann) 19 May '26

19 May '26

David Eichmann pushed to branch wip/27162/remove-hadrian-so-symlinks at Glasgow Haskell Compiler / GHC Commits: 8e2c8400 by Duncan Coutts at 2026-05-19T12:46:54+01:00 Hadrian: remove legacy rts .so symlinks For compatibility with the old makefile based build system, hadrian had rules to generate symlinks from unversioned to versioned names for the rts .so/.dynlib file, like libHSrts-ghcx.y.so -> libHSrts-1.0.3-ghcx.y.so We no longer need these symlinks since the makefile build system has been retired some time ago. The need for these symlinks is awkward on windows where we cannot (in practice) create symlinks. So rather than make them conditional (non-windows), just remove them entirely. - - - - - 3 changed files: - + changelog.d/rts_symlinks.md - hadrian/src/Rules/Register.hs - hadrian/src/Rules/Rts.hs Changes: ===================================== changelog.d/rts_symlinks.md ===================================== @@ -0,0 +1,11 @@ +section: packaging +issues: #27162 +mrs: !15913 +synopsis: + GHC binary distributions nolonger have unversioned symlinks of the RTS libraries (.so/.dylib) +description: + Whith dynamic linking, an RTS with explicit version number is already linked by default e.g. + `libHSrts-1.0.3-ghc9.14.1.so`. GHC's binary distributions previously included symlinks without + an explicit RTS versions number e.g. `libHSrts-ghc9.14.1.so -> libHSrts-1.0.3-ghc9.14.1.so`. + As they are not used, such unversioned symlinks are no longer included in binary distributions. + Custom tooling that makes use of the removed symlinks, should now use the versioned file name instead. ===================================== hadrian/src/Rules/Register.hs ===================================== @@ -12,7 +12,6 @@ import Hadrian.BuildPath import Hadrian.Expression import Hadrian.Haskell.Cabal import Packages -import Rules.Rts import Settings import Target import Utilities @@ -88,14 +87,9 @@ parseToBuildSubdirectory root = do -- * Registering registerPackages :: [Context] -> Action () -registerPackages ctxs = do +registerPackages ctxs = need =<< mapM pkgRegisteredLibraryFile ctxs - -- Dynamic RTS library files need symlinks (Rules.Rts.rtsRules). - forM_ ctxs $ \ ctx -> when (package ctx == rts) $ do - ways <- interpretInContext ctx (getLibraryWays <> getRtsWays) - needRtsSymLinks (stage ctx) ways - -- | Register a package and initialise the corresponding package database if -- need be. Note that we only register packages in 'Stage0' and 'Stage1'. registerPackageRules :: [(Resource, Int)] -> Stage -> Inplace -> Rules () ===================================== hadrian/src/Rules/Rts.hs ===================================== @@ -1,10 +1,5 @@ -{-# LANGUAGE MultiWayIf #-} +module Rules.Rts (rtsRules) where -module Rules.Rts (rtsRules, needRtsSymLinks) where - -import qualified Data.Set as Set - -import Packages (rts) import Hadrian.Utilities import Settings.Builders.Common @@ -12,18 +7,7 @@ import Settings.Builders.Common -- library files (see Rules.Library.libraryRules). rtsRules :: Rules () rtsRules = priority 3 $ do - -- Dynamic RTS library files need symlinks without the dummy version number. - -- This is for backwards compatibility (the old make build system omitted the - -- dummy version number). root <- buildRootRules - [ root -/- "**/libHSrts_*-ghc*.so", - root -/- "**/libHSrts_*-ghc*.dylib", - root -/- "**/libHSrts-ghc*.so", - root -/- "**/libHSrts-ghc*.dylib"] - |%> \ rtsLibFilePath' -> createFileLink - (addRtsDummyVersion $ takeFileName rtsLibFilePath') - rtsLibFilePath' - -- Solve the recursive dependency between the rts and ghc-internal -- on Windows by creating an import lib for the ghc-internal dll, -- to be linked into the rts dll. @@ -37,35 +21,3 @@ buildGhcInternalImportLib target = do output = target -- the .dll.a import lib need [input] runBuilder Dlltool ["-d", input, "-l", output] [input] [output] - --- Need symlinks generated by rtsRules. -needRtsSymLinks :: Stage -> Set.Set Way -> Action () -needRtsSymLinks stage rtsWays - = forM_ (Set.filter (wayUnit Dynamic) rtsWays) $ \ way -> do - let ctx = Context stage rts way Final - distDir <- distDynDir ctx - rtsLibFile <- takeFileName <$> pkgLibraryFile ctx - need [removeRtsDummyVersion (distDir </> rtsLibFile)] - -prefix, versionlessPrefix :: String -versionlessPrefix = "libHSrts" -prefix = versionlessPrefix ++ "-1.0.3" - --- removeRtsDummyVersion "a/libHSrts-1.0-ghc1.2.3.4.so" --- == "a/libHSrts-ghc1.2.3.4.so" -removeRtsDummyVersion :: FilePath -> FilePath -removeRtsDummyVersion = replaceLibFilePrefix prefix versionlessPrefix - --- addRtsDummyVersion "a/libHSrts-ghc1.2.3.4.so" --- == "a/libHSrts-1.0-ghc1.2.3.4.so" -addRtsDummyVersion :: FilePath -> FilePath -addRtsDummyVersion = replaceLibFilePrefix versionlessPrefix prefix - -replaceLibFilePrefix :: String -> String -> FilePath -> FilePath -replaceLibFilePrefix oldPrefix newPrefix oldFilePath = let - oldFileName = takeFileName oldFilePath - newFileName = maybe - (error $ "Expected RTS library file to start with " ++ oldPrefix) - (newPrefix ++) - (stripPrefix oldPrefix oldFileName) - in replaceFileName oldFilePath newFileName View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e2c8400179372c144c3cef9b4188af… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e2c8400179372c144c3cef9b4188af… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/base-buildable-with-ghc-9-14] Add alternative `fixIO` import for GHC 9.14
by Wolfgang Jeltsch (＠jeltsch) 19 May '26

19 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/base-buildable-with-ghc-9-14 at Glasgow Haskell Compiler / GHC Commits: 44d20fd8 by Wolfgang Jeltsch at 2026-05-19T14:36:09+03:00 Add alternative `fixIO` import for GHC 9.14 - - - - - 1 changed file: - libraries/base/src/System/IO.hs Changes: ===================================== libraries/base/src/System/IO.hs ===================================== @@ -279,7 +279,11 @@ import GHC.IO.StdHandles stdout, stderr ) +#if __GLASGOW_HASKELL__ < 1000 +import GHC.Internal.System.IO (fixIO) +#else import GHC.Internal.Control.Monad.Fix (fixIO) +#endif import Control.Monad (return, (>>=)) import Control.Exception (ioError) import Data.Eq ((==)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44d20fd8ea4802511edd508d54d94b4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44d20fd8ea4802511edd508d54d94b4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Add type families: Tuple, Constraints, Tuple#, Sum# (#27179)
by Marge Bot (＠marge-bot) 19 May '26

19 May '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 83c45c49 by Vladislav Zavialov at 2026-05-19T07:32:41-04:00 Add type families: Tuple, Constraints, Tuple#, Sum# (#27179) These type families map tuples of types to the corresponding Tuple<N>, Tuple<N>#, CTuple<N>, and Sum<N># types. Some examples at N=2: Tuple (Int, Bool) = Tuple2 Int Bool Constraints (Show a, Eq a) = CTuple2 (Show a) (Eq a) Tuple# (Int#, Float#) = Tuple2# Int# Float# Sum# (Int#, Float#) = Sum2# Int# Float# See GHC Proposal #145 "Non-punning list and tuple syntax". To make the Sum# instance at N=64 possible, this patch also introduces the Sum64# constructor declaration and bumps mAX_SUM_SIZE from 63 to 64. Metric Increase: ghc_experimental_dir - - - - - 116a5669 by Wen Kokke at 2026-05-19T07:32:42-04:00 rts: Add IPE event class for -l This commit adds a new IPE event class to the -l RTS flag. Previously, IPE events were enabled unconditionally. However, the IPE events can easily grow to hundreds or thousands of megabytes. With the new event class you can pass, e.g., -l-I to disable IPE events. - - - - - 3579dbe8 by Wen Kokke at 2026-05-19T07:32:42-04:00 ghc-internal: Add TraceFlags.traceIPE - - - - - ed1b1c25 by Wen Kokke at 2026-05-19T07:32:42-04:00 testsuite: Add test for TraceFlags.traceIpe - - - - - fc172782 by Wen Kokke at 2026-05-19T07:32:43-04:00 ghc-internal: Add DebugFlags.ipe - - - - - ffa20293 by Wen Kokke at 2026-05-19T07:32:43-04:00 testsuite: Add test for DebugFlags.ipe - - - - - da68f4a4 by Duncan Coutts at 2026-05-19T07:32:44-04:00 Document removal of the signal-based interval timer Update mentions within the RTS section of the users guide. Add a changelog entry. - - - - - c34e8965 by Duncan Coutts at 2026-05-19T07:32:44-04:00 Fix section for an recent changelog entry - - - - - 120ac937 by David Eichmann at 2026-05-19T07:32:44-04:00 ghc-toolchain: implement llvm program versioning logic - - - - - 46 changed files: - changelog.d/dynamic-trace-flags - + changelog.d/ipe-event-class - + changelog.d/lib-add-tuple-tyfam-27179 - + changelog.d/no-more-timer-signal - compiler/GHC/Settings/Constants.hs - docs/users_guide/profiling.rst - docs/users_guide/runtime_control.rst - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-experimental/src/Data/Sum/Experimental.hs - libraries/ghc-experimental/src/Data/Tuple/Experimental.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/Types.hs - m4/ghc_toolchain.m4 - rts/IPE.c - rts/RtsFlags.c - rts/Trace.c - rts/Trace.h - rts/include/rts/EventLogWriter.h - rts/include/rts/Flags.h - testsuite/tests/ghci/scripts/ListTuplePunsPprNoAbbrevTuple.stdout - testsuite/tests/ghci/scripts/all.T - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/parser/should_compile/ListTuplePunsSuccess1.hs - testsuite/tests/parser/should_compile/all.T - + testsuite/tests/parser/should_fail/ListTuplePunsFail6.hs - + testsuite/tests/parser/should_fail/ListTuplePunsFail6.stderr - testsuite/tests/parser/should_fail/all.T - testsuite/tests/parser/should_run/ListTuplePunsConstraints.hs - testsuite/tests/profiling/should_run/callstack001.stdout - + testsuite/tests/rts/T25275/DebugIpe.hs - + testsuite/tests/rts/T25275/T25275_A.stdout - + testsuite/tests/rts/T25275/T25275_B.stdout - + testsuite/tests/rts/T25275/T25275_C.stdout - + testsuite/tests/rts/T25275/T25275_D.stdout - + testsuite/tests/rts/T25275/TraceIpe.hs - + testsuite/tests/rts/T25275/all.T - + testsuite/tests/typecheck/should_compile/T23135.hs - testsuite/tests/typecheck/should_compile/all.T - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Program.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ecb62fa3259011e3a3432592465594… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ecb62fa3259011e3a3432592465594… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/base-buildable-with-ghc-9-14] Add `hGetNewlineMode` for GHC 9.14
by Wolfgang Jeltsch (＠jeltsch) 19 May '26

19 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/base-buildable-with-ghc-9-14 at Glasgow Haskell Compiler / GHC Commits: 6475c878 by Wolfgang Jeltsch at 2026-05-19T14:28:06+03:00 Add `hGetNewlineMode` for GHC 9.14 - - - - - 1 changed file: - libraries/base/src/GHC/IO/Handle.hs Changes: ===================================== libraries/base/src/GHC/IO/Handle.hs ===================================== @@ -1,4 +1,6 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE RecordWildCards #-} -- | -- @@ -75,3 +77,19 @@ module GHC.IO.Handle ) where import GHC.Internal.IO.Handle + +#if __GLASGOW_HASKELL__ < 1000 + +import GHC.Internal.Base (($), IO, return) +import GHC.Internal.IO.Handle.Types (Handle__ (..)) +import GHC.Internal.IO.Handle.Internals (withHandle_) + +-- | Return the current 'NewlineMode' for the specified 'Handle'. +-- +-- @since 4.23.0.0 +hGetNewlineMode :: Handle -> IO NewlineMode +hGetNewlineMode hdl = + withHandle_ "hGetNewlineMode" hdl $ \Handle__{..} -> + return NewlineMode{ inputNL = haInputNL, outputNL = haOutputNL } + +#endif View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6475c878d64eceea90293a5acca6600… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6475c878d64eceea90293a5acca6600… You're receiving this email because of your account on gitlab.haskell.org.

1 0