[Git][ghc/ghc][wip/ghc-debug] 16 commits: rts: Implement ghc-debug API (#18405)
Sven Tennie
gitlab at gitlab.haskell.org
Sun Jun 28 15:14:25 UTC 2020
Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
9f51391a by Matthew Pickering at 2020-06-28T17:11:23+02:00
rts: Implement ghc-debug API (#18405)
There are four components to this patch which make it possible to
implement `ghc-debug`.
1. Add four new functions to the RtsAPI.
* rts_pause and rts_unpause allow an external process to completely
pause and unpause the RTS.
* rts_listThreads and rts_listMiscRoots are used to find the current
roots of the garbage collector.
These changes also mean that `Task.h` is exposed to the user.
2. Generalise the `ghc-heap` API so that raw `Word`s can be returned
rather than actual objects. This is necessary when trying to decode
closures on an external process because the pointers in such closures
are correct for the internal rather than external process. If you used
the previous API then you would get a segfault as the garbage collector
would try to traverse into these nonsensical branches.
```
-- before
getClosureData :: a -> IO Closure
-- after
getClosureDataX :: (forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
-> a -> IO (GenClosure b)
```
For the normal case `b` is instantiated to `Box`, which contains a
pointer to a heap object.
```
data Box = Box a
-- GenClosure Box
```
For `ghc-debug` we instead just take the word of the address as we have
to explicitly interpret it on the external process.
```
GenClosure Word
```
3. Support for decoding `TSO` and `STACK` closures is partially
implemented. There is still quite a bit of work to do to finish both but
these at least allow us to make some more progress.
4. findPtr is generalised to take a callback argument. This means that
its result can be communicated to the debugger rather than just printing
out the result. The debugger has a function which invokes `findPtr` and
passes a callback which sends the result over a socket.
Co-authored-by: Ben Gamari <ben at smart-cactus.org>
- - - - -
3a1cb87d by Sven Tennie at 2020-06-28T17:12:02+02:00
Decode more StgTSO and StgStack fields (#18405)
Use hsc2hs to get an understandable and stable mapping from the C
structs to Haskell.
- - - - -
256946ff by Sven Tennie at 2020-06-28T17:12:02+02:00
Add comments to RtsApi functions
- - - - -
f4451002 by Sven Tennie at 2020-06-28T17:12:02+02:00
Make StgTSO and StgStack decoding downwards compatible
This is especially needed for hadrian/ghci.
- - - - -
819b1e93 by Sven Tennie at 2020-06-28T17:12:02+02:00
Add test for StgTSO decoding
- - - - -
a37471c2 by Sven Tennie at 2020-06-28T17:12:02+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.
- - - - -
fe0a1c4c by Sven Tennie at 2020-06-28T17:12:02+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).
- - - - -
fbdc7bfe by Sven Tennie at 2020-06-28T17:12:02+02:00
Add comment
- - - - -
55ba7498 by Sven Tennie at 2020-06-28T17:12:02+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.)
- - - - -
4c3af5d5 by Sven Tennie at 2020-06-28T17:12:02+02:00
Add some documentation
- - - - -
9d5ef2b1 by Sven Tennie at 2020-06-28T17:12:02+02:00
Add/update documentation for FindPtrCb
- - - - -
50dee362 by Sven Tennie at 2020-06-28T17:12:02+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
| ^^^^^^^^^^^
)
- - - - -
ffb2e429 by Sven Tennie at 2020-06-28T17:12:02+02:00
Add a test for rts_pause and rts_unpause
- - - - -
6f1923ac by Sven Tennie at 2020-06-28T17:12:02+02:00
Better function signatures & Remove debugging flags
- - - - -
66e153f8 by Sven Tennie at 2020-06-28T17:12:02+02:00
Add test list_threads_and_misc_roots (#18405)
It uses rts_listThreads() and rts_listMiscRoots().
- - - - -
fe541469 by Sven Tennie at 2020-06-28T17:12:02+02:00
Introduce rts_isPaused() (#18405)
Some operations are only save when the RTS is paused. This predicate
helps to make such checks.
- - - - -
27 changed files:
- includes/Rts.h
- includes/RtsAPI.h
- + includes/rts/Task.h
- includes/rts/storage/Heap.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
- rts/Schedule.c
- rts/Task.c
- rts/Task.h
- rts/rts.cabal.in
- + 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/Rts.h
=====================================
@@ -223,6 +223,7 @@ void _assertFail(const char *filename, unsigned int linenum)
#include "rts/Globals.h"
#include "rts/IOManager.h"
#include "rts/Linker.h"
+#include "rts/Task.h"
#include "rts/Ticky.h"
#include "rts/Timer.h"
#include "rts/StablePtr.h"
=====================================
includes/RtsAPI.h
=====================================
@@ -16,7 +16,9 @@ extern "C" {
#endif
#include "HsFFI.h"
+#include "rts/Types.h"
#include "rts/Time.h"
+#include "rts/Task.h"
#include "rts/EventLogWriter.h"
/*
@@ -483,6 +485,37 @@ void rts_checkSchedStatus (char* site, Capability *);
SchedulerStatus rts_getSchedStatus (Capability *cap);
+// Various bits of information that need to be persisted between rts_pause and
+// rts_unpause.
+typedef struct RtsPaused_ {
+ Task *pausing_task;
+ 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);
+
+// 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 (see
+// rts_pause()).
+typedef void (*ListRootsCb)(void *user, StgClosure *);
+void rts_listMiscRoots(ListRootsCb cb, void *user);
+
/*
* The RTS allocates some thread-local data when you make a call into
* Haskell using one of the rts_eval() functions. This data is not
=====================================
includes/rts/Task.h
=====================================
@@ -0,0 +1,40 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Task API
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+typedef struct Task_ Task;
+
+// Create a new Task for a bound thread. This Task must be released
+// by calling boundTaskExiting. The Task is cached in
+// thread-local storage and will remain even after boundTaskExiting()
+// has been called; to free the memory, see freeMyTask().
+//
+Task* newBoundTask (void);
+
+// Return the current OS thread's Task, which is created if it doesn't already
+// exist. After you have finished using RTS APIs, you should call freeMyTask()
+// to release this thread's Task.
+Task* getTask (void);
+
+// The current task is a bound task that is exiting.
+//
+void boundTaskExiting (Task *task);
+
+// Free a Task if one was previously allocated by newBoundTask().
+// This is not necessary unless the thread that called newBoundTask()
+// will be exiting, or if this thread has finished calling Haskell
+// functions.
+//
+void freeMyTask(void);
+
=====================================
includes/rts/storage/Heap.h
=====================================
@@ -11,6 +11,7 @@
#include "rts/storage/Closures.h"
StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure);
+StgArrBytes *heap_view_closurePtrsAsWords(Capability *cap, StgClosure *closure);
void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs
, StgClosure *fun, StgClosure **payload, StgWord size);
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -7,6 +7,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE RankNTypes #-}
{-|
Module : GHC.Exts.Heap
@@ -24,7 +26,8 @@ module GHC.Exts.Heap (
, GenClosure(..)
, ClosureType(..)
, PrimType(..)
- , HasHeapRep(getClosureData)
+ , HasHeapRep(getClosureDataX)
+ , getClosureData
-- * Info Table types
, StgInfoTable(..)
@@ -55,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
@@ -63,78 +67,113 @@ import GHC.Exts
import GHC.Int
import GHC.Word
+import Foreign
+
#include "ghcconfig.h"
class HasHeapRep (a :: TYPE rep) where
- getClosureData :: a -> IO Closure
+
+ -- | 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
- getClosureData = getClosure
+ getClosureDataX = getClosureX
instance HasHeapRep (a :: TYPE 'UnliftedRep) where
- getClosureData x = getClosure (unsafeCoerce# x)
+ getClosureDataX k x = getClosureX (k . unsafeCoerce#) (unsafeCoerce# x)
instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
- getClosureData x = return $
+ getClosureDataX _ x = return $
IntClosure { ptipe = PInt, intVal = I# x }
instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where
- getClosureData x = return $
+ getClosureDataX _ x = return $
WordClosure { ptipe = PWord, wordVal = W# x }
instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where
- getClosureData x = return $
+ getClosureDataX _ x = return $
Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) }
instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where
- getClosureData x = return $
+ getClosureDataX _ x = return $
Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) }
instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where
- getClosureData x = return $
+ getClosureDataX _ x = return $
AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) }
instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where
- getClosureData x = return $
+ getClosureDataX _ x = return $
FloatClosure { ptipe = PFloat, floatVal = F# x }
instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
- getClosureData x = return $
+ getClosureDataX _ x = return $
DoubleClosure { ptipe = PDouble, doubleVal = D# x }
--- | This returns the raw representation of the given argument. The second
--- component of the triple is the raw words of the closure on the heap, and the
--- third component is those words that are actually pointers. Once back in the
--- Haskell world, the raw words that hold pointers may be outdated after a
--- garbage collector run, but the corresponding values in 'Box's will still
--- point to the correct value.
+-- From GHC.Runtime.Heap.Inspect
+amap' :: (t -> b) -> Array Int t -> [b]
+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
-- This is a hack to cover the bootstrap compiler using the old version of
-- 'unpackClosure'. The new 'unpackClosure' return values are not merely
-- a reordering, so using the old version would not work.
+#if MIN_VERSION_ghc_prim(0,5,3)
(# iptr, dat, pointers #) -> do
- let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
- end = fromIntegral nelems - 1
- rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]
- pelems = I# (sizeofArray# pointers)
- ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers
- pure (Ptr iptr, rawWds, ptrList)
-
--- From GHC.Runtime.Heap.Inspect
-amap' :: (t -> b) -> Array Int t -> [b]
-amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
- where g (I# i#) = case indexArray# arr# i# of
- (# e #) -> f e
-
--- | 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.
-getClosure :: a -> IO Closure
-getClosure x = do
- (iptr, wds, pts) <- getClosureRaw x
+#else
+ (# iptr, pointers, dat #) -> do
+#endif
+ let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
+ end = fromIntegral nelems - 1
+ rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]
+ pelems = I# (sizeofArray# pointers)
+ ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers
+ pure (Ptr iptr, rawWds, ptrList)
+
+getClosureData :: forall rep (a :: TYPE rep) . HasHeapRep a => a -> IO Closure
+getClosureData = getClosureDataX getClosureRaw
+
+
+-- | 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 (unsafeCoerce# x)
itbl <- peekItbl iptr
-- The remaining words after the header
let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds
@@ -250,7 +289,10 @@ getClosure x = do
++ "found " ++ show (length rawWds)
pure $ SmallMutArrClosure itbl (rawWds !! 0) pts
- t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
+ t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do
+ unless (length pts >= 1) $
+ fail $ "Expected at least 1 words to MUT_VAR, found "
+ ++ show (length pts)
pure $ MutVarClosure itbl (head pts)
t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
@@ -266,7 +308,6 @@ getClosure x = do
-- pure $ OtherClosure itbl pts wds
--
-
WEAK ->
pure $ WeakClosure
{ info = itbl
@@ -276,10 +317,58 @@ getClosure x = do
, finalizer = pts !! 3
, link = pts !! 4
}
+ TSO -> do
+ unless (length pts == 6) $
+ fail $ "Expected 6 ptr arguments to TSO, found "
+ ++ show (length pts)
+
+ 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 1 ptr argument to STACK, found "
+ ++ show (length pts)
+ 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 'getClosureData', but taking a 'Box', so it is easier to work with.
+-- | 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,6 +260,40 @@ data GenClosure b
, link :: !b -- ^ next weak pointer for the capability, can be NULL.
}
+ -- | 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
+ -- 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
+ , 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]
+ }
+
------------------------------------------------------------
-- Unboxed unlifted closures
=====================================
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
=====================================
@@ -76,23 +76,15 @@ void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs
}
}
-StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
- ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
-
- StgWord size = heap_view_closureSize(closure);
- StgWord nptrs = 0;
- StgWord i;
-
- // First collect all pointers here, with the comfortable memory bound
- // of the whole closure. Afterwards we know how many pointers are in
- // the closure and then we can allocate space on the heap and copy them
- // there
- StgClosure *ptrs[size];
-
+/*
+ * Collect the pointers of a closure into the given array. size should be
+ * heap_view_closureSize(closure). Returns the number of pointers collected.
+ */
+static StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *ptrs[size]) {
StgClosure **end;
- StgClosure **ptr;
-
const StgInfoTable *info = get_itbl(closure);
+ StgWord nptrs = 0;
+ StgWord i;
switch (info->type) {
case INVALID_OBJECT:
@@ -123,7 +115,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
case FUN_0_2:
case FUN_STATIC:
end = closure->payload + info->layout.payload.ptrs;
- for (ptr = closure->payload; ptr < end; ptr++) {
+ for (StgClosure **ptr = closure->payload; ptr < end; ptr++) {
ptrs[nptrs++] = *ptr;
}
break;
@@ -136,7 +128,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
case THUNK_0_2:
case THUNK_STATIC:
end = ((StgThunk *)closure)->payload + info->layout.payload.ptrs;
- for (ptr = ((StgThunk *)closure)->payload; ptr < end; ptr++) {
+ for (StgClosure **ptr = ((StgThunk *)closure)->payload; ptr < end; ptr++) {
ptrs[nptrs++] = *ptr;
}
break;
@@ -213,7 +205,30 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
ptrs[nptrs++] = (StgClosure *)((StgMVar *)closure)->tail;
ptrs[nptrs++] = ((StgMVar *)closure)->value;
break;
+ case TSO:
+ 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;
@@ -228,6 +243,52 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
break;
}
+ return nptrs;
+}
+
+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);
+
+ // First collect all pointers here, with the comfortable memory bound
+ // of the whole closure. Afterwards we know how many pointers are in
+ // the closure and then we can allocate space on the heap and copy them
+ // there
+ StgClosure *ptrs[size];
+ StgWord nptrs = collect_pointers(closure, size, ptrs);
+ StgArrBytes *arr =
+ (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + nptrs);
+ TICK_ALLOC_PRIM(sizeofW(StgArrBytes), nptrs, 0);
+ SET_HDR(arr, &stg_ARR_WORDS_info, cap->r.rCCCS);
+ arr->bytes = sizeof(StgWord) * nptrs;
+
+ for (StgWord i = 0; i<nptrs; i++) {
+ arr->payload[i] = (StgWord)ptrs[i];
+ }
+
+ return arr;
+}
+
+StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+
+ StgWord size = heap_view_closureSize(closure);
+
+ // First collect all pointers here, with the comfortable memory bound
+ // of the whole closure. Afterwards we know how many pointers are in
+ // the closure and then we can allocate space on the heap and copy them
+ // there
+ StgClosure *ptrs[size];
+ StgWord nptrs = collect_pointers(closure, size, ptrs);
+
size = nptrs + mutArrPtrsCardTableSize(nptrs);
StgMutArrPtrs *arr =
(StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
@@ -236,7 +297,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
arr->ptrs = nptrs;
arr->size = size;
- for (i = 0; i<nptrs; i++) {
+ for (StgWord i = 0; i<nptrs; i++) {
arr->payload[i] = ptrs[i];
}
=====================================
rts/Printer.c
=====================================
@@ -697,7 +697,7 @@ void printLargeAndPinnedObjects()
for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
Capability *cap = capabilities[cap_idx];
- debugBelch("Capability %d: Current pinned object block: %p\n",
+ debugBelch("Capability %d: Current pinned object block: %p\n",
cap_idx, (void*)cap->pinned_object_block);
for (bdescr *bd = cap->pinned_object_blocks; bd; bd = bd->link) {
debugBelch("%p\n", (void*)bd);
@@ -852,12 +852,28 @@ extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
#endif /* USING_LIBBFD */
+// 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 */
+void findPtrCb(FindPtrCb cb, void *, P_ p); /* keep gcc -Wall happy */
+
+static void
+findPtr_default_callback(void *user STG_UNUSED, StgClosure * closure){
+ debugBelch("%p = ", closure);
+ printClosure((StgClosure *)closure);
+}
+
int searched = 0;
static int
-findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
+findPtrBlocks (FindPtrCb cb, void* user, StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
{
StgPtr q, r, end;
for (; bd; bd = bd->link) {
@@ -875,8 +891,7 @@ findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
}
end = r + closure_sizeW((StgClosure*)r);
if (q < end) {
- debugBelch("%p = ", r);
- printClosure((StgClosure *)r);
+ cb(user, (StgClosure *) r);
arr[i++] = r;
break;
}
@@ -893,8 +908,8 @@ findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
return i;
}
-void
-findPtr(P_ p, int follow)
+static void
+findPtr_gen(FindPtrCb cb, void *user, P_ p, int follow)
{
uint32_t g, n;
bdescr *bd;
@@ -916,24 +931,38 @@ findPtr(P_ p, int follow)
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
bd = generations[g].blocks;
- i = findPtrBlocks(p,bd,arr,arr_size,i);
+ i = findPtrBlocks(cb, user,p,bd,arr,arr_size,i);
bd = generations[g].large_objects;
- i = findPtrBlocks(p,bd,arr,arr_size,i);
+ i = findPtrBlocks(cb, user, p,bd,arr,arr_size,i);
if (i >= arr_size) return;
for (n = 0; n < n_capabilities; n++) {
- i = findPtrBlocks(p, gc_threads[n]->gens[g].part_list,
+ i = findPtrBlocks(cb, user, p, gc_threads[n]->gens[g].part_list,
arr, arr_size, i);
- i = findPtrBlocks(p, gc_threads[n]->gens[g].todo_bd,
+ i = findPtrBlocks(cb, user, p, gc_threads[n]->gens[g].todo_bd,
arr, arr_size, i);
}
if (i >= arr_size) return;
}
if (follow && i == 1) {
+ ASSERT(cb == &findPtr_default_callback);
debugBelch("-->\n");
+ // Non-standard callback expects follow=0
findPtr(arr[0], 1);
}
}
+// 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);
+}
+
const char *what_next_strs[] = {
[0] = "(unknown)",
[ThreadRunGHC] = "ThreadRunGHC",
=====================================
rts/RtsAPI.c
=====================================
@@ -18,6 +18,7 @@
#include "StablePtr.h"
#include "Threads.h"
#include "Weak.h"
+#include "StableName.h"
/* ----------------------------------------------------------------------------
Building Haskell objects from C datatypes.
@@ -645,6 +646,119 @@ rts_unlock (Capability *cap)
}
}
+#if defined(THREADED_RTS)
+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;
+ paused.pausing_task = newBoundTask();
+ stopAllCapabilities(&paused.capabilities, paused.pausing_task);
+ rts_paused = true;
+ return 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);
+ for (uint32_t g=0; g < RtsFlags.GcFlags.generations; g++) {
+ StgTSO *tso = generations[g].threads;
+ while (tso != END_TSO_QUEUE) {
+ cb(user, tso);
+ tso = tso->global_link;
+ }
+ }
+}
+
+struct list_roots_ctx {
+ ListRootsCb cb;
+ void *user;
+};
+
+// This is an evac_fn.
+static void list_roots_helper(void *user, StgClosure **p) {
+ struct list_roots_ctx *ctx = (struct list_roots_ctx *) user;
+ 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;
+ ctx.cb = cb;
+ ctx.user = user;
+
+ ASSERT(rts_paused);
+ threadStableNameTable(&list_roots_helper, (void *)&ctx);
+ threadStablePtrTable(&list_roots_helper, (void *)&ctx);
+}
+
+#else
+RtsPaused rts_pause (void)
+{
+ errorBelch("Warning: Pausing the RTS is only possible for "
+ "multithreaded RTS.");
+ struct RtsPaused_ paused;
+ paused.pausing_task = NULL;
+ paused.capabilities = NULL;
+ return paused;
+}
+
+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)
+{
+ errorBelch("Warning: Listing RTS-threads is only possible for "
+ "multithreaded RTS.");
+}
+
+void rts_listMiscRoots (ListRootsCb cb STG_UNUSED, void *user STG_UNUSED)
+{
+ errorBelch("Warning: Listing MiscRoots is only possible for "
+ "multithreaded RTS.");
+}
+#endif
+
void rts_done (void)
{
freeMyTask();
=====================================
rts/Schedule.c
=====================================
@@ -1537,7 +1537,7 @@ static void acquireAllCapabilities(Capability *cap, Task *task)
void releaseAllCapabilities(uint32_t n, Capability *keep_cap, Task *task)
{
uint32_t i;
-
+ ASSERT( task != NULL);
for (i = 0; i < n; i++) {
Capability *tmpcap = capabilities[i];
if (keep_cap != tmpcap) {
=====================================
rts/Task.c
=====================================
@@ -36,8 +36,6 @@ uint32_t currentWorkerCount;
uint32_t peakWorkerCount;
static int tasksInitialized = 0;
-
-static void freeTask (Task *task);
static Task * newTask (bool);
#if defined(THREADED_RTS)
@@ -173,7 +171,7 @@ void freeMyTask (void)
setMyTask(NULL);
}
-static void
+void
freeTask (Task *task)
{
InCall *incall, *next;
=====================================
rts/Task.h
=====================================
@@ -188,6 +188,7 @@ isWorker (Task *task)
// Linked list of all tasks.
//
extern Task *all_tasks;
+void freeTask (Task *task);
// The all_tasks list is protected by the all_tasks_mutex
#if defined(THREADED_RTS)
@@ -200,29 +201,6 @@ extern Mutex all_tasks_mutex;
void initTaskManager (void);
uint32_t freeTaskManager (void);
-// Create a new Task for a bound thread. This Task must be released
-// by calling boundTaskExiting. The Task is cached in
-// thread-local storage and will remain even after boundTaskExiting()
-// has been called; to free the memory, see freeMyTask().
-//
-Task* newBoundTask (void);
-
-// Return the current OS thread's Task, which is created if it doesn't already
-// exist. After you have finished using RTS APIs, you should call freeMyTask()
-// to release this thread's Task.
-Task* getTask (void);
-
-// The current task is a bound task that is exiting.
-//
-void boundTaskExiting (Task *task);
-
-// Free a Task if one was previously allocated by newBoundTask().
-// This is not necessary unless the thread that called newBoundTask()
-// will be exiting, or if this thread has finished calling Haskell
-// functions.
-//
-void freeMyTask(void);
-
// Notify the task manager that a task has stopped. This is used
// mainly for stats-gathering purposes.
// Requires: sched_mutex.
=====================================
rts/rts.cabal.in
=====================================
@@ -150,6 +150,7 @@ library
rts/StableName.h
rts/StablePtr.h
rts/StaticPtrTable.h
+ rts/Task.h
rts/TTY.h
rts/Threads.h
rts/Ticky.h
=====================================
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/a44ab6ec4c5d9ad229bb7f1cd8849b4900f2889e...fe5414693d1875e83b1c3cf70f9a2236ce1c599e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a44ab6ec4c5d9ad229bb7f1cd8849b4900f2889e...fe5414693d1875e83b1c3cf70f9a2236ce1c599e
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/b51ef720/attachment-0001.html>
More information about the ghc-commits
mailing list