Magnus pushed to branch wip/mangoiv/9.12.5-rc4 at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • changelog.d/fix-parallel-gc-selector-race-27477
    1 
    +section: rts
    2 
    +synopsis: Fix a parallel GC race on weakly-ordered architectures (AArch64) that could crash or silently corrupt the heap
    3 
    +description:
    4 
    +  On weakly-ordered architectures such as AArch64 programs using
    5 
    +  could crash during parallel garbage collection (segmentation fault
    6 
    +  or ``internal error: eval_thunk_selector: strange selectee <n>``) or
    7 
    +  continue running with silently corrupted heap data, due to a missing
    8 
    +  memory barrier in the parallel GC.
    9 
    +mrs: !16488
    10 
    +issues: #27477

  • rts/sm/Evac.c
    ... ... @@ -1360,7 +1360,11 @@ selector_loop:
    1360 1360 
         // from-space during marking, for example.  We rely on the property
    1361 1361 
         // that evacuate() doesn't mind if it gets passed a to-space pointer.
    1362 1362
    1363 
    -    info = RELAXED_LOAD((StgInfoTable**) &selectee->header.info);
    1363 
    +    // NB. this load must be ordered: the selectee may be updated
    1364 
    +    // concurrently by another GC thread's unchain_thunk_selectors(),
    1365 
    +    // which publishes an indirection by writing the indirectee and
    1366 
    +    // then RELEASE-storing the info pointer. See #27477.
    1367 
    +    info = ACQUIRE_LOAD((StgInfoTable**) &selectee->header.info);
    1364 1368
    1365 1369 
         if (IS_FORWARDING_PTR(info)) {
    1366 1370 
             // We don't follow pointers into to-space; the constructor

  • testsuite/tests/rts/T27477.hs
    1 
    +{-# LANGUAGE BangPatterns #-}
    2 
    +
    3 
    +-- Stress test for #27477: missing ACQUIRE in eval_thunk_selector
    4 
    +-- (rts/sm/Evac.c).
    5 
    +--
    6 
    +-- With the bug present this test crashes or reports value mismatches
    7 
    +-- within a few seconds on AArch64; on strongly-ordered targets
    8 
    +-- it just passes.
    9 
    +
    10 
    +module Main (main) where
    11 
    +
    12 
    +import Control.Concurrent
    13 
    +import Control.Exception
    14 
    +import Control.Monad
    15 
    +import Data.IORef
    16 
    +import System.Environment
    17 
    +import System.Exit
    18 
    +import System.IO
    19 
    +import System.Mem (performMinorGC)
    20 
    +
    21 
    +data T = T { nxt :: T, val :: !Int }
    22 
    +
    23 
    +-- expected values and the cells that should evaluate to them
    24 
    +type Batch = ([Int], [T])
    25 
    +
    26 
    +tailD, branchD, branchesPerCell :: Int
    27 
    +tailD = 12          -- shared tail length per cluster
    28 
    +branchD = 3         -- private branch length
    29 
    +branchesPerCell = 2
    30 
    +-- tailD + branchD must stay below MAX_THUNK_SELECTOR_DEPTH (16)
    31 
    +
    32 
    +{-# NOINLINE spineEnd #-}
    33 
    +spineEnd :: T
    34 
    +spineEnd = errorWithoutStackTrace "spine end reached"
    35 
    +
    36 
    +-- Fully evaluated spine of constructors; cell i from the head has val i+1.
    37 
    +buildSpine :: Int -> IO T
    38 
    +buildSpine len = evaluate (go len (T spineEnd 0))
    39 
    +  where
    40 
    +    go :: Int -> T -> T
    41 
    +    go 0 acc = acc
    42 
    +    go k acc = go (k - 1) (T acc k)
    43 
    +
    44 
    +-- k selector thunks, shallow-first: cell i selects from cell i-1,
    45 
    +-- cell 0 selects from t.  If t evaluates to spine cell m (val m+1),
    46 
    +-- cell i evaluates to spine cell m+1+i (val m+2+i).
    47 
    +{-# NOINLINE selChain #-}
    48 
    +selChain :: Int -> T -> [T]
    49 
    +selChain 0 _ = []
    50 
    +selChain k t = let t' = nxt t in t' : selChain (k - 1) t'
    51 
    +
    52 
    +lenL :: [a] -> Int
    53 
    +lenL = go 0
    54 
    +  where
    55 
    +    go !n [] = n
    56 
    +    go !n (_ : xs) = go (n + 1) xs
    57 
    +
    58 
    +everyN :: Int -> [a] -> [a]
    59 
    +everyN _ [] = []
    60 
    +everyN n (x : xs) = x : everyN n (drop (n - 1) xs)
    61 
    +
    62 
    +-- One branch hanging off tail cell tj (which evaluates to val jval):
    63 
    +-- branch cell i evaluates to jval+1+i.  Returned deepest-first.
    64 
    +{-# NOINLINE mkBranch #-}
    65 
    +mkBranch :: Int -> T -> IO Batch
    66 
    +mkBranch jval tj = do
    67 
    +  let cells = selChain branchD tj
    68 
    +  _ <- evaluate (lenL cells)
    69 
    +  let expected = [ jval + 1 + i | i <- [0 .. branchD - 1] ]
    70 
    +  pure (reverse expected, reverse cells)
    71 
    +
    72 
    +-- A cluster: one private spine, one shared tail of selectors over it,
    73 
    +-- branchesPerCell branches of selectors converging on every tail cell.
    74 
    +-- Neither the spine nor the tail is returned: they must stay reachable
    75 
    +-- only through the branch selectors.
    76 
    +buildCluster :: IO [Batch]
    77 
    +buildCluster = do
    78 
    +  sp <- buildSpine (tailD + branchD + 4)
    79 
    +  let tails = selChain tailD sp
    80 
    +  _ <- evaluate (lenL tails)
    81 
    +  bss <- forM (zip [0 ..] tails) $ \(j, tj) ->
    82 
    +    replicateM branchesPerCell (mkBranch (j + 2) tj)
    83 
    +  pure (concat bss)
    84 
    +
    85 
    +verifyBatch :: IORef Int -> Int -> Batch -> IO ()
    86 
    +verifyBatch errs wid (es0, ts0) = go es0 ts0
    87 
    +  where
    88 
    +    go (e : es) (t : ts) = do
    89 
    +      v <- evaluate (val t)
    90 
    +      when (v /= e) $ do
    91 
    +        hPutStrLn stderr $
    92 
    +          "MISMATCH worker=" ++ show wid
    93 
    +            ++ " expected=" ++ show e ++ " got=" ++ show v
    94 
    +        modifyIORef' errs (+ 1)
    95 
    +      go es ts
    96 
    +    go _ _ = pure ()
    97 
    +
    98 
    +-- simple cyclic barrier
    99 
    +newtype Barrier = Barrier (MVar (Int, [MVar ()]))
    100 
    +
    101 
    +newBarrier :: IO Barrier
    102 
    +newBarrier = Barrier <$> newMVar (0, [])
    103 
    +
    104 
    +awaitBarrier :: Barrier -> Int -> IO ()
    105 
    +awaitBarrier (Barrier st) total = do
    106 
    +  w <- newEmptyMVar
    107 
    +  join $ modifyMVar st $ \(k, ws) ->
    108 
    +    if k + 1 == total
    109 
    +      then pure ((0, []), mapM_ (\m -> putMVar m ()) ws)
    110 
    +      else pure ((k + 1, w : ws), takeMVar w)
    111 
    +
    112 
    +worker :: Int -> Int -> Int -> Barrier -> [IORef [Batch]] -> IORef Int -> Int -> IO ()
    113 
    +worker rounds clusters nWorkers bar slots errs wid =
    114 
    +  forM_ [1 .. rounds] $ \(_r :: Int) -> do
    115 
    +    -- build fresh selector clusters, publish them
    116 
    +    batches <- concat <$> replicateM clusters buildCluster
    117 
    +    writeIORef (slots !! wid) batches
    118 
    +    awaitBarrier bar nWorkers
    119 
    +    -- root each branch's deepest cell via fresh cons cells in our own
    120 
    +    -- nursery (so our GC thread evacuates the shared cells itself), in
    121 
    +    -- a per-worker interleaved order so that different GC threads
    122 
    +    -- sweep different branches of the same shared tails concurrently
    123 
    +    published <- mapM readIORef slots
    124 
    +    let allBatches = concat published
    125 
    +        ordered
    126 
    +          | nWorkers > 1 =
    127 
    +              concat [ everyN nWorkers (drop ((wid + k) `mod` nWorkers) allBatches)
    128 
    +                     | k <- [0 .. nWorkers - 1] ]
    129 
    +          | otherwise = allBatches
    130 
    +        deepTs = [ t | (_, t : _) <- ordered ]
    131 
    +        deepEs = [ e | (e : _, _) <- ordered ]
    132 
    +    _ <- evaluate (lenL deepTs)
    133 
    +    _ <- evaluate (lenL deepEs)
    134 
    +    awaitBarrier bar nWorkers
    135 
    +    -- run a parallel GC with everything live
    136 
    +    when (wid == 0) performMinorGC
    137 
    +    awaitBarrier bar nWorkers
    138 
    +    -- force everything and check the values
    139 
    +    verifyBatch errs wid (deepEs, deepTs)
    140 
    +    awaitBarrier bar nWorkers
    141 
    +
    142 
    +main :: IO ()
    143 
    +main = do
    144 
    +  hSetBuffering stderr LineBuffering
    145 
    +  args <- getArgs
    146 
    +  let atDef d i = if length args > i then read (args !! i) else d
    147 
    +      rounds = atDef 600 0
    148 
    +      clusters = atDef 48 1
    149 
    +  n <- getNumCapabilities
    150 
    +  bar <- newBarrier
    151 
    +  slots <- replicateM n (newIORef [])
    152 
    +  errs <- newIORef 0
    153 
    +  dones <- forM [0 .. n - 1] $ \i -> do
    154 
    +    done <- newEmptyMVar
    155 
    +    _ <- forkOn i $
    156 
    +      (worker rounds clusters n bar slots errs i >> putMVar done Nothing)
    157 
    +        `catch` \e -> putMVar done (Just (e :: SomeException))
    158 
    +    pure done
    159 
    +  results <- mapM takeMVar dones
    160 
    +  forM_ results $ \r -> case r of
    161 
    +    Just e -> do
    162 
    +      hPutStrLn stderr ("worker exception: " ++ show e)
    163 
    +      exitWith (ExitFailure 2)
    164 
    +    Nothing -> pure ()
    165 
    +  ec <- readIORef errs
    166 
    +  when (ec > 0) $ do
    167 
    +    hPutStrLn stderr ("FAILED: " ++ show ec ++ " mismatches")
    168 
    +    exitWith (ExitFailure 2)
    169 
    +  putStrLn "OK"

  • testsuite/tests/rts/T27477.stdout
    1 
    +OK

  • testsuite/tests/rts/all.T
    ... ... @@ -639,5 +639,11 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru
    639 639 
     test('T25560', [req_c_rts, ignore_stderr], compile_and_run, [''])
    640 640
    641 641 
     test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main'])
    642 
    -
    643 642 
     test('T27123', [when(have_profiling(), extra_ways(['prof']))], compile_and_run, ['-O -package ghc'])
    643 
    +test('T27477',
    644 
    +     [ extra_run_opts('600 24 +RTS -N4 -A1m -RTS')
    645 
    +     , req_ghc_smp
    646 
    +     , req_target_smp
    647 
    +     , only_ways(['threaded1', 'threaded2'])
    648 
    +     ],
    649 
    +     compile_and_run, ['-O2'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/45b16ebe4a65a1551e1c8da494043c5fa25681c2 at 1788947169