[Git][ghc/ghc][wip/ghc-debug] 15 commits: Decode more StgTSO and StgStack fields (#18405)

Sven Tennie gitlab at gitlab.haskell.org
Sun Jun 28 14:58:51 UTC 2020



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


Commits:
dcb1f00d by Sven Tennie at 2020-06-28T16:56:00+02:00
Decode more StgTSO and StgStack fields (#18405)

Use hsc2hs to get an understandable and stable mapping from the C
structs to Haskell.

- - - - -
34455dfd by Sven Tennie at 2020-06-28T16:56:23+02:00
Add comments to RtsApi functions

- - - - -
ac42af19 by Sven Tennie at 2020-06-28T16:56:23+02:00
Make StgTSO and StgStack decoding downwards compatible

This is especially needed for hadrian/ghci.

- - - - -
1a7212a8 by Sven Tennie at 2020-06-28T16:56:23+02:00
Add test for StgTSO decoding

- - - - -
1f219b60 by Sven Tennie at 2020-06-28T16:56:23+02:00
Rename size to stack_size to use dedicated type

size is already defined as a HalfWord in GenClosure, which is
only equivalent to Word32 on 64bit architectures.

- - - - -
5a2ce292 by Sven Tennie at 2020-06-28T16:56:23+02:00
Assert various fields of TSOClosure and StackClosure

This makes sure ghc-heap decodes StgTSO and StgStack correctly.

To assert - otherwise dynamic - properties, a new, non-running TSO is
created in create_tso() (create_tso.c).

- - - - -
3ad94946 by Sven Tennie at 2020-06-28T16:56:23+02:00
Add comment

- - - - -
c1f3e99e by Sven Tennie at 2020-06-28T16:56:23+02:00
Revert changes to TSO.h

The memory layout of StgTSO isn't significant anymore as we decode it
with hsc2hs.

(Of course the basic structure of a closure with an info table must be
still in place, but that's not touched by this commit.)

- - - - -
81e7862a by Sven Tennie at 2020-06-28T16:56:23+02:00
Add some documentation

- - - - -
bc929e74 by Sven Tennie at 2020-06-28T16:56:23+02:00
Add/update documentation for FindPtrCb

- - - - -
ec4e47e3 by Sven Tennie at 2020-06-28T16:56:23+02:00
Adjust type of getClosureX to type of getClosureDataX

After a rebase the compiler complained:

libraries/ghc-heap/GHC/Exts/Heap.hs:89:23: error:
    • Couldn't match type: a -> IO (Ptr StgInfoTable, [Word], [b])
                     with: forall c. c -> IO (Ptr StgInfoTable, [Word], [b])
      Expected: (forall c. c -> IO (Ptr StgInfoTable, [Word], [b]))
                -> a -> IO (GenClosure b)
        Actual: (a -> IO (Ptr StgInfoTable, [Word], [b]))
                -> a -> IO (GenClosure b)
    • In the expression: getClosureX
      In an equation for ‘getClosureDataX’: getClosureDataX = getClosureX
      In the instance declaration for ‘HasHeapRep a’
    • Relevant bindings include
        getClosureDataX :: (forall c.
                            c -> IO (Ptr StgInfoTable, [Word], [b]))
                           -> a -> IO (GenClosure b)
          (bound at libraries/ghc-heap/GHC/Exts/Heap.hs:89:5)
   |
89 |     getClosureDataX = getClosureX
   |                       ^^^^^^^^^^^
)

- - - - -
954af3ab by Sven Tennie at 2020-06-28T16:56:23+02:00
Add a test for rts_pause and rts_unpause

- - - - -
0a6cb9ba by Sven Tennie at 2020-06-28T16:56:23+02:00
Better function signatures & Remove debugging flags

- - - - -
85c0fc59 by Sven Tennie at 2020-06-28T16:56:23+02:00
Add test list_threads_and_misc_roots (#18405)

It uses rts_listThreads() and rts_listMiscRoots().

- - - - -
a44ab6ec by Sven Tennie at 2020-06-28T16:56:23+02:00
Introduce rts_isPaused() (#18405)

Some operations are only save when the RTS is paused. This predicate
helps to make such checks.

- - - - -


20 changed files:

- includes/RtsAPI.h
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/tests/all.T
- + libraries/ghc-heap/tests/create_tso.c
- + libraries/ghc-heap/tests/create_tso.h
- + libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
- + libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c
- + libraries/ghc-heap/tests/list_threads_and_misc_roots_c.h
- + libraries/ghc-heap/tests/tso_and_stack_closures.hs
- rts/Heap.c
- rts/Printer.c
- rts/RtsAPI.c
- + testsuite/tests/rts/ghc-debug/all.T
- + testsuite/tests/rts/ghc-debug/pause_and_unpause.hs
- + testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.c
- + testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.h


Changes:

=====================================
includes/RtsAPI.h
=====================================
@@ -492,14 +492,27 @@ typedef struct RtsPaused_ {
     Capability *capabilities;
 } RtsPaused;
 
+// Halt execution of all Haskell threads.
+// It is different to rts_lock because it pauses all capabilities. rts_lock
+// only pauses a single capability.
+// rts_pause() and rts_unpause() have to be executed from the same OS thread
+// (i.e. myTask() must stay the same).
 RtsPaused rts_pause (void);
+
+// Counterpart of rts_pause: Continue from a pause.
+// rts_pause() and rts_unpause() have to be executed from the same OS thread
+// (i.e. myTask() must stay the same).
 void rts_unpause (RtsPaused paused);
 
-// List all live threads. Must be done while RTS is paused.
+// Tells the current state of the RTS regarding rts_pause() and rts_unpause().
+bool rts_isPaused(void);
+
+// List all live threads. Must be done while RTS is paused (see rts_pause()).
 typedef void (*ListThreadsCb)(void *user, StgTSO *);
 void rts_listThreads(ListThreadsCb cb, void *user);
 
-// List all non-thread GC roots. Must be done while RTS is paused.
+// List all non-thread GC roots. Must be done while RTS is paused (see
+// rts_pause()).
 typedef void (*ListRootsCb)(void *user, StgClosure *);
 void rts_listMiscRoots(ListRootsCb cb, void *user);
 


=====================================
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 qualified GHC.Exts.Heap.FFIClosures as FFIClosures
 
 import Control.Monad
 import Data.Bits
@@ -66,11 +67,23 @@ import GHC.Exts
 import GHC.Int
 import GHC.Word
 
+import Foreign
+
 #include "ghcconfig.h"
 
 class HasHeapRep (a :: TYPE rep) where
-    getClosureDataX :: (forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
-                      -> a -> IO (GenClosure b)
+
+    -- | Decode a closure to it's heap representation ('GenClosure').
+    -- Inside a GHC context 'b' is usually a 'GHC.Exts.Heap.Closures.Box'
+    -- containing a thunk or an evaluated heap object. Outside it can be a
+    -- 'Word' for "raw" usage of pointers.
+    getClosureDataX ::
+        (forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
+        -- ^ Helper function to get info table, memory and pointers of the
+        -- closure. The order of @[b]@ is significant and determined by
+        -- @collect_pointers()@ in @rts/Heap.c at .
+        -> a -- ^ Closure to decode
+        -> IO (GenClosure b) -- ^ Heap representation of the closure
 
 instance HasHeapRep (a :: TYPE 'LiftedRep) where
     getClosureDataX = getClosureX
@@ -112,7 +125,11 @@ amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
     where g (I# i#) = case indexArray# arr# i# of
                           (# e #) -> f e
 
-
+-- | Takes any value (closure) as parameter and returns a tuple of:
+-- * A 'Ptr' to the info table
+-- * The memory of the closure as @[Word]@
+-- * Pointers of the closure's @struct@ (in C code) in a @[Box]@.
+-- The pointers are collected in @Heap.c at .
 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
 getClosureRaw x = do
     case unpackClosure# x of
@@ -135,14 +152,28 @@ getClosureData :: forall rep (a :: TYPE rep) . HasHeapRep a => a -> IO Closure
 getClosureData = getClosureDataX getClosureRaw
 
 
--- | This function returns a parsed heap representation of the argument _at
--- this moment_, even if it is unevaluated or an indirection or other exotic
--- stuff.  Beware when passing something to this function, the same caveats as
--- for 'asBox' apply.
-getClosureX :: forall a b . (a -> IO (Ptr StgInfoTable, [Word], [b]))
-            -> a -> IO (GenClosure b)
+-- | This function returns a parsed heap representation ('GenClosure') of the
+-- closure _at this moment_, even if it is unevaluated or an indirection or
+-- other exotic stuff. Beware when passing something to this function, the same
+-- caveats as for 'asBox' apply.
+--
+-- Inside a GHC context 'b' is usually a 'GHC.Exts.Heap.Closures.Box'
+-- containing a thunk or an evaluated heap object. Outside it can be a
+-- 'Word' for "raw" usage of pointers.
+--
+-- 'get_closure_raw' should provide low level details of the closure's heap
+-- respresentation. The order of @[b]@ is significant and determined by
+-- @collect_pointers()@ in @rts/Heap.c at .
+--
+-- For most use cases 'getClosureData' is an easier to use alternative.
+getClosureX :: forall a b.
+            (forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
+            -- ^ Helper function to get info table, memory and pointers of the
+            -- closure
+            -> a -- ^ Closure to decode
+            -> IO (GenClosure b) -- ^ Heap representation of the closure
 getClosureX get_closure_raw x = do
-    (iptr, wds, pts) <- get_closure_raw x
+    (iptr, wds, pts) <- get_closure_raw (unsafeCoerce# x)
     itbl <- peekItbl iptr
     -- The remaining words after the header
     let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds
@@ -287,30 +318,57 @@ 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)
+
+            allocaArray (length wds) (\ptr -> do
+                pokeArray ptr wds
+
+                fields <- FFIClosures.peekTSOFields ptr
+
+                pure $ TSOClosure
+                    { info = itbl
+                    , _link = (pts !! 0)
+                    , global_link = (pts !! 1)
+                    , tsoStack = (pts !! 2)
+                    , trec = (pts !! 3)
+                    , blocked_exceptions = (pts !! 4)
+                    , bq = (pts !! 5)
+                    , what_next = FFIClosures.tso_what_next fields
+                    , why_blocked = FFIClosures.tso_why_blocked fields
+                    , flags = FFIClosures.tso_flags fields
+                    , threadId = FFIClosures.tso_threadId fields
+                    , saved_errno = FFIClosures.tso_saved_errno fields
+                    , tso_dirty = FFIClosures.tso_dirty fields
+                    , alloc_limit = FFIClosures.tso_alloc_limit fields
+                    , tot_stack_size = FFIClosures.tso_tot_stack_size fields
+                    }
+                )
         STACK -> do
-            unless (length pts >= 1) $
-                fail $ "Expected at least 1 ptr argument to STACK, found "
+            unless (length pts == 1) $
+                fail $ "Expected 1 ptr argument to STACK, found "
                         ++ show (length pts)
-            let splitWord = rawWds !! 0
-            pure $ StackClosure itbl
-#if defined(WORDS_BIGENDIAN)
-                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-                (fromIntegral splitWord)
-#else
-                (fromIntegral splitWord)
-                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-#endif
-                (pts !! 0)
-                []
 
+            allocaArray (length wds) (\ptr -> do
+                pokeArray ptr wds
+
+                fields <- FFIClosures.peekStackFields ptr
+
+                pure $ StackClosure
+                    { info = itbl
+                    , stack_size = FFIClosures.stack_size fields
+                    , stack_dirty = FFIClosures.stack_dirty fields
+                    , stackPointer = (pts !! 0)
+                    , stack  = FFIClosures.stack fields
+#if __GLASGOW_HASKELL__ >= 811
+                    , stack_marking = FFIClosures.stack_marking fields
+#endif
+                    }
+                )
         _ ->
             pure $ UnsupportedClosure itbl
 
 -- | Like 'getClosureDataX', but taking a 'Box', so it is easier to work with.
 getBoxedClosureData :: Box -> IO Closure
 getBoxedClosureData (Box a) = getClosureData a
-


=====================================
libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
=====================================
@@ -81,7 +81,7 @@ data ClosureType
     | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
     | COMPACT_NFDATA
     | N_CLOSURE_TYPES
- deriving (Enum, Eq, Ord, Show, Generic)
+ deriving (Enum, Eq, Ord, Show, Generic, Bounded)
 
 -- | Return the size of the closures header in words
 closureTypeHeaderSize :: ClosureType -> Int


=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -260,18 +260,37 @@ 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
+  -- | Representation of StgTSO: A Thread State Object.
+  -- The values for 'what_next', 'why_blocked' and 'flags' are defined in
+  -- @Constants.h at .
   | TSOClosure
       { info :: !StgInfoTable
-      , tsoStack :: !b
+      -- pointers
+      , _link :: !b
+      , global_link :: !b
+      , tsoStack :: !b -- ^ stackobj from StgTSO
+      , trec :: !b
+      , blocked_exceptions :: !b
+      , bq :: !b
+      -- values
+      , what_next :: Word16
+      , why_blocked :: Word16
+      , flags :: Word32
+      , threadId :: Word64
+      , saved_errno :: Word32
+      , tso_dirty:: Word32 -- ^ non-zero => dirty
+      , alloc_limit :: Int64
+      , tot_stack_size :: Word32
       }
-
+  -- Representation of StgStack: The 'tsoStack' of a 'TSOClosure'.
   | StackClosure
      { info :: !StgInfoTable
-     , size :: !HalfWord
-     , dirty :: !HalfWord
-     , stackPointer :: !b
+     , stack_size :: !Word32 -- ^ stack size in *words*
+     , stack_dirty :: !Word8 -- ^ non-zero => dirty
+#if __GLASGOW_HASKELL__ >= 811
+     , stack_marking :: Word8
+#endif
+     , stackPointer :: !b -- ^ current stack pointer
      , stack :: [Word]
      }
 


=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc
=====================================
@@ -0,0 +1,76 @@
+{-# LANGUAGE CPP #-}
+module GHC.Exts.Heap.FFIClosures where
+
+#include "Rts.h"
+
+import Prelude
+import Foreign
+
+-- TODO use sum type for what_next, why_blocked, flags?
+
+data TSOFields = TSOFields {
+    tso_what_next :: Word16,
+    tso_why_blocked :: Word16,
+    tso_flags :: Word32,
+-- Unfortunately block_info is a union without clear discriminator.
+--    block_info :: TDB,
+    tso_threadId :: Word64,
+    tso_saved_errno :: Word32,
+    tso_dirty:: Word32,
+    tso_alloc_limit :: Int64,
+    tso_tot_stack_size :: Word32
+-- TODO StgTSOProfInfo prof is optionally included, but looks very interesting.
+}
+
+-- | 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 {
+        tso_what_next = what_next',
+        tso_why_blocked = why_blocked',
+        tso_flags = flags',
+        tso_threadId = threadId',
+        tso_saved_errno = saved_errno',
+        tso_dirty= dirty',
+        tso_alloc_limit = alloc_limit',
+        tso_tot_stack_size = tot_stack_size'
+    }
+
+data StackFields = StackFields {
+    stack_size :: Word32,
+    stack_dirty :: Word8,
+#if __GLASGOW_HASKELL__ >= 811
+    stack_marking :: Word8,
+#endif
+    stack :: [Word]
+}
+
+-- | Get non-closure fields from @StgStack_@ (@TSO.h@)
+peekStackFields :: Ptr a -> IO StackFields
+peekStackFields ptr = do
+    stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32
+    dirty' <- (#peek struct StgStack_, dirty) ptr
+#if __GLASGOW_HASKELL__ >= 811
+    marking' <- (#peek struct StgStack_, marking) ptr
+#endif
+
+    let stackPtr = (#ptr struct StgStack_, stack) ptr
+    stack' <- peekArray (fromIntegral stack_size') stackPtr
+
+    return StackFields {
+        stack_size = stack_size',
+        stack_dirty = dirty',
+#if __GLASGOW_HASKELL__ >= 811
+        stack_marking = marking',
+#endif
+        stack = stack'
+    }


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


=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -36,3 +36,16 @@ test('closure_size_noopt',
      ],
      compile_and_run, [''])
 
+test('tso_and_stack_closures',
+     [extra_files(['create_tso.c','create_tso.h']),
+      ignore_stdout,
+      ignore_stderr
+     ],
+     multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], ''])
+
+test('list_threads_and_misc_roots',
+     [extra_files(['list_threads_and_misc_roots_c.c','list_threads_and_misc_roots_c.h']),
+      ignore_stdout,
+      ignore_stderr
+     ],
+     multi_compile_and_run, ['list_threads_and_misc_roots', [('list_threads_and_misc_roots_c.c','')], '-threaded'])


=====================================
libraries/ghc-heap/tests/create_tso.c
=====================================
@@ -0,0 +1,10 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+
+StgTSO* create_tso(){
+    HaskellObj trueClosure = rts_mkBool(&MainCapability, 1);
+
+    StgTSO * tso = createGenThread(&MainCapability, 500U, trueClosure);
+
+    return tso;
+}


=====================================
libraries/ghc-heap/tests/create_tso.h
=====================================
@@ -0,0 +1,3 @@
+#include "RtsAPI.h"
+
+StgTSO* create_tso();


=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
=====================================
@@ -0,0 +1,72 @@
+{-# LANGUAGE MagicHash #-}
+
+import Foreign.Ptr
+import Foreign.Marshal.Array
+import GHC.IORef
+import Control.Concurrent
+import GHC.Exts.Heap
+import GHC.Exts
+
+
+-- Invent a type to bypass the type constraints of getClosureData.
+-- Infact this will be a Word#, that is directly given to unpackClosure#
+-- (which is a primop that expects a pointer to a closure).
+data FoolClosure
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h listThreadsAndMiscRoots"
+    listThreadsAndMiscRoots_c :: IO ()
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h getTSOCount"
+    getTSOCount_c :: IO Int
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h getTSOs"
+    getTSOs_c :: IO (Ptr Word)
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h getMiscRootsCount"
+    getMiscRootsCount_c :: IO Int
+
+foreign import ccall safe "list_threads_and_misc_roots_c.h getMiscRoots"
+    getMiscRoots_c :: IO (Ptr Word)
+
+main :: IO ()
+main = do
+    listThreadsAndMiscRoots_c
+
+    tsoCount <- getTSOCount_c
+    tsos <- getTSOs_c
+    tsoList <- peekArray tsoCount tsos
+    tsoClosures <- mapM createClosure tsoList
+    assertEqual tsoCount $ length tsoClosures
+    mapM (assertEqual TSO) $ map (tipe . info) tsoClosures
+
+    miscRootsCount <- getMiscRootsCount_c
+    miscRoots <- getMiscRoots_c
+    miscRootsList <- peekArray miscRootsCount miscRoots
+    heapClosures <- mapM createClosure miscRootsList
+    assertEqual miscRootsCount $ length heapClosures
+    -- Regarding the type system, this always has to be True, but we want to
+    -- force evaluation / de-serialization with a simple check.
+    mapM assertIsClosureType $ map (tipe . info) heapClosures
+
+    return ()
+
+createClosure :: Word -> IO (GenClosure Box)
+createClosure tsoPtr = do
+    let wPtr = unpackWord# tsoPtr
+    getClosureData ((unsafeCoerce# wPtr) :: FoolClosure)
+
+unpackWord# :: Word -> Word#
+unpackWord# (W# w#) = w#
+
+assertEqual :: (Show a, Eq a) => a -> a -> IO ()
+assertEqual a b
+    | a /= b = error (show a ++ " /= " ++ show b)
+    | otherwise = return ()
+
+assertIsClosureType :: ClosureType -> IO ()
+assertIsClosureType t
+    | t `elem` enumerate = return ()
+    | otherwise = error (show t ++ " not in  " ++ show enumerate)
+    where
+        enumerate :: [ClosureType]
+        enumerate = [minBound..maxBound]


=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c
=====================================
@@ -0,0 +1,54 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "list_threads_and_misc_roots_c.h"
+
+int tsoCount = 0;
+StgTSO** tsos;
+
+int miscRootsCount = 0;
+StgClosure** miscRoots;
+
+void collectTSOsCallback(void *user, StgTSO* tso){
+    tsoCount++;
+    tsos = realloc(tsos, sizeof(StgTSO*) * tsoCount);
+    tsos[tsoCount - 1] = tso;
+}
+
+void collectMiscRootsCallback(void *user, StgClosure* closure){
+    miscRootsCount++;
+    miscRoots = realloc(miscRoots, sizeof(StgClosure*) * miscRootsCount);
+    miscRoots[miscRootsCount - 1] = closure;
+}
+
+void* listThreads_thread(void* unused){
+    RtsPaused paused = rts_pause();
+    rts_listThreads(&collectTSOsCallback, NULL);
+    rts_listMiscRoots(&collectMiscRootsCallback, NULL);
+    rts_unpause(paused);
+
+    return NULL;
+}
+
+void listThreadsAndMiscRoots(void){
+    pthread_t threadId;
+    pthread_create(&threadId, NULL, &listThreads_thread, NULL);
+    pthread_join(threadId, NULL);
+}
+
+int getTSOCount(void){
+    return tsoCount;
+}
+
+StgTSO** getTSOs(void){
+    return tsos;
+}
+
+int getMiscRootsCount(void){
+    return miscRootsCount;
+}
+
+StgClosure** getMiscRoots(void){
+    return miscRoots;
+}


=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots_c.h
=====================================
@@ -0,0 +1,11 @@
+#include "Rts.h"
+
+void listThreadsAndMiscRoots(void);
+
+int getTSOCount(void);
+
+StgTSO** getTSOs(void);
+
+int getMiscRootsCount(void);
+
+StgClosure** getMiscRoots(void);


=====================================
libraries/ghc-heap/tests/tso_and_stack_closures.hs
=====================================
@@ -0,0 +1,77 @@
+{-# LANGUAGE ForeignFunctionInterface, MagicHash, CPP, BangPatterns #-}
+
+import Foreign
+import Foreign.C.Types
+import GHC.Exts.Heap
+import GHC.Exts
+
+import GHC.Word
+
+#include "ghcconfig.h"
+#include "rts/Constants.h"
+
+foreign import ccall unsafe "create_tso.h create_tso"
+    c_create_tso:: IO Word
+
+-- Invent a type to bypass the type constraints of getClosureData.
+-- Infact this will be a Word#, that is directly given to unpackClosure#
+-- (which is a primop that expects a pointer to a closure).
+data FoolStgTSO
+
+-- We can make some assumptions about the - otherwise dynamic - properties of
+-- StgTSO and StgStack, because a new, non-running TSO is created with
+-- create_tso() (create_tso.c).create_tso
+main :: IO ()
+main = do
+    tso <- createTSOClosure
+    assertEqual (what_next tso) ThreadRunGHC
+    assertEqual (why_blocked tso) NotBlocked
+    assertEqual (saved_errno tso) 0
+
+    print $ "tso : "++ show tso
+
+    -- The newly created TSO should be on the end of the run queue.
+    let !_linkBox = _link tso
+    _linkClosure <- getBoxedClosureData _linkBox
+    assertEqual (name _linkClosure) "END_TSO_QUEUE"
+
+    let !global_linkBox = global_link tso
+    globalLinkClosure <- getBoxedClosureData global_linkBox
+    assertEqual (getClosureType globalLinkClosure) TSO
+
+    let !stackBox = tsoStack tso
+    stackClosure <- getBoxedClosureData stackBox
+    assertEqual (getClosureType stackClosure) STACK
+
+    let !stackPointerBox = stackPointer stackClosure
+    stackPointerClosure <- getBoxedClosureData stackPointerBox
+    assertEqual (getClosureType stackPointerClosure) RET_SMALL
+
+    let !trecBox = trec tso
+    trecClosure <- getBoxedClosureData trecBox
+    assertEqual (name trecClosure) "NO_TREC"
+
+    let !blockedExceptionsBox = blocked_exceptions tso
+    blockedExceptionsClosure <- getBoxedClosureData blockedExceptionsBox
+    assertEqual (name blockedExceptionsClosure) "END_TSO_QUEUE"
+
+    let !bqBox = bq tso
+    bqClosure <- getBoxedClosureData bqBox
+    assertEqual (name bqClosure) "END_TSO_QUEUE"
+
+createTSOClosure :: IO (GenClosure Box)
+createTSOClosure = do
+    ptr <- c_create_tso
+    let wPtr = unpackWord# ptr
+    getClosureData ((unsafeCoerce# wPtr) :: FoolStgTSO)
+
+unpackWord# :: Word -> Word#
+unpackWord# (W# w#) = w#
+
+assertEqual :: (Show a, Eq a) => a -> a -> IO ()
+assertEqual a b
+  | a /= b = error (show a ++ " /= " ++ show b)
+  | otherwise = return ()
+
+getClosureType :: GenClosure b -> ClosureType
+getClosureType = tipe . info


=====================================
rts/Heap.c
=====================================
@@ -206,14 +206,29 @@ 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:
+            ASSERT((StgClosure *)((StgStack *)closure)->sp != NULL);
             ptrs[nptrs++] = (StgClosure *)((StgStack *)closure)->sp;
             break;
-
-
         case WEAK:
             ptrs[nptrs++] = (StgClosure *)((StgWeak *)closure)->cfinalizers;
             ptrs[nptrs++] = (StgClosure *)((StgWeak *)closure)->key;
@@ -232,6 +247,13 @@ static StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *p
 }
 
 StgArrBytes *heap_view_closurePtrsAsWords(Capability *cap, StgClosure *closure) {
+    if(!rts_isPaused()){
+        errorBelch("Warning: "
+            "The RTS must be paused (see rts_pause()) to inspect it's heap!");
+
+        return NULL;
+    }
+
     ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
 
     StgWord size = heap_view_closureSize(closure);


=====================================
rts/Printer.c
=====================================
@@ -852,10 +852,12 @@ extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
 
 #endif /* USING_LIBBFD */
 
-// findPtr takes a callback so external tools such as ghc-debug can invoke it
-// and intercept the intermediate results. When findPtr successfully finds
-// a closure containing an address then the callback is called on the address
-// of that closure. The `StgClosure` argument is an untagged closure pointer.
+// findPtrCb takes a callback of type FindPtrCb, so external tools (such as
+// ghc-debug) can invoke it and intercept the intermediate results.
+// When findPtrCb successfully finds a closure containing an address then the
+// callback is called on the address of that closure.
+// The `StgClosure` argument is an untagged closure pointer.
+// `user` points to any data provided by the caller. It's not used internally.
 typedef void (*FindPtrCb)(void *user, StgClosure *);
 
 void findPtr(P_ p, int);                /* keep gcc -Wall happy */
@@ -949,11 +951,14 @@ findPtr_gen(FindPtrCb cb, void *user, P_ p, int follow)
   }
 }
 
-void
-findPtr(P_ p, int follow){
+// Special case of findPtrCb: Uses a default callback, that prints the closure
+// pointed to by p.
+void findPtr(P_ p, int follow){
   findPtr_gen(&findPtr_default_callback, NULL, p, follow);
 }
 
+// Call cb on the closure pointed to by p.
+// FindPtrCb is documented where it's defined.
 void findPtrCb(FindPtrCb cb, void* user, P_ p){
   findPtr_gen(cb, user, p, 0);
 }


=====================================
rts/RtsAPI.c
=====================================
@@ -651,6 +651,8 @@ static bool rts_paused = false;
 // Halt execution of all Haskell threads.
 // It is different to rts_lock because it pauses all capabilities. rts_lock
 // only pauses a single capability.
+// rts_pause() and rts_unpause() have to be executed from the same OS thread
+// (i.e. myTask() must stay the same).
 RtsPaused rts_pause (void)
 {
     struct RtsPaused_ paused;
@@ -660,14 +662,26 @@ RtsPaused rts_pause (void)
     return paused;
 }
 
-void rts_unpause (RtsPaused  paused)
+// Counterpart of rts_pause: Continue from a pause.
+// rts_pause() and rts_unpause() have to be executed from the same OS thread
+// (i.e. myTask() must stay the same).
+void rts_unpause (RtsPaused paused)
 {
     rts_paused = false;
     releaseAllCapabilities(n_capabilities, paused.capabilities, paused.pausing_task);
     freeTask(paused.pausing_task);
 }
 
+// Tells the current state of the RTS regarding rts_pause() and rts_unpause().
+bool rts_isPaused(void)
+{
+    return rts_paused;
+}
 
+// Call cb for all StgTSOs. *user is a user defined payload to cb. It's not
+// used by the RTS.
+// rts_listThreads should only be called when the RTS is paused, i.e. rts_pause
+// was called before.
 void rts_listThreads(ListThreadsCb cb, void *user)
 {
     ASSERT(rts_paused);
@@ -691,6 +705,11 @@ static void list_roots_helper(void *user, StgClosure **p) {
     ctx->cb(ctx->user, *p);
 }
 
+// Call cb for all StgClosures reachable from threadStableNameTable and
+// threadStablePtrTable. *user is a user defined payload to cb. It's not
+// used by the RTS.
+// rts_listMiscRoots should only be called when the RTS is paused, i.e.
+// rts_pause was called before.
 void rts_listMiscRoots (ListRootsCb cb, void *user)
 {
     struct list_roots_ctx ctx;
@@ -713,12 +732,19 @@ RtsPaused rts_pause (void)
     return paused;
 }
 
-void rts_unpause (RtsPaused  paused STG_UNUSED)
+void rts_unpause (RtsPaused paused STG_UNUSED)
 {
     errorBelch("Warning: Unpausing the RTS is only possible for "
                "multithreaded RTS.");
 }
 
+bool rts_isPaused(void)
+{
+    errorBelch("Warning: (Un-) Pausing the RTS is only possible for "
+               "multithreaded RTS.");
+    return false;
+}
+
 
 void rts_listThreads(ListThreadsCb cb STG_UNUSED, void *user STG_UNUSED)
 {


=====================================
testsuite/tests/rts/ghc-debug/all.T
=====================================
@@ -0,0 +1,6 @@
+test('pause_and_unpause',
+     [ extra_files(['pause_and_unpause_thread.c','pause_and_unpause_thread.h']),
+      ignore_stdout,
+      ignore_stderr
+     ],
+     multi_compile_and_run, ['pause_and_unpause', [('pause_and_unpause_thread.c','')], '-threaded'])


=====================================
testsuite/tests/rts/ghc-debug/pause_and_unpause.hs
=====================================
@@ -0,0 +1,73 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+import Data.Word
+import Data.IORef
+import GHC.Clock
+import Control.Concurrent
+import Foreign.C.Types
+import System.Mem
+import Control.Monad
+
+foreign import ccall safe "pause_and_unpause_thread.h pauseAndUnpause"
+    pauseAndUnpause_c :: IO ()
+
+foreign import ccall safe "pause_and_unpause_thread.h getUnixTime"
+    getUnixTime_c :: IO CTime
+
+foreign import ccall safe "pause_and_unpause_thread.h getPauseBegin"
+    getPauseBegin_c :: IO CTime
+
+foreign import ccall safe "pause_and_unpause_thread.h getPauseEnd"
+    getPauseEnd_c :: IO CTime
+
+clockEachSecond :: IORef [CTime] -> IO ()
+clockEachSecond ref = forever $ do
+  time <- getUnixTime_c
+  timesList <- readIORef ref
+  writeIORef ref $ time : timesList
+
+  sleepSeconds 1
+
+{- To show that rts_pause() and rts_unpause() work, clockEachSecond adds the
+current unix time to a list (once per Second). pauseAndUnpause_c stops the RTS
+for 5 Seconds. Thus there's an invariant that there should be no timestamp in
+the list that is in this 5 Seconds wide timeframe, which is defined by
+getPauseBegin_c and getPauseEnd_c. -}
+main :: IO ()
+main = do
+    ref <- newIORef []
+    forkIO $ clockEachSecond ref
+
+    sleepSeconds 3
+
+    pauseAndUnpause_c
+
+    -- This seems to sleep for 8 - 5 Seconds. That's strange, but should be
+    -- good enough for this test.
+    -- 5 Seconds is the time the whole RTS is paused. But I (Sven) don't
+    -- understand how this relates.
+    sleepSeconds 8
+
+    times <- readIORef ref
+
+    pauseBegin <- getPauseBegin_c
+    pauseEnd <- getPauseEnd_c
+    filter (\t -> pauseBegin < t && t < pauseEnd) times `shouldBe` []
+    filter (\t -> t <= pauseBegin) times `shouldNotBe` []
+    filter (\t -> t >= pauseEnd) times `shouldNotBe` []
+
+    return ()
+
+sleepSeconds :: Int -> IO ()
+sleepSeconds t = threadDelay $ oneSecondInMicroSeconds * t
+
+oneSecondInMicroSeconds :: Int
+oneSecondInMicroSeconds = 1000000
+
+shouldBe :: (Eq a, Show a) => a -> a -> IO ()
+shouldBe x y =
+  unless (x == y) $ fail $ show x ++ " is not equal to " ++ show y
+
+shouldNotBe :: (Eq a, Show a) => a -> a -> IO ()
+shouldNotBe x y =
+  unless (x /= y) $ fail $ show x ++ " is equal to " ++ show y


=====================================
testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.c
=====================================
@@ -0,0 +1,45 @@
+#include <pthread.h>
+#include <time.h>
+#include <unistd.h>
+#include "pause_and_unpause_thread.h"
+#include "Rts.h"
+#include "RtsAPI.h"
+
+#include <stdio.h>
+
+struct PauseTimestamps timestamps = {0, 0};
+
+void* pauseAndUnpause_thread(void* unused){
+    RtsPaused r_paused = rts_pause();
+
+    if(!rts_isPaused()) {
+        errorBelch("Expected the RTS to be paused.");
+        exit(1);
+    }
+
+    timestamps.begin = time(NULL);
+    sleep(5);
+    timestamps.end = time(NULL);
+
+    rts_unpause(r_paused);
+
+    return NULL;
+}
+
+void pauseAndUnpause(void){
+    pthread_t threadId;
+    pthread_create(&threadId, NULL, &pauseAndUnpause_thread, NULL);
+    pthread_detach(threadId);
+}
+
+time_t getPauseBegin(void) {
+    return timestamps.begin;
+}
+
+time_t getPauseEnd(void) {
+    return timestamps.end;
+}
+
+time_t getUnixTime(void){
+    return time(NULL);
+}


=====================================
testsuite/tests/rts/ghc-debug/pause_and_unpause_thread.h
=====================================
@@ -0,0 +1,11 @@
+#include <time.h>
+
+struct PauseTimestamps{
+    time_t begin;
+    time_t end;
+};
+
+void pauseAndUnpause(void);
+time_t getPauseBegin(void);
+time_t getPauseEnd(void);
+time_t getUnixTime(void);



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ffd67f4d8d977453d7534b2d0dcf21ed2e5deba...a44ab6ec4c5d9ad229bb7f1cd8849b4900f2889e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ffd67f4d8d977453d7534b2d0dcf21ed2e5deba...a44ab6ec4c5d9ad229bb7f1cd8849b4900f2889e
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/20200628/2c584f3f/attachment-0001.html>


More information about the ghc-commits mailing list