[Git][ghc/ghc][wip/ghc-debug] 9 commits: Decode more StgTSO and StgStack fields (#18405)
Sven Tennie
gitlab at gitlab.haskell.org
Sun Jun 28 15:45:20 UTC 2020
Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
bfa5b175 by Sven Tennie at 2020-06-28T17:43:13+02:00
Decode more StgTSO and StgStack fields (#18405)
Use hsc2hs to get an understandable and stable mapping from the C
structs to Haskell.
It's important to keep StgTSO and StgStack decoding downwards
compatible. This is especially needed for hadrian/ghci.
- - - - -
bd23b2da by Sven Tennie at 2020-06-28T17:44:24+02:00
Add comments to RtsApi functions
- - - - -
41675f2e by Sven Tennie at 2020-06-28T17:44:24+02:00
Add test for StgTSO decoding (#18405)
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).
size is renamed to stack_size to use a dedicated type.
size was already defined as a HalfWord in GenClosure, which is
only equivalent to Word32 on 64bit architectures.
- - - - -
8810fe42 by Sven Tennie at 2020-06-28T17:44:24+02:00
Add some documentation
- - - - -
5437f410 by Sven Tennie at 2020-06-28T17:44:24+02:00
Add/update documentation for FindPtrCb
- - - - -
505ae07e by Sven Tennie at 2020-06-28T17:44:24+02:00
Adjust type of getClosureX to type of getClosureDataX (#18405)
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
| ^^^^^^^^^^^
)
- - - - -
b4c6c6be by Sven Tennie at 2020-06-28T17:44:24+02:00
Add test for rts_pause and rts_unpause (#18405)
- - - - -
8855031c by Sven Tennie at 2020-06-28T17:44:24+02:00
Add test list_threads_and_misc_roots (#18405)
It uses rts_listThreads() and rts_listMiscRoots().
- - - - -
c191e5d3 by Sven Tennie at 2020-06-28T17:44:24+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/d98e60e172988bded3070cc568451233297e87e6...c191e5d3c403a8b5dae849c874590657c3e91063
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d98e60e172988bded3070cc568451233297e87e6...c191e5d3c403a8b5dae849c874590657c3e91063
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/23ac5258/attachment-0001.html>
More information about the ghc-commits
mailing list