Andreas Klebinger pushed to branch wip/andreask/fix-prof-segv at Glasgow Haskell Compiler / GHC Commits: 208b1d42 by Andreas Klebinger at 2026-06-18T12:36:24+00:00 StgToCmm: Don't assume tagged FUN closures in closureCodeBody When entering a closure the self/node pointer might not be tagged. So AND the tag bits away rather than subtracting the expected tag. - - - - - 688fea6e by Andreas Klebinger at 2026-06-18T12:36:24+00:00 profiling: Fix a segfault from a closure evaluating race condition. 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. - - - - - 223819ab by Andreas Klebinger at 2026-06-18T12:36:24+00:00 Add test for T27123 - - - - - 4 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - + testsuite/tests/rts/T27123.hs - testsuite/tests/rts/all.T Changes: ===================================== 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 (toTargetInt (fromDynTag (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,19 @@ 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 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)) ) ) + { + // ccall printf("closure type changed! (%d, %d)\n" + // , 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,66 @@ +{-# OPTIONS_GHC -ddump-cmm -ddump-stg-final -ddump-to-file -dsuppress-ticks #-} +{-# 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 evaluateThks #-} +evaluateThks :: Arr -> [Int] -> IO () +evaluateThks 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 + arr <- io (newSmallArray 6 (id)) + _ <- forkIO $ do + evaluateThks arr [0..5] + _ <- forkIO $ do + evaluateThks arr [5,4..0] + forkIO $ mkThunks arr + threadDelay 30_000_000 ===================================== testsuite/tests/rts/all.T ===================================== @@ -687,3 +687,5 @@ test('ClosureTable', ['-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', [extra_ways(['optasm', 'prof'])], compile_and_run, ['']) \ No newline at end of file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/23401b4321946170c117be02ded1407... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/23401b4321946170c117be02ded1407... You're receiving this email because of your account on gitlab.haskell.org.