[Git][ghc/ghc][wip/ghc-debug] Decode more StgTSO fields in ghc-heap

[Sven Tennie]

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


Commits:
203cbc02 by Sven Tennie at 2020-05-10T17:27:51+02:00
Decode more StgTSO fields in ghc-heap

- - - - -


4 changed files:

- includes/rts/storage/TSO.h
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- rts/Heap.c


Changes:

=====================================
includes/rts/storage/TSO.h
=====================================
@@ -107,6 +107,22 @@ typedef struct StgTSO_ {
      */
     struct StgStack_       *stackobj;
 
+    struct InCall_ *bound;
+    struct Capability_ *cap;
+
+    struct StgTRecHeader_ *trec; /* STM transaction record */
+
+    /*
+     * A list of threads blocked on this TSO waiting to throw exceptions.
+     */
+    struct MessageThrowTo_ *blocked_exceptions;
+
+    /*
+     * A list of StgBlockingQueue objects, representing threads
+     * blocked on thunks that are under evaluation by this thread.
+     */
+    struct StgBlockingQueue_ *bq;
+
     /*
      * The tso->dirty flag indicates that this TSO's stack should be
      * scanned during garbage collection.  It also indicates that this
@@ -128,21 +144,6 @@ typedef struct StgTSO_ {
     StgThreadID             id;
     StgWord32               saved_errno;
     StgWord32               dirty;          /* non-zero => dirty */
-    struct InCall_*         bound;
-    struct Capability_*     cap;
-
-    struct StgTRecHeader_ * trec;       /* STM transaction record */
-
-    /*
-     * A list of threads blocked on this TSO waiting to throw exceptions.
-    */
-    struct MessageThrowTo_ * blocked_exceptions;
-
-    /*
-     * A list of StgBlockingQueue objects, representing threads
-     * blocked on thunks that are under evaluation by this thread.
-    */
-    struct StgBlockingQueue_ *bq;
 
     /*
      * The allocation limit for this thread, which is updated as the


=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -287,10 +287,18 @@ getClosureX get_closure_raw x = do
                 , link = pts !! 4
                 }
         TSO -> do
-            unless (length pts >= 1) $
-                fail $ "Expected at least 1 ptr argument to TSO, found "
+            unless (length pts == 6) $
+                fail $ "Expected 6 ptr arguments to TSO, found "
                         ++ show (length pts)
-            pure $ TSOClosure itbl (pts !! 0)
+            pure $ TSOClosure 
+                { info = itbl
+                , _link = (pts !! 0)
+                , global_link = (pts !! 1)
+                , tsoStack = (pts !! 2)
+                , trec = (pts !! 3)
+                , blocked_exceptions = (pts !! 4)
+                , bq = (pts !! 5)
+                } 
         STACK -> do
             unless (length pts >= 1) $
                 fail $ "Expected at least 1 ptr argument to STACK, found "


=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -262,9 +262,16 @@ data GenClosure b
 
   -- TODO: There are many more fields in a TSO closure which
   -- are not yet implemented
+  
+  -- | StgTSO
   | TSOClosure
       { info :: !StgInfoTable
-      , tsoStack :: !b
+      , _link :: !b
+      , global_link :: !b
+      , tsoStack :: !b -- ^ stackobj from StgTSO
+      , trec :: !b
+      , blocked_exceptions :: !b
+      , bq :: !b
       }
 
   | StackClosure


=====================================
rts/Heap.c
=====================================
@@ -206,8 +206,23 @@ static StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *p
             ptrs[nptrs++] = ((StgMVar *)closure)->value;
             break;
         case TSO:
-            // TODO: Not complete
+            ASSERT((StgClosure *)((StgTSO *)closure)->_link != NULL);
+            ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->_link;
+
+            ASSERT((StgClosure *)((StgTSO *)closure)->global_link != NULL);
+            ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->global_link;
+
+            ASSERT((StgClosure *)((StgTSO *)closure)->stackobj != NULL);
             ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->stackobj;
+
+            ASSERT((StgClosure *)((StgTSO *)closure)->trec != NULL);
+            ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->trec;
+
+            ASSERT((StgClosure *)((StgTSO *)closure)->blocked_exceptions != NULL);
+            ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->blocked_exceptions;
+
+            ASSERT((StgClosure *)((StgTSO *)closure)->bq != NULL);
+            ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->bq;
             break;
         case STACK:
             ptrs[nptrs++] = (StgClosure *)((StgStack *)closure)->sp;



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/203cbc02fe3358a5d2300eacce59666b7a4c699a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/203cbc02fe3358a5d2300eacce59666b7a4c699a
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/20200510/e3e2ebcc/attachment-0001.html>