Magnus pushed to branch wip/mangoiv/9.12.5-rc3-fixes at Glasgow Haskell Compiler / GHC Commits: 62792510 by Andreas Klebinger at 2026-07-08T22:59:13+02:00 Fix a profiling race condition resulting in segfaults. StgToCmm: Don't assume tagged FUN closures in closureCodeBody. When entering a closure the self/node pointer might not be tagged in some situations when a thunk is evaluated by multiple threads. So we most AND away the tag bits rather than subtracting an expected tag. Apply.cmm: Fix a race condition occuring when a thunk is mutated during GC. In stg_ap_0_fast when might need to run GC before entering a thunk. If this happens another thread or the GC itself might mutate the closure making entering it no longer valid. We now check for this. Add test and changelog for #27123 fixes. (cherry picked from commit ed09895d7de1ca116a561868c151fd825a16ad0c) - - - - - 5 changed files: - + changelog.d/T27123.md - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - + testsuite/tests/rts/T27123.hs - testsuite/tests/rts/all.T Changes: ===================================== changelog.d/T27123.md ===================================== @@ -0,0 +1,7 @@ +section: compiler +synopsis: Fix two crashes that could happen in a multithreaded setting when profiling. +description: There were two bugs that could cause occasional segfaults or crashes with +an `PAP object entered` error when profiling. They only happened when two threads +where racing to evaluate the same thunk, and specific GC timings. +mrs: !16214 +issues: #27123 ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -587,9 +587,8 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details -- ticky after heap check to avoid double counting ; tickyEnterFun cl_info ; enterCostCentreFun cc - (CmmMachOp (mo_wordSub platform) - [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification] - , mkIntExpr platform (funTag platform cl_info) ]) + (cmmUntag platform (CmmReg (CmmLocal node))) -- See [NodeReg clobbered with loopification] + ; fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* -- heap check, to reduce live vars over check ===================================== rts/Apply.cmm ===================================== @@ -99,12 +99,14 @@ again: W_ info; P_ untaggedfun; W_ arity; + W_ closure_type; // We must obey the correct heap object observation pattern in // Note [Heap memory barriers] in SMP.h. untaggedfun = UNTAG(fun); info = %INFO_PTR(untaggedfun); + closure_type = TO_W_( %INFO_TYPE(%STD_INFO(info)) ); switch [INVALID_OBJECT .. N_CLOSURE_TYPES] - (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) { + (closure_type) { case IND, IND_STATIC: @@ -212,10 +214,17 @@ again: // We can't use the value of 'info' any more, because if // STK_CHK_GEN() did a GC then the closure we're looking // at may have changed, e.g. a THUNK_SELECTOR may have - // been evaluated by the GC. So we reload the info - // pointer now. + // been evaluated by the GC. + // We always reload the info pointer now. And if + // the closure type changed we need to take a different case + // alt altogether so we retry from the start in that case. + untaggedfun = UNTAG(fun); info = %INFO_PTR(untaggedfun); + if(closure_type != TO_W_( %INFO_TYPE(%STD_INFO(info)) ) ) + { + goto again; + } jump %ENTRY_CODE(info) (stg_restore_cccs_eval_info, CCCS) ===================================== testsuite/tests/rts/T27123.hs ===================================== @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -fno-full-laziness -fno-worker-wrapper #-} +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +-- This test checks that the auto-apply code (stg_ap_0_fast, stg_ap_p) is robust +-- against another thread or the GC evaluating a closure at the same time. + +module Main + -- (main) +where + +import Control.Monad +import Control.Concurrent +import System.IO +import GHC.Data.SmallArray +import GHC.Exts +import GHC.IO + +type Arr = SmallMutableArray RealWorld (Int->Int) + +io :: (State# RealWorld -> (# State# RealWorld, a #)) -> IO a +io f = IO f + +io_ :: (State# RealWorld -> State# RealWorld ) -> IO () +io_ f = IO (\s -> case f s of s2 -> (# s2, () #)) + +{-# NOINLINE readSmallArray #-} +readSmallArray (SmallMutableArray arr) (I# idx) = IO $ \s -> case readSmallArray# arr idx s of + (# s2, r #) -> (# s2, r #) + +-- Continually overwrites the array with unevaluated thunks that will evaluated to +-- a PAP under profiling. +{-# NOINLINE mkThunks #-} +mkThunks :: Arr -> IO () +mkThunks arr = do + forever $ do + yield + forM_ [0..100] $ \_j -> do + forM_ [0..5 :: Int] $ \i -> do + -- With profiling results in a thunk that will evaluate to a PAP capturing the SCC + let g = {-# SCC g #-} succ + io_ (writeSmallArray arr i g) + +-- Evaluate the array repeatedly in the given order. +{-# NOINLINE evaluateThunks #-} +evaluateThunks :: Arr -> [Int] -> IO () +evaluateThunks arr idxs = do + forever $ do + yield + -- putStr "." >> hFlush stdout + forM [0..5000::Int] $ \j -> do + forM_ idxs $ \i -> do + !g <- readSmallArray arr i + seq (g i) (pure ()) + +main :: IO () +main = do + -- We spawn three threads. + -- * Two are evaluating the thunks in the array in opposite directions + -- * One thread is writing thunks to the array. + -- The reading threads will race to evaluate the same thunk triggering potential + -- race conditions. + arr <- io (newSmallArray 6 (id)) + _ <- forkIO $ do + evaluateThunks arr [0..5] + _ <- forkIO $ do + evaluateThunks arr [5,4..0] + forkIO $ mkThunks arr + threadDelay 10_000_000 ===================================== testsuite/tests/rts/all.T ===================================== @@ -639,3 +639,59 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru test('T25560', [req_c_rts, ignore_stderr], compile_and_run, ['']) test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main']) +<<<<<<< HEAD +||||||| parent of ed09895d7de (Fix a profiling race condition resulting in segfaults.) +test('T22859', + [js_skip, + # This test is vulnerable to changes in allocation behaviour, so we disable it in some ways + when(arch('wasm32'), skip), + omit_ways(llvm_ways)], + compile_and_run, ['-with-rtsopts -A8K']) + +# These tests need access to the internal RTS headers. +# TODO: there is probably some cleaner way to do this, and it should probably +# be guarded for in-tree tests, since it cannot work against an arbitrary +# installed ghc. + +test('TimeoutQueue', + [c_src, only_ways(['normal', 'debug'])], compile_and_run, + ['-debug -optc-Wall -optc-DDEBUG -I{top}/../rts']) + +test('ClosureTable', + [req_c, only_ways(['normal', 'debug']), extra_files(['ClosureTable_c.c'])], compile_and_run, + ['-debug -O0 ClosureTable_c.c -I{top}/../rts -I{top}/../rts/include']) + +test('resizeMutableByteArrayInPlace', [req_cmm, extra_ways(['optasm', 'sanity']), only_ways(['optasm', 'sanity'])], compile_and_run, ['']) + +test('T27434', + extra_ways(['compacting_gc']), + compile_and_run, ['']) +======= +test('T22859', + [js_skip, + # This test is vulnerable to changes in allocation behaviour, so we disable it in some ways + when(arch('wasm32'), skip), + omit_ways(llvm_ways)], + compile_and_run, ['-with-rtsopts -A8K']) + +# These tests need access to the internal RTS headers. +# TODO: there is probably some cleaner way to do this, and it should probably +# be guarded for in-tree tests, since it cannot work against an arbitrary +# installed ghc. + +test('TimeoutQueue', + [c_src, only_ways(['normal', 'debug'])], compile_and_run, + ['-debug -optc-Wall -optc-DDEBUG -I{top}/../rts']) + +test('ClosureTable', + [req_c, only_ways(['normal', 'debug']), extra_files(['ClosureTable_c.c'])], compile_and_run, + ['-debug -O0 ClosureTable_c.c -I{top}/../rts -I{top}/../rts/include']) + +test('resizeMutableByteArrayInPlace', [req_cmm, extra_ways(['optasm', 'sanity']), only_ways(['optasm', 'sanity'])], compile_and_run, ['']) + +test('T27123', [when(have_profiling(), extra_ways(['prof']))], compile_and_run, ['-O']) + +test('T27434', + extra_ways(['compacting_gc']), + compile_and_run, ['']) +>>>>>>> ed09895d7de (Fix a profiling race condition resulting in segfaults.) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/62792510351f397693f80d246fffcf17... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/62792510351f397693f80d246fffcf17... You're receiving this email because of your account on gitlab.haskell.org.