[Git][ghc/ghc][master] ghc-heap: Fix decoding of TSO closures

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
436867d6 by Matthew Pickering at 2022-08-18T09:24:08-04:00
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

- - - - -


2 changed files:

- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs


Changes:

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


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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/436867d6b07c69170e8e51283ac57ed3eab52ae4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/436867d6b07c69170e8e51283ac57ed3eab52ae4
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220818/1e3cb5bd/attachment-0001.html>