GitLab

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

 +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

 +{-# 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.)