diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2022-08-15 11:07:05 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-08-18 09:24:08 -0400 |
| commit | 436867d6b07c69170e8e51283ac57ed3eab52ae4 (patch) | |
| tree | 343480385937c2caa85070eb32af7d077991392f | |
| parent | 3e493dfd4db4b61ffc3f1faf7e38663118473d99 (diff) | |
| download | haskell-436867d6b07c69170e8e51283ac57ed3eab52ae4.tar.gz | |
ghc-heap: Fix decoding of TSO closures
An extra field was added to the TSO structure in 6d1700b6 but the
decoding logic in ghc-heap was not updated for this new field.
Fixes #22046
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap.hs | 8 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/Closures.hs | 1 |
2 files changed, 7 insertions, 2 deletions
diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs index 874c61b746..574a230cfd 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap.hs @@ -350,7 +350,7 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do [p] -> Just p _ -> error $ "Expected 4 or 5 words in WEAK, found " ++ show (length pts) } - TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts + TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other) <- pts -> withArray rawHeapWords (\ptr -> do fields <- FFIClosures.peekTSOFields decodeCCS ptr pure $ TSOClosure @@ -361,6 +361,10 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do , trec = u_trec , blocked_exceptions = u_blk_ex , bq = u_bq + , thread_label = case other of + [tl] -> Just tl + [] -> Nothing + _ -> error $ "thead_label:Expected 0 or 1 extra arguments" , what_next = FFIClosures.tso_what_next fields , why_blocked = FFIClosures.tso_why_blocked fields , flags = FFIClosures.tso_flags fields @@ -372,7 +376,7 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do , prof = FFIClosures.tso_prof fields }) | otherwise - -> fail $ "Expected 6 ptr arguments to TSO, found " + -> fail $ "Expected at least 6 ptr arguments to TSO, found " ++ show (length pts) STACK | [] <- pts diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs index 13d1ff71c2..6078a927bf 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -280,6 +280,7 @@ data GenClosure b , trec :: !b , blocked_exceptions :: !b , bq :: !b + , thread_label :: !(Maybe b) -- values , what_next :: !WhatNext , why_blocked :: !WhyBlocked |