- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/spj-reinstallable-base2] prefer KnownKeys to KnownOcc, bit of polish
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: 395134b6 by Rodrigo Mesquita at 2026-05-19T14:16:19+01:00 prefer KnownKeys to KnownOcc, bit of polish - - - - - 7 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/KnownOccs.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/Module.hs Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -246,7 +246,7 @@ How known-occ entities work * Known-occ lookup (normal case: KES_FromModule) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In normal client code, suppose the desugarer calls - dsLookupKnownKeyTyCon rationalTyConKey + dsLookupKnownKeyTyCon ioTyConKey or dsLookupKnownOccTyCon rationalTyConOcc @@ -304,8 +304,8 @@ Known-key entities are * All the known-key names are gathered in one table: knownKeyTable :: [(KnownOcc, KnownKey)] knownKeyTable - = [ (mkTcOcc "Rational", rationalTyConKey) - , (mkTcOcc "Eq", eqClassKey) + = [ (mkTcOcc "IO", ioTyConKey) + , (mkTcOcc "Eq", eqClassKey) ... etc ... ] * Because of (KnownOccNameInvariant) we can turn that table into two mappings: ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -379,8 +379,6 @@ pureAClassOpOcc = mkVarOcc "pure" returnMClassOpOcc = mkVarOcc "return" thenMClassOpOcc = mkVarOcc ">>" bindMClassOpOcc = mkVarOcc ">>=" - -- ROMES:TODO: bindMClassOpOcc does not have a Known Names Table Entry. What - -- happens to all these occs needed for Quote? Should we make them just KnownOcc? thenAClassOpOcc = mkVarOcc "*>" mappendClassOpOcc = mkVarOcc "mappend" getFieldClassOpOcc = mkVarOcc "getField" @@ -483,7 +481,7 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, integerTyConKey, naturalTyConKey, listTyConKey, maybeTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, - orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, + orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, eqTyConKey, heqTyConKey, smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey, stringTyConKey, ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: KnownKey @@ -519,9 +517,7 @@ mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 orderingTyConKey = mkPreludeTyConUnique 32 mVarPrimTyConKey = mkPreludeTyConUnique 33 --- ioPortPrimTyConKey (34) was killed ratioTyConKey = mkPreludeTyConUnique 35 -rationalTyConKey = mkPreludeTyConUnique 36 realWorldTyConKey = mkPreludeTyConUnique 37 stablePtrPrimTyConKey = mkPreludeTyConUnique 38 stablePtrTyConKey = mkPreludeTyConUnique 39 ===================================== compiler/GHC/Builtin/KnownOccs.hs ===================================== @@ -179,14 +179,8 @@ fromStaticPtrClassOpOcc, newStablePtrIdOcc :: KnownOcc fromStaticPtrClassOpOcc = mkVarOcc "fromStaticPtr" newStablePtrIdOcc = mkVarOcc "newStablePtr" -staticPtrTyConOcc, staticPtrInfoDataConOcc :: KnownOcc -staticPtrTyConOcc = mkTcOcc "StaticPtr" -staticPtrInfoDataConOcc = mkDataOcc "StaticPtrInfo" - -knownNatClassOcc, knownSymbolClassOcc, knownCharClassOcc :: KnownOcc -knownNatClassOcc = mkTcOcc "KnownNat" -knownSymbolClassOcc = mkTcOcc "KnownSymbol" -knownCharClassOcc = mkTcOcc "KnownChar" +staticPtrTyConOcc :: KnownOcc +staticPtrTyConOcc = mkTcOcc "StaticPtr" returnIOIdOcc, bindIOIdOcc, thenIOIdOcc, printIdOcc, ioTyConOcc, ioDataConOcc :: KnownOcc @@ -226,11 +220,10 @@ typeLitCharDataConOcc = mkDataOcc "TypeLitChar" trModuleTyConOcc, trModuleDataConOcc, trNameSDataConOcc - , trTyConTyConOcc, trTyConDataConOcc :: KnownOcc + , trTyConDataConOcc :: KnownOcc trModuleTyConOcc = mkTcOcc "Module" trModuleDataConOcc = mkDataOcc "Module" trNameSDataConOcc = mkDataOcc "TrNameS" -trTyConTyConOcc = mkTcOcc "TyCon" trTyConDataConOcc = mkDataOcc "TyCon" -- Typeable representation types ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -137,7 +137,7 @@ import GHC.Iface.Errors.Types import Language.Haskell.Syntax.BooleanFormula (BooleanFormula) import Language.Haskell.Syntax.BooleanFormula qualified as BF(BooleanFormula(..)) import Language.Haskell.Syntax.Extension (NoExtField (NoExtField)) -import GHC.Builtin.KnownOccs (ioTyConOcc) +import GHC.Builtin.KnownKeys (ioTyConKey) {- This module takes @@ -983,7 +983,7 @@ mk_top_id (IfGblTopBndr gbl_name) -- rather than the current module so we need this special case. -- See some similar logic in `GHC.Rename.Env`. | Just rOOT_MAIN == nameModule_maybe gbl_name - = lookupKnownOccThing ioTyConOcc KES_FromModule >>= \case + = lookupKnownKeyThing ioTyConKey KES_FromModule >>= \case Failed err -> failIfM (pprDiagnostic err) Succeeded ioTyThing -> do ATyCon ioTyCon <- pure ioTyThing ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -27,13 +27,12 @@ import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) import GHC.Builtin.WiredIn.Types import GHC.Builtin.WiredIn.Prim import GHC.Builtin.KnownKeys -import GHC.Builtin.KnownOccs import GHC.Builtin.PrimOps ( PrimOp(..) ) import GHC.Builtin.PrimOps.Ids ( primOpId ) import GHC.Types.FieldLabel import GHC.Types.SafeHaskell -import GHC.Types.Name ( Name, KnownOcc ) +import GHC.Types.Name ( Name, KnownKey ) import GHC.Types.Name.Reader import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id @@ -961,9 +960,9 @@ matchTypeable clas [k,t] -- clas = Typeable -- see Note [No Typeable for polytypes or qualified types] -- Now cases that do work - | k `eqType` naturalTy = doTyLit knownNatClassOcc t - | k `eqType` typeSymbolKind = doTyLit knownSymbolClassOcc t - | k `eqType` charTy = doTyLit knownCharClassOcc t + | k `eqType` naturalTy = doTyLit knownNatClassKey t + | k `eqType` typeSymbolKind = doTyLit knownSymbolClassKey t + | k `eqType` charTy = doTyLit knownCharClassKey t | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks @@ -1039,8 +1038,8 @@ mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ] -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal -- we generate a sub-goal for the appropriate class. -- See Note [Typeable for Nat and Symbol] -doTyLit :: KnownOcc -> Type -> TcM ClsInstResult -doTyLit kc t = do { kc_clas <- tcLookupKnownOccClass kc +doTyLit :: KnownKey -> Type -> TcM ClsInstResult +doTyLit kc t = do { kc_clas <- tcLookupKnownKeyClass kc ; let kc_pred = mkClassPred kc_clas [ t ] mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev) mk_ev _ = panic "doTyLit" ===================================== compiler/GHC/Tc/Instance/Typeable.hs ===================================== @@ -23,6 +23,7 @@ import GHC.Iface.Env( newGlobalBinder ) import GHC.Builtin.Modules( gHC_TYPES, gHC_PRIM ) import GHC.Builtin.KnownOccs +import GHC.Builtin.KnownKeys (trTyConTyConKey) import GHC.Builtin.WiredIn.Prim ( primTyCons ) import GHC.Builtin.WiredIn.Types ( runtimeRepTyCon @@ -428,7 +429,7 @@ data TyConTodo todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo todoForTyCons mod mod_id tycons = do - trTyConTy <- mkTyConTy <$> tcLookupKnownOccTyCon trTyConTyConOcc + trTyConTy <- mkTyConTy <$> tcLookupKnownKeyTyCon trTyConTyConKey let mk_rep_id :: TyConRepName -> Id mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy `setInlinePragma` neverInlinePragma ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -1975,7 +1975,7 @@ generateMainBinding tcg_env main_name = do getIOType :: TcM (TcType, TcType) -- Return (IO alpha, alpha) for fresh alpha -getIOType = do { ioTyCon <- tcLookupKnownOccTyCon ioTyConOcc +getIOType = do { ioTyCon <- tcLookupKnownKeyTyCon ioTyConKey ; res_ty <- newFlexiTyVarTy liftedTypeKind ; return (mkTyConApp ioTyCon [res_ty], res_ty) } @@ -2589,7 +2589,7 @@ getGhciStepIO :: TcM (LHsExpr GhcRn) getGhciStepIO = do ghciTy <- getGHCiMonad a_tv <- newName (mkTyVarOccFS (fsLit "a")) - ioTyCon <- tcLookupKnownOccTyCon ioTyConOcc + ioTyCon <- tcLookupKnownKeyTyCon ioTyConKey let ghciM = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv) ioM = nlHsAppTy (nlHsTyVar NotPromoted (tyConName ioTyCon)) (nlHsTyVar NotPromoted a_tv) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/395134b66b8aa71bcd602777bce6031… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/395134b66b8aa71bcd602777bce6031… 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: daa65163 by Zubin Duggal at 2026-05-19T18:46:15+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,13 @@ check_target: } // nobody else can wake up this TSO after we claim the message +#if defined(THREADED_RTS) + 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 +444,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 +458,7 @@ check_target: if (!((target->flags & TSO_BLOCKEX) && ((target->flags & TSO_INTERRUPTIBLE) == 0))) { interruptWorkerTask(task); + RELEASE_STORE(&target_incall->interrupt_pending, 1); } return THROWTO_BLOCKED; } else { @@ -520,8 +533,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 } /* ----------------------------------------------------------------------------- @@ -664,6 +683,46 @@ removeFromMVarBlockedQueue (StgTSO *tso) tso->_link = END_TSO_QUEUE; } +#if defined(THREADED_RTS) +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 +758,16 @@ removeFromQueues(Capability *cap, StgTSO *tso) // capabilities. // ASSERT(m->header.info == &stg_WHITEHOLE_info); +#if defined(THREADED_RTS) + 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,25 @@ suspendThread (StgRegTable *reg, bool interruptible) suspendTask(cap,task); cap->in_haskell = false; + +#if defined(THREADED_RTS) + 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 +2593,10 @@ resumeThread (void *task_) // entry on the suspended_ccalls list will also have been // migrated. - // Remove the thread from the suspended list + 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 +2635,31 @@ resumeThread (void *task_) return &cap->r; } +#if defined(THREADED_RTS) +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,8 @@ typedef struct InCall_ { // Links InCalls onto suspended_ccalls, spare_incalls struct InCall_ *prev; struct InCall_ *next; + + StgWord interrupt_pending; } InCall; typedef struct Task_ { ===================================== rts/Timer.c ===================================== @@ -131,6 +131,9 @@ handle_tick(int unused STG_UNUSED) flushEventLog(NULL); } } + 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,38 @@ +{-# 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 () + +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 + 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/daa651639f3768d11ea0f76cbb121c7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/daa651639f3768d11ea0f76cbb121c7… 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: 7c45db7a by Zubin Duggal at 2026-05-19T18:45:38+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,13 @@ check_target: } // nobody else can wake up this TSO after we claim the message +#if defined(THREADED_RTS) + 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 +444,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 +458,7 @@ check_target: if (!((target->flags & TSO_BLOCKEX) && ((target->flags & TSO_INTERRUPTIBLE) == 0))) { interruptWorkerTask(task); + RELEASE_STORE(&target_incall->interrupt_pending, 1); } return THROWTO_BLOCKED; } else { @@ -520,8 +533,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 } /* ----------------------------------------------------------------------------- @@ -664,6 +683,46 @@ removeFromMVarBlockedQueue (StgTSO *tso) tso->_link = END_TSO_QUEUE; } +#if defined(THREADED_RTS) +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 +758,16 @@ removeFromQueues(Capability *cap, StgTSO *tso) // capabilities. // ASSERT(m->header.info == &stg_WHITEHOLE_info); +#if defined(THREADED_RTS) + 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,25 @@ suspendThread (StgRegTable *reg, bool interruptible) suspendTask(cap,task); cap->in_haskell = false; + +#if defined(THREADED_RTS) + 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 +2593,10 @@ resumeThread (void *task_) // entry on the suspended_ccalls list will also have been // migrated. - // Remove the thread from the suspended list + 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 +2635,31 @@ resumeThread (void *task_) return &cap->r; } +#if defined(THREADED_RTS) +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,8 @@ typedef struct InCall_ { // Links InCalls onto suspended_ccalls, spare_incalls struct InCall_ *prev; struct InCall_ *next; + + StgWord interrupt_pending; } InCall; typedef struct Task_ { ===================================== rts/Timer.c ===================================== @@ -131,6 +131,9 @@ handle_tick(int unused STG_UNUSED) flushEventLog(NULL); } } + 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/7c45db7a591fc6bb1d3589689611cf0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c45db7a591fc6bb1d3589689611cf0… 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] 2 commits: Disable `GHC.Internal.Unicode.Version` 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: 967b23cb by Wolfgang Jeltsch at 2026-05-19T16:04:36+03:00 Disable `GHC.Internal.Unicode.Version` import for GHC 9.14 - - - - - 025d47d3 by Wolfgang Jeltsch at 2026-05-19T16:06:14+03:00 Disable GHC 9.14 `printToHandleFinalizerExceptionHandler` - - - - - 3 changed files: - libraries/base/src/GHC/Unicode.hs - libraries/base/src/GHC/Weak.hs - libraries/base/src/GHC/Weak/Finalize.hs Changes: ===================================== libraries/base/src/GHC/Unicode.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# OPTIONS_HADDOCK not-home #-} @@ -44,4 +45,6 @@ module GHC.Unicode ) where import GHC.Internal.Unicode +#if __GLASGOW_HASKELL__ >= 1000 import GHC.Internal.Unicode.Version +#endif ===================================== libraries/base/src/GHC/Weak.hs ===================================== @@ -25,9 +25,8 @@ module GHC.Weak -- this handler will be ignored. setFinalizerExceptionHandler, getFinalizerExceptionHandler, - printToHandleFinalizerExceptionHandler + GHC.Weak.Finalize.printToHandleFinalizerExceptionHandler ) where import GHC.Internal.Weak -import GHC.Internal.Weak.Finalize import GHC.Weak.Finalize ===================================== libraries/base/src/GHC/Weak/Finalize.hs ===================================== @@ -7,7 +7,7 @@ module GHC.Weak.Finalize -- this handler will be ignored. setFinalizerExceptionHandler , getFinalizerExceptionHandler - , printToHandleFinalizerExceptionHandler + , GHC.Weak.Finalize.printToHandleFinalizerExceptionHandler -- * Internal , GHC.Weak.Finalize.runFinalizerBatch ) where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4b404918e10366d02345cd3d4d850a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4b404918e10366d02345cd3d4d850a… 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: 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