[Git][ghc/ghc][wip/ghc-debug] Encode TSO fields for ghc-heap

[Sven Tennie]

Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC


Commits:
4e78046b by Sven Tennie at 2020-05-17T16:57:36+02:00
Encode TSO fields for ghc-heap

- - - - -


4 changed files:

- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc
- rts/Heap.c


Changes:

=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -58,7 +58,7 @@ import GHC.Exts.Heap.InfoTableProf
 import GHC.Exts.Heap.InfoTable
 #endif
 import GHC.Exts.Heap.Utils
-import GHC.Exts.Heap.FFIClosures
+import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
 
 import Control.Monad
 import Data.Bits
@@ -297,8 +297,7 @@ getClosureX get_closure_raw x = do
             allocaArray (length wds) (\ptr -> do
                 pokeArray ptr wds
 
-                threadId' <- peekStgThreadID ptr
-                alloc_limit' <- peekAllocLimit ptr
+                fields <- FFIClosures.peekTSOFields ptr
 
                 pure $ TSOClosure
                     { info = itbl
@@ -308,8 +307,14 @@ getClosureX get_closure_raw x = do
                     , trec = (pts !! 3)
                     , blocked_exceptions = (pts !! 4)
                     , bq = (pts !! 5)
-                    , threadId = threadId'
-                    , alloc_limit = alloc_limit'
+                    , what_next = FFIClosures.what_next fields
+                    , why_blocked = FFIClosures.why_blocked fields
+                    , flags = FFIClosures.flags fields
+                    , threadId = FFIClosures.threadId fields
+                    , saved_errno = FFIClosures.saved_errno fields
+                    , dirty = FFIClosures.dirty fields
+                    , alloc_limit = FFIClosures.alloc_limit fields
+                    , tot_stack_size = FFIClosures.tot_stack_size fields
                     }
                 )
         STACK -> do


=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -260,9 +260,6 @@ data GenClosure b
         , link        :: !b -- ^ next weak pointer for the capability, can be NULL.
         }
 
-  -- TODO: There are many more fields in a TSO closure which
-  -- are not yet implemented
-
   -- | StgTSO
   | TSOClosure
       { info :: !StgInfoTable
@@ -274,8 +271,14 @@ data GenClosure b
       , blocked_exceptions :: !b
       , bq :: !b
       -- values
+      , what_next :: Word16
+      , why_blocked :: Word16
+      , flags :: Word32
       , threadId :: Word64
+      , saved_errno :: Word32
+      , dirty:: Word32
       , alloc_limit :: Int64
+      , tot_stack_size :: Word32
       }
 
   | StackClosure


=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc
=====================================
@@ -5,9 +5,41 @@ module GHC.Exts.Heap.FFIClosures where
 import Prelude
 import Foreign
 
-peekStgThreadID :: Ptr a -> IO Word64
-peekStgThreadID ptr = (#peek struct StgTSO_, id) ptr
+-- TODO use sum type for what_next, why_blocked, flags?
 
+data TSOFields = TSOFields {
+    what_next :: Word16,
+    why_blocked :: Word16,
+    flags :: Word32,
+-- Unfortunately block_info is a union without clear discriminator.
+--    block_info :: TDB,
+    threadId :: Word64,
+    saved_errno :: Word32,
+    dirty:: Word32,
+    alloc_limit :: Int64,
+    tot_stack_size :: Word32
+-- TODO StgTSOProfInfo prof is optionally included, but looks very interesting.
+}
 
-peekAllocLimit :: Ptr a -> IO Int64
-peekAllocLimit ptr = (#peek struct StgTSO_, alloc_limit) ptr
+-- | Get non-pointer fields from @StgTSO_@ (@TSO.h@)
+peekTSOFields :: Ptr a -> IO TSOFields
+peekTSOFields ptr = do
+    what_next' <- (#peek struct StgTSO_, what_next) ptr
+    why_blocked' <- (#peek struct StgTSO_, why_blocked) ptr
+    flags' <- (#peek struct StgTSO_, flags) ptr
+    threadId' <- (#peek struct StgTSO_, id) ptr
+    saved_errno' <- (#peek struct StgTSO_, saved_errno) ptr
+    dirty' <- (#peek struct StgTSO_, dirty) ptr
+    alloc_limit' <- (#peek struct StgTSO_, alloc_limit) ptr
+    tot_stack_size' <- (#peek struct StgTSO_, tot_stack_size) ptr
+
+    return TSOFields {
+        what_next = what_next',
+        why_blocked = why_blocked',
+        flags = flags',
+        threadId = threadId',
+        saved_errno = saved_errno',
+        dirty= dirty',
+        alloc_limit = alloc_limit',
+        tot_stack_size = tot_stack_size'
+    }


=====================================
rts/Heap.c
=====================================
@@ -224,12 +224,6 @@ static StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *p
             ASSERT((StgClosure *)((StgTSO *)closure)->bq != NULL);
             ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->bq;
 
-            int threadId = ((StgTSO *)closure)->id;
-            debugBelch("threadId : %u", threadId);
-
-            int alloc_limit = ((StgTSO *)closure)->alloc_limit;
-            debugBelch("alloc_limit : %d", alloc_limit);
-
             break;
         case STACK:
             ptrs[nptrs++] = (StgClosure *)((StgStack *)closure)->sp;



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e78046b7c166ee69e0200dbb8d4c1f3f3f13930

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e78046b7c166ee69e0200dbb8d4c1f3f3f13930
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/20200517/9e13ac58/attachment-0001.html>