Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: 5b5aac16 by Simon Jakobi at 2026-05-14T16:19:04+02:00 Fix -dsuppress-uniques for free variables in demand signatures Before: Str=b{sXyZ->S} With this patch: Str=b{S} T13143.stderr is updated accordingly. Fixes #27106. (cherry picked from commit 5b82080a3f3dd476e198130218d4da729fb5334a) - - - - - 98f24314 by Matthew Pickering at 2026-05-14T16:19:58+02:00 rts: forward clone-stack messages after TSO migration MSG_CLONE_STACK assumed that the target TSO was still owned by the capability that received the message. This is not always true: the TSO can migrate before the inbox entry is handled. When that happened, handleCloneStackMessage could clone a live stack from the wrong capability and use the wrong capability for allocation and performTryPutMVar, leading to stack sanity failures such as checkStackFrame: weird activation record found on stack. Fix this by passing the current capability into handleCloneStackMessage, rechecking msg->tso->cap at handling time, and forwarding the message if the TSO has migrated. Once ownership matches, use the executing capability consistently for cloneStack, rts_apply, and performTryPutMVar. Fixes #27008 (cherry picked from commit 5b550754ca0153a705ec607407074fe5716c1f7e) - - - - - d903097d by Andreas Klebinger at 2026-05-14T16:20:44+02:00 Fix missing profiling header for origin_thunk frame. Fixes #27007 (cherry picked from commit 63ae8eb38c54eaba77949b048a3621a5f4ca76e3) - - - - - 52c2ba8f by Luite Stegeman at 2026-05-14T16:24:20+02:00 bytecode: Carefully SLIDE off the end of a stack chunk The SLIDE bytecode instruction was not checking for stack chunk boundaries and could corrupt the stack underflow frame, leading to crashes. We add a check to use safe writes if we cross the chunk boundary and also handle stack underflow if Sp is advanced past the underflow frame. fix #27001 (cherry picked from commit 72b20fc0ad4b6ad12c67f686af5cb42700656886) - - - - - 15 changed files: - compiler/GHC/Types/Demand.hs - rts/CloneStack.c - rts/CloneStack.h - rts/Interpreter.c - rts/Messages.c - rts/StgMiscClosures.cmm - + testsuite/tests/bytecode/T27001.hs - + testsuite/tests/bytecode/T27001.stdout - testsuite/tests/bytecode/all.T - testsuite/tests/dmdanal/should_compile/T13143.stderr - + testsuite/tests/dmdanal/should_compile/T27106.hs - + testsuite/tests/dmdanal/should_compile/T27106.stderr - testsuite/tests/dmdanal/should_compile/all.T - testsuite/tests/rts/all.T - + testsuite/tests/rts/cloneThreadStackMigrating.hs Changes: ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE PatternSynonyms #-} @@ -2844,7 +2845,10 @@ instance Outputable DmdEnv where = ppr div <> if null fv_elts then empty else braces (fsep (map pp_elt fv_elts)) where - pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + pp_elt (uniq, dmd) = + sdocOption sdocSuppressUniques $ \case + True -> ppr dmd + False -> ppr uniq <> text "->" <> ppr dmd fv_elts = nonDetUFMToList fvs -- It's OK to use nonDetUFMToList here because we only do it for -- pretty printing ===================================== rts/CloneStack.c ===================================== @@ -89,15 +89,31 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) { sendMessage(srcCapability, tso->cap, (Message *)msg); } -void handleCloneStackMessage(MessageCloneStack *msg){ - StgStack* newStackClosure = cloneStack(msg->tso->cap, msg->tso->stackobj); +// The cap argument is the capability which is handling the CloneStack message +void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg){ + // We must check that the current owner of the thread we want to clone the stack for + // is still this capability. + Capability *owner = RELAXED_LOAD(&msg->tso->cap); + if (owner != cap) { + // The target TSO may have migrated after the message was queued on the old + // capability. In that case we must forward the request to the current + // owner; otherwise we would race with another capability mutating the + // stack while we clone it. + sendMessage(cap, owner, (Message *)msg); + return; + } + + // At this point the executing capability owns the TSO, so it is the only + // capability that may safely inspect the live stack and the one whose + // allocator we must use for the cloned StgStack closure. + StgStack* newStackClosure = cloneStack(cap, msg->tso->stackobj); // Lift StackSnapshot# to StackSnapshot by applying it's constructor. // This is necessary because performTryPutMVar() puts the closure onto the // stack for evaluation and stacks can not be evaluated (entered). - HaskellObj result = rts_apply(msg->tso->cap, StackSnapshot_constructor_closure, (HaskellObj) newStackClosure); + HaskellObj result = rts_apply(cap, StackSnapshot_constructor_closure, (HaskellObj) newStackClosure); - bool putMVarWasSuccessful = performTryPutMVar(msg->tso->cap, msg->result, result); + bool putMVarWasSuccessful = performTryPutMVar(cap, msg->result, result); if(!putMVarWasSuccessful) { barf("Can't put stack cloning result into MVar."); ===================================== rts/CloneStack.h ===================================== @@ -19,7 +19,7 @@ StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack); #include "BeginPrivate.h" #if defined(THREADED_RTS) -void handleCloneStackMessage(MessageCloneStack *msg); +void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg); #endif #include "EndPrivate.h" ===================================== rts/Interpreter.c ===================================== @@ -179,6 +179,24 @@ tag functions as tag inference currently doesn't rely on those being properly ta #define WITHIN_CHUNK_BOUNDS_W(n, s) \ (RTS_LIKELY(((StgWord*) Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame)))) +/* Note [Checking for underflow frames] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + We look at the stack slot at offset sizeof(StgUnderflowFrame) from + the start of the chunk to check if we're in the first check chunk. + Every non-first stack chunk has an underflow frame header at that offset. + + We really should change this check, since this stack slot in the first + chunk may not be the start of a stack frame and could in theory contain + an arbitrary value. + + In practice we're unlikely to have interpreted frames that low on the stack. + */ +#define IS_UNDERFLOW_FRAME(info) \ + ((info) == &stg_stack_underflow_frame_d_info || \ + (info) == &stg_stack_underflow_frame_v16_info || \ + (info) == &stg_stack_underflow_frame_v32_info || \ + (info) == &stg_stack_underflow_frame_v64_info) #define W64_TO_WDS(n) ((n * sizeof(StgWord64) / sizeof(StgWord))) @@ -431,11 +449,9 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ frame = (StgUnderflowFrame*)(cur_stack->stack + cur_stack->stack_size - sizeofW(StgUnderflowFrame)); - // 2a. Check it is an underflow frame (the top stack chunk won't have one). - if( frame->info == &stg_stack_underflow_frame_d_info - || frame->info == &stg_stack_underflow_frame_v16_info - || frame->info == &stg_stack_underflow_frame_v32_info - || frame->info == &stg_stack_underflow_frame_v64_info ) + // 2a. Check it is an underflow frame (the first stack chunk won't have one). + // See Note [Checking for underflow frames] + if( IS_UNDERFLOW_FRAME(frame->info) ) { INTERP_TICK(it_underflow_lookups); @@ -452,9 +468,11 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ } // 2b. Access the element if there is no underflow frame, it must be right // at the top of the stack. - else { - // Not actually in the underflow case + else if(Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) { + // Still inside the stack chunk return Sp_plusW(offset_words); + } else { + barf("slow_spw: offset_words %d is out of bounds", (int)offset_words); } } } @@ -1788,8 +1806,39 @@ run_BCO: * => * a_1 ... a_n, k */ - while(n-- > 0) { - SpW(n+by) = ReadSpW(n); + if (n == 0 || WITHIN_CAP_CHUNK_BOUNDS_W(n - 1 + by)) { + while(n-- > 0) { + SpW(n+by) = ReadSpW(n); + } + } else { + // We write across a chunk boundary: Use safe access + while(n-- > 0) { + *((StgWord*)SafeSpWP(n+by)) = ReadSpW(n); + } + } + + // If we SLIDE Sp past the chunk bounds we need to handle the underflow + // (possibly multiple times) + while (!WITHIN_CAP_CHUNK_BOUNDS_W(by)) { + StgStack *stk = cap->r.rCurrentTSO->stackobj; + StgUnderflowFrame *uf = (StgUnderflowFrame*) + (stk->stack + stk->stack_size + - sizeofW(StgUnderflowFrame)); + // See Note [Checking for underflow frames] + if (IS_UNDERFLOW_FRAME(uf->info)) { + W_ sp_to_uf = (StgWord*)uf - (StgWord*)Sp; + Sp = (StgPtr)uf; + SAVE_STACK_POINTERS; + threadStackUnderflow(cap, cap->r.rCurrentTSO); + LOAD_STACK_POINTERS; + by -= sp_to_uf; + } else if (Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) { + // we're within the first stack chunk, this chunk has + // no underflow frame + break; + } else { + barf("bci_SLIDE: Sp+by outside stack bounds"); + } } Sp_addW(by); INTERP_TICK(it_slides); ===================================== rts/Messages.c ===================================== @@ -135,7 +135,7 @@ loop: } else if(i == &stg_MSG_CLONE_STACK_info){ MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m; - handleCloneStackMessage(cloneStackMessage); + handleCloneStackMessage(cap, cloneStackMessage); } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -47,6 +47,7 @@ import CLOSURE stg_ret_v_info; /* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */ INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL, W_ info_ptr, + PROF_HDR_FIELDS(W_, p1, p2) W_ thunk_info_ptr) /* no args => explicit stack */ { ===================================== testsuite/tests/bytecode/T27001.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE BangPatterns #-} +-- Test that SLIDE works correctly when it crosses a stack chunk boundary. +-- See #27001. +module Main where + +go :: Int -> Double -> Double +go 0 !acc = acc +go n !acc = go (n - 1) (acc + 1.0) + +result :: Double +result = go 100000 0.0 + +main :: IO () +main = print result ===================================== testsuite/tests/bytecode/T27001.stdout ===================================== @@ -0,0 +1,4 @@ +(0.15 secs,) +it :: () +100000.0 +(0.09 secs, 51,566,104 bytes) ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -9,3 +9,8 @@ test('T25975', extra_ways(ghci_ways), compile_and_run, # Nullary data constructors test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) + +# SLIDE across stack chunk boundary (#27001) +test('T27001', [extra_files(['T27001.hs']), req_interp], + run_command, + ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter T27001.hs']) ===================================== testsuite/tests/dmdanal/should_compile/T13143.stderr ===================================== @@ -6,8 +6,8 @@ Result size of Tidy Core Rec { -- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0} T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker] - :: forall {a}. (# #) -> a -[GblId, Arity=1, Str=<B>b{sBo->S}, Cpr=b, Unf=OtherCon []] + :: forall a. (# #) -> a +[GblId, Arity=1, Str=<B>b{S}, Cpr=b, Unf=OtherCon []] T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Types.(##) end Rec } @@ -15,7 +15,7 @@ end Rec } f [InlPrag=NOINLINE[final]] :: forall a. Int -> a [GblId, Arity=1, - Str=<B>b{sBo->S}, + Str=<B>b{S}, Cpr=b, Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -66,7 +66,7 @@ T13143.$trModule -- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0} lvl :: Int -[GblId, Str=b{sBo->S}, Cpr=b] +[GblId, Str=b{S}, Cpr=b] lvl = T13143.$wf @Int GHC.Types.(##) Rec { ===================================== testsuite/tests/dmdanal/should_compile/T27106.hs ===================================== @@ -0,0 +1,5 @@ +module T27106 where + +{-# NOINLINE weird #-} +weird :: Int -> a +weird x = weird x ===================================== testsuite/tests/dmdanal/should_compile/T27106.stderr ===================================== @@ -0,0 +1,4 @@ +weird [InlPrag=NOINLINE[final]] :: forall a. Int -> a +[GblId, + Arity=1, + Str=<B>b{S}, ===================================== testsuite/tests/dmdanal/should_compile/all.T ===================================== @@ -45,6 +45,13 @@ test('T13077a', normal, compile, ['']) # T13143: WW for NOINLINE function f test('T13143', [ grep_errmsg(r'^T13143\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques']) +# Uniques in the free variable part of a demand signature should be +# suppressed by -dsuppress-uniques. +test('T27106', normal, multimod_compile_filter, + ['T27106', + '-v0 -O -ddump-simpl -dsuppress-uniques', + r"sed -n '/^weird /,/.* Str=/p'"]) + # T15627 # Absent bindings of unlifted types should be WW'ed away. # The idea is to check that both $wmutVar and $warray ===================================== testsuite/tests/rts/all.T ===================================== @@ -583,6 +583,15 @@ test('cloneMyStack_retBigStackFrame', [req_c, extra_files(['cloneStackLib.c']), test('cloneThreadStack', [req_c, only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c']), req_ghc_with_threaded_rts], compile_and_run, ['cloneStackLib.c -threaded']) +test('cloneThreadStackMigrating', + [ ignore_stdout + , only_ways(['threaded1']) + , extra_ways(['threaded1']) + , extra_run_opts('+RTS -N -DS -RTS') + , req_ghc_with_threaded_rts + , req_target_smp + ], compile_and_run, ['-threaded -debug -rtsopts']) + test('decodeMyStack', [ omit_ghci, js_broken(22261) # cloneMyStack# not yet implemented ], compile_and_run, ['-finfo-table-map']) ===================================== testsuite/tests/rts/cloneThreadStackMigrating.hs ===================================== @@ -0,0 +1,37 @@ +module Main where + +import Control.Concurrent +import Control.Monad +import GHC.Exts.Stack +import GHC.Stack.CloneStack + +numWorkers :: Int +numWorkers = 100 + +startN :: Int +startN = 10 + +runForMicros :: Int +runForMicros = 1000000 + +fib :: Int -> Int +fib 0 = 1 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) + +workerThread :: Int -> IO () +workerThread n = do + fib n `seq` pure () + workerThread (n + 1) + +cloneThread :: ThreadId -> IO () +cloneThread tid = forever $ do + snapshot <- cloneThreadStack tid + stack <- decodeStack snapshot + stack `seq` pure () + +main :: IO () +main = do + tids <- replicateM numWorkers (forkIO $ workerThread startN) + mapM_ (forkIO . cloneThread) tids + threadDelay runForMicros View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0b9c16240dd96548f319c8b2376e34... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c0b9c16240dd96548f319c8b2376e34... You're receiving this email because of your account on gitlab.haskell.org.