[Git][ghc/ghc][wip/ghc-debug] Export StgTSO fields with the help of hsc2hs

[Sven Tennie]

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


Commits:
aa8bd1d7 by Sven Tennie at 2020-05-11T18:25:38+02:00
Export StgTSO fields with the help of hsc2hs

- - - - -


5 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
- libraries/ghc-heap/ghc-heap.cabal.in
- rts/Heap.c


Changes:

=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Exts.Heap.InfoTableProf
 import GHC.Exts.Heap.InfoTable
 #endif
 import GHC.Exts.Heap.Utils
+import GHC.Exts.Heap.FFIClosures
 
 import Control.Monad
 import Data.Bits
@@ -66,6 +67,8 @@ import GHC.Exts
 import GHC.Int
 import GHC.Word
 
+import Foreign
+
 #include "ghcconfig.h"
 
 class HasHeapRep (a :: TYPE rep) where
@@ -290,6 +293,18 @@ getClosureX get_closure_raw x = do
             unless (length pts == 6) $
                 fail $ "Expected 6 ptr arguments to TSO, found "
                         ++ show (length pts)
+
+            threadId' <- allocaArray (length wds) (\ptr -> do
+                pokeArray ptr wds
+                id <- peekStgThreadID ptr
+                return id
+                )
+            alloc_limit' <- allocaArray (length wds) (\ptr -> do
+                pokeArray ptr wds
+                alloc_limit <- peekAllocLimit ptr
+                return alloc_limit
+                )
+
             pure $ TSOClosure
                 { info = itbl
                 , _link = (pts !! 0)
@@ -298,6 +313,8 @@ getClosureX get_closure_raw x = do
                 , trec = (pts !! 3)
                 , blocked_exceptions = (pts !! 4)
                 , bq = (pts !! 5)
+                , threadId = threadId'
+                , alloc_limit = alloc_limit'
                 }
         STACK -> do
             unless (length pts >= 1) $


=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -266,12 +266,16 @@ data GenClosure b
   -- | StgTSO
   | TSOClosure
       { info :: !StgInfoTable
+      -- pointers
       , _link :: !b
       , global_link :: !b
       , tsoStack :: !b -- ^ stackobj from StgTSO
       , trec :: !b
       , blocked_exceptions :: !b
       , bq :: !b
+      -- values
+      , threadId :: Word64
+      , alloc_limit :: Int64
       }
 
   | StackClosure


=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc
=====================================
@@ -0,0 +1,20 @@
+module GHC.Exts.Heap.FFIClosures where
+
+#include "Rts.h"
+
+import Prelude
+import Foreign
+import Foreign.Ptr
+import Data.Int
+
+import GHC.Exts.Heap.Closures
+
+peekStgThreadID :: Ptr a -> IO Word64
+peekStgThreadID ptr = do
+    id <- (#peek struct StgTSO_, id) ptr
+    return id
+
+peekAllocLimit :: Ptr a -> IO Int64
+peekAllocLimit ptr = do
+    alloc_limit <- (#peek struct StgTSO_, alloc_limit) ptr
+    return alloc_limit


=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -39,3 +39,4 @@ library
                     GHC.Exts.Heap.InfoTable.Types
                     GHC.Exts.Heap.InfoTableProf
                     GHC.Exts.Heap.Utils
+                    GHC.Exts.Heap.FFIClosures


=====================================
rts/Heap.c
=====================================
@@ -223,6 +223,13 @@ 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/aa8bd1d7f49f0290be0c62763231d95c55be3b8c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aa8bd1d7f49f0290be0c62763231d95c55be3b8c
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/20200511/39bee3a5/attachment-0001.html>