GitLab

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
```

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

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