[Git][ghc/ghc][wip/ghc-debug] 6 commits: Support STACK closures in collect_pointers()
David Eichmann
gitlab at gitlab.haskell.org
Mon Oct 12 17:18:00 UTC 2020
David Eichmann pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
e15213d5 by David Eichmann at 2020-10-06T12:23:14+01:00
Support STACK closures in collect_pointers()
- - - - -
d2724ab5 by David Eichmann at 2020-10-06T12:23:30+01:00
Update documentation
- - - - -
5d654ff0 by David Eichmann at 2020-10-06T13:18:29+01:00
Update documentation
- - - - -
8e82553c by David Eichmann at 2020-10-06T13:47:06+01:00
Remove LiftedClosure. Use Any instead.
- - - - -
773548ae by David Eichmann at 2020-10-08T17:51:30+01:00
Remove first argument to peekTSOFields. Always use peekStgTSOProfInfo.
- - - - -
778961af by David Eichmann at 2020-10-12T18:15:45+01:00
Comobine prof_info tso_and_stack_closures test and test getClosureDataFromHeapRep
- - - - -
18 changed files:
- includes/RtsAPI.h
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs
- + libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc → libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
- libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc
- libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/tests/TestUtils.hs
- 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/prof_info.hs
- libraries/ghc-heap/tests/tso_and_stack_closures.hs
- rts/Heap.c
- rts/RtsAPI.c
Changes:
=====================================
includes/RtsAPI.h
=====================================
@@ -487,16 +487,17 @@ void rts_checkSchedStatus (char* site, Capability *);
SchedulerStatus rts_getSchedStatus (Capability *cap);
-// Halt execution of all Haskell threads by acquiring all capabilities (safe FFI
-// calls may continue). rts_resume must later be called on the same thread to
-// resume the RTS. Only one thread at a time can keep the rts paused. The
-// rts_pause function will block until the current thread is given exclusive
-// permission to pause the RTS. If the RTS is already paused by the current OS
-// thread, then rts_pause will return immediately and have no effect. Returns a
-// token which may be used to create new objects and evaluate them (like
-// rts_lock) .This is different to rts_lock which only pauses a single
-// capability. Calling rts_pause in between rts_lock/rts_unlock on the same
-// thread will cause an error.
+// Halt execution of all Haskell threads by acquiring all capabilities. Note
+// that this does not pause threads running safe FFI calls. rts_resume must
+// later be called on the same thread to resume the RTS. Only one thread at a
+// time can keep the rts paused. The rts_pause function will block until the
+// current thread is given exclusive permission to pause the RTS. If the RTS is
+// already paused by the current OS thread, then rts_pause will return
+// immediately and have no effect. Returns a token which may be used to create
+// new objects and evaluate them (like rts_lock). This is different to rts_lock
+// which only pauses a single capability. Calling rts_pause in between
+// rts_lock/rts_unlock on the same thread will cause an error. Calling rts_pause
+// from an unsafe FFI call will also cause an error (safe FFI calls are ok).
Capability * rts_pause (void);
// Counterpart of rts_pause: Continue from a pause. All capabilities are
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -24,7 +24,6 @@ values, i.e. to investigate sharing and lazy evaluation.
module GHC.Exts.Heap (
-- * Closure types
Closure
- , LiftedClosure
, GenClosure(..)
, ClosureType(..)
, PrimType(..)
@@ -65,17 +64,8 @@ import GHC.Exts.Heap.ClosureTypes
import GHC.Exts.Heap.Constants
import GHC.Exts.Heap.ProfInfo.Types
#if defined(PROFILING)
-import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
import GHC.Exts.Heap.InfoTableProf
#else
--- This import makes PeekProfInfo_ProfilingEnabled available in make-based
--- builds. See #15197 for details (even though the related patch didn't
--- seem to fix the issue).
--- GHC.Exts.Heap.Closures uses the same trick to include
--- GHC.Exts.Heap.InfoTableProf into make-based builds.
-import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled ()
-
-import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled
import GHC.Exts.Heap.InfoTable
#endif
import GHC.Exts.Heap.Utils
@@ -91,12 +81,6 @@ import Foreign
#include "ghcconfig.h"
--- | Some closures (e.g.TSOs) don't have corresponding types to represent them in Haskell.
--- So when we have a pointer to such closure that we want to inspect, we `unsafeCoerce` it
--- into the following `LiftedClosure` lifted type (could be any lifted type) so that the
--- appropriate `instance HasHeapRep (a :: TYPE 'LiftedRep)` is used to decode the closure.
-data LiftedClosure
-
class HasHeapRep (a :: TYPE rep) where
-- | Decode a closure to it's heap representation ('GenClosure').
@@ -191,9 +175,10 @@ getClosureDataFromHeapObject x = do
getClosureDataFromHeapRep
:: Maybe (Ptr a)
-- ^ Pointer to the closure in the heap. This is only used for STACK
- -- closures to properly calculate the `stack_spOffset`. If this argument is
- -- Nothing and the closure is a STACK, then `UnsupportedClosure` is
- -- returned.
+ -- closures to properly calculate the `stack_spOffset`. This pointer will
+ -- not be dereferenced; the object need not exist at the give address. If
+ -- this argument is Nothing and the closure is a STACK, then
+ -- `UnsupportedClosure` is returned.
-> ByteArray#
-- ^ Heap representation of the closure as returned by `unpackClosure#`.
-- This includes all of the object including the header, info table
@@ -205,16 +190,16 @@ getClosureDataFromHeapRep
-- info table from this process's runtime or in pinned or off-heap memory.
-> [b]
-- ^ Pointers in the payload of the closure, extracted from the heap
- -- representation. In the case of STACK objects, this does NOT contain
- -- pointers in the stack space (i.e. in StgStack::stack). Note `b` is some
- -- representation of a pointer. If for example `b ~ Any` then the referenced
- -- objects will be managed by the runtime system and kept alive by the
- -- garbage collector. That is not true if for example `b ~ Ptr Any`.
+ -- representation as defined by `collect_pointers()` in `Heap.c`. In the
+ -- case of STACK objects, this does NOT contain pointers in the stack space
+ -- (i.e. in StgStack::stack). Note `b` is some representation of a pointer.
+ -- If for example `b ~ Any` then the referenced objects will be managed by
+ -- the runtime system and kept alive by the garbage collector. That is not
+ -- true if for example `b ~ Ptr Any`.
-> IO (GenClosure b)
-- ^ Heap representation of the closure.
getClosureDataFromHeapRep closureAddressMay heapRep infoTablePtr pts = do
itbl <- peekItbl infoTablePtr
- -- The remaining words after the header
let -- heapRep as a list of words.
rawHeapWords :: [Word]
rawHeapWords = [W# (indexWordArray# heapRep i) | I# i <- [0.. end] ]
@@ -368,7 +353,7 @@ getClosureDataFromHeapRep closureAddressMay heapRep infoTablePtr pts = do
}
TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts
-> withArray rawHeapWords (\ptr -> do
- fields <- FFIClosures.peekTSOFields peekStgTSOProfInfo ptr
+ fields <- FFIClosures.peekTSOFields ptr
pure $ TSOClosure
{ info = itbl
, link = u_lnk
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -318,9 +318,10 @@ data GenClosure b
#if __GLASGOW_HASKELL__ >= 810
, stack_marking :: !Word8
#endif
- -- | Offset of the `StgStack::sp` pointer in bytes
- -- x->sp == ((byte*)x)+stack_spOffset
- -- The type of `stack_spOffset` reflects the type of `stack_size`.
+ -- | Offset of the `StgStack::sp` pointer in *bytes*:
+ --
+ -- stgStack->sp == ((byte*)stgStack)+stack_spOffset
+ --
, stack_spOffset :: !Int
}
@@ -393,7 +394,7 @@ data WhatNext
| ThreadInterpret
| ThreadKilled
| ThreadComplete
- | WhatNextUnknownValue -- ^ Please report this as a bug
+ | WhatNextUnknownValue Word16 -- ^ Please report this as a bug
deriving (Eq, Show, Generic)
data WhyBlocked
@@ -411,7 +412,7 @@ data WhyBlocked
| BlockedOnMsgThrowTo
| ThreadMigrating
| BlockedOnIOCompletion
- | WhyBlockedUnknownValue -- ^ Please report this as a bug
+ | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug
deriving (Eq, Show, Generic)
data TsoFlags
@@ -422,7 +423,7 @@ data TsoFlags
| TsoMarked
| TsoSqueezed
| TsoAllocLimit
- | TsoFlagsUnknownValue -- ^ Please report this as a bug
+ | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug
deriving (Eq, Show, Generic)
-- | For generic code, this function returns all referenced closures.
=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.Exts.Heap.FFIClosures (module Reexport) where
+
+#if defined(PROFILING)
+import GHC.Exts.Heap.FFIClosures_ProfilingEnabled as Reexport
+import GHC.Exts.Heap.FFIClosures_ProfilingDisabled ()
+#else
+import GHC.Exts.Heap.FFIClosures_ProfilingDisabled as Reexport
+import GHC.Exts.Heap.FFIClosures_ProfilingEnabled ()
+#endif
=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
=====================================
@@ -0,0 +1,133 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+
+module GHC.Exts.Heap.FFIClosures_ProfilingDisabled where
+
+-- Manually undefining PROFILING gives the #peek and #poke macros an accurate
+-- representation of the C structures when hsc2hs runs. This is valid because
+-- a non-profiling build would use
+-- GHC.Exts.Heap.FFIClosures_ProfilingEnabled.
+#undef PROFILING
+#include "Rts.h"
+
+import Prelude
+import Foreign
+import GHC.Exts
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
+import GHC.Exts.Heap.ProfInfo.Types
+import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
+
+data TSOFields = TSOFields {
+ tso_what_next :: WhatNext,
+ tso_why_blocked :: WhyBlocked,
+ tso_flags :: [TsoFlags],
+-- 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,
+ tso_prof :: Maybe StgTSOProfInfo
+}
+
+-- | Get non-pointer fields from @StgTSO_@ (@TSO.h@)
+peekTSOFields :: Ptr tsoPtr -> 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
+ tso_prof' <- peekStgTSOProfInfo ptr
+
+ return TSOFields {
+ tso_what_next = parseWhatNext what_next',
+ tso_why_blocked = parseWhyBlocked why_blocked',
+ tso_flags = parseTsoFlags flags',
+ tso_threadId = threadId',
+ tso_saved_errno = saved_errno',
+ tso_dirty = dirty',
+ tso_alloc_limit = alloc_limit',
+ tso_tot_stack_size = tot_stack_size',
+ tso_prof = tso_prof'
+ }
+
+parseWhatNext :: Word16 -> WhatNext
+parseWhatNext w = case w of
+ (#const ThreadRunGHC) -> ThreadRunGHC
+ (#const ThreadInterpret) -> ThreadInterpret
+ (#const ThreadKilled) -> ThreadKilled
+ (#const ThreadComplete) -> ThreadComplete
+ _ -> WhatNextUnknownValue w
+
+parseWhyBlocked :: Word16 -> WhyBlocked
+parseWhyBlocked w = case w of
+ (#const NotBlocked) -> NotBlocked
+ (#const BlockedOnMVar) -> BlockedOnMVar
+ (#const BlockedOnMVarRead) -> BlockedOnMVarRead
+ (#const BlockedOnBlackHole) -> BlockedOnBlackHole
+ (#const BlockedOnRead) -> BlockedOnRead
+ (#const BlockedOnWrite) -> BlockedOnWrite
+ (#const BlockedOnDelay) -> BlockedOnDelay
+ (#const BlockedOnSTM) -> BlockedOnSTM
+ (#const BlockedOnDoProc) -> BlockedOnDoProc
+ (#const BlockedOnCCall) -> BlockedOnCCall
+ (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible
+ (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo
+ (#const ThreadMigrating) -> ThreadMigrating
+#if __GLASGOW_HASKELL__ >= 810
+ (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion
+#endif
+ _ -> WhyBlockedUnknownValue w
+
+parseTsoFlags :: Word32 -> [TsoFlags]
+parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset (#const TSO_LOCKED) w)
+ | isSet (#const TSO_BLOCKEX) w = TsoBlockx : parseTsoFlags (unset (#const TSO_BLOCKEX) w)
+ | isSet (#const TSO_INTERRUPTIBLE) w = TsoInterruptible : parseTsoFlags (unset (#const TSO_INTERRUPTIBLE) w)
+ | isSet (#const TSO_STOPPED_ON_BREAKPOINT) w = TsoStoppedOnBreakpoint : parseTsoFlags (unset (#const TSO_STOPPED_ON_BREAKPOINT) w)
+ | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w)
+ | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)
+ | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)
+parseTsoFlags 0 = []
+parseTsoFlags w = [TsoFlagsUnknownValue w]
+
+isSet :: Word32 -> Word32 -> Bool
+isSet bitMask w = w .&. bitMask /= 0
+
+unset :: Word32 -> Word32 -> Word32
+unset bitMask w = w `xor` bitMask
+
+data StackFields = StackFields {
+ stack_size :: Word32,
+ stack_dirty :: Word8,
+#if __GLASGOW_HASKELL__ >= 810
+ stack_marking :: Word8,
+#endif
+ stack_sp :: Addr##
+}
+
+-- | 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__ >= 810
+ marking' <- (#peek struct StgStack_, marking) ptr
+#endif
+ Ptr sp' <- (#peek struct StgStack_, sp) ptr
+
+ -- TODO decode the stack.
+
+ return StackFields {
+ stack_size = stack_size',
+ stack_dirty = dirty',
+#if __GLASGOW_HASKELL__ >= 810
+ stack_marking = marking',
+#endif
+ stack_sp = sp'
+ }
+
=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc → libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
=====================================
@@ -1,13 +1,19 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
-module GHC.Exts.Heap.FFIClosures where
+module GHC.Exts.Heap.FFIClosures_ProfilingEnabled where
+-- Manually defining PROFILING gives the #peek and #poke macros an accurate
+-- representation of the C structures when hsc2hs runs. This is valid because
+-- a non-profiling build would use
+-- GHC.Exts.Heap.FFIClosures_ProfilingDisabled.
+#define PROFILING
#include "Rts.h"
import Prelude
import Foreign
import GHC.Exts
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
import GHC.Exts.Heap.ProfInfo.Types
import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
@@ -26,10 +32,8 @@ data TSOFields = TSOFields {
}
-- | Get non-pointer fields from @StgTSO_@ (@TSO.h@)
-peekTSOFields :: (Ptr tsoPtr -> IO (Maybe StgTSOProfInfo))
- -> Ptr tsoPtr
- -> IO TSOFields
-peekTSOFields peekProfInfo ptr = do
+peekTSOFields :: Ptr tsoPtr -> 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
@@ -38,7 +42,7 @@ peekTSOFields peekProfInfo ptr = do
dirty' <- (#peek struct StgTSO_, dirty) ptr
alloc_limit' <- (#peek struct StgTSO_, alloc_limit) ptr
tot_stack_size' <- (#peek struct StgTSO_, tot_stack_size) ptr
- tso_prof' <- peekProfInfo ptr
+ tso_prof' <- peekStgTSOProfInfo ptr
return TSOFields {
tso_what_next = parseWhatNext what_next',
@@ -58,7 +62,7 @@ parseWhatNext w = case w of
(#const ThreadInterpret) -> ThreadInterpret
(#const ThreadKilled) -> ThreadKilled
(#const ThreadComplete) -> ThreadComplete
- _ -> WhatNextUnknownValue
+ _ -> WhatNextUnknownValue w
parseWhyBlocked :: Word16 -> WhyBlocked
parseWhyBlocked w = case w of
@@ -78,7 +82,7 @@ parseWhyBlocked w = case w of
#if __GLASGOW_HASKELL__ >= 810
(#const BlockedOnIOCompletion) -> BlockedOnIOCompletion
#endif
- _ -> WhyBlockedUnknownValue
+ _ -> WhyBlockedUnknownValue w
parseTsoFlags :: Word32 -> [TsoFlags]
parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset (#const TSO_LOCKED) w)
@@ -89,7 +93,7 @@ parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset
| isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)
| isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)
parseTsoFlags 0 = []
-parseTsoFlags _ = [TsoFlagsUnknownValue]
+parseTsoFlags w = [TsoFlagsUnknownValue w]
isSet :: Word32 -> Word32 -> Bool
isSet bitMask w = w .&. bitMask /= 0
=====================================
libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP, DeriveGeneric #-}
module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled(
peekStgTSOProfInfo
) where
=====================================
libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MagicHash #-}
@@ -49,7 +48,11 @@ peekStgTSOProfInfo tsoPtr = do
cccsOffset :: Int
cccsOffset = (#const OFFSET_StgTSO_cccs) + (#size StgHeader)
-peekCostCentreStack :: AddressSet -> IORef (AddressMap CostCentre) -> Ptr costCentreStack -> IO (Maybe CostCentreStack)
+peekCostCentreStack
+ :: AddressSet
+ -> IORef (AddressMap CostCentre)
+ -> Ptr costCentreStack
+ -> IO (Maybe CostCentreStack)
peekCostCentreStack _ _ ptr | ptr == nullPtr = return Nothing
peekCostCentreStack loopBreakers _ ptr | IntSet.member (ptrToInt ptr) loopBreakers = return Nothing
peekCostCentreStack loopBreakers costCenterCacheRef ptr = do
=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -41,6 +41,8 @@ library
GHC.Exts.Heap.InfoTableProf
GHC.Exts.Heap.Utils
GHC.Exts.Heap.FFIClosures
+ GHC.Exts.Heap.FFIClosures_ProfilingEnabled
+ GHC.Exts.Heap.FFIClosures_ProfilingDisabled
GHC.Exts.Heap.ProfInfo.Types
GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -1,9 +1,8 @@
{-# LANGUAGE MagicHash #-}
module TestUtils where
-import GHC.Exts.Heap (getClosureData, LiftedClosure, Box, GenClosure)
import Foreign (Ptr)
-import GHC.Exts (Ptr, Addr#, unsafeCoerce#)
+import GHC.Exts (Addr#)
import GHC.Ptr (Ptr(Ptr))
assertEqual :: (Show a, Eq a) => a -> a -> IO ()
@@ -11,10 +10,5 @@ assertEqual a b
| a /= b = error (show a ++ " /= " ++ show b)
| otherwise = return ()
-createClosure :: Ptr () -> IO (GenClosure Box)
-createClosure tsoPtr = do
- let addr = unpackAddr# tsoPtr
- getClosureData ((unsafeCoerce# addr) :: LiftedClosure)
-
unpackAddr# :: Ptr () -> Addr#
unpackAddr# (Ptr addr) = addr
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -37,12 +37,23 @@ test('closure_size_noopt',
compile_and_run, [''])
test('tso_and_stack_closures',
- [extra_files(['create_tso.c','create_tso.h', 'TestUtils.hs']),
+ [extra_files(['create_tso.c','create_tso.h','TestUtils.hs']),
+ only_ways(['profthreaded']),
+ extra_ways(['profthreaded']),
ignore_stdout,
ignore_stderr
],
multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], ''])
+# test('tso_and_stack_closures (prof)',
+# [extra_files(['create_tso.c','create_tso.h','TestUtils.hs']),
+# only_ways(prof_ways),
+# extra_ways(prof_ways),
+# ignore_stdout,
+# ignore_stderr,
+# ],
+# multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], '-prof'])
+
test('list_threads_and_misc_roots',
[extra_files(['list_threads_and_misc_roots_c.c','list_threads_and_misc_roots_c.h','TestUtils.hs']),
ignore_stdout,
@@ -50,15 +61,6 @@ test('list_threads_and_misc_roots',
],
multi_compile_and_run, ['list_threads_and_misc_roots', [('list_threads_and_misc_roots_c.c','')], '-threaded'])
-test('prof_info',
- [extra_files(['create_tso.c','create_tso.h','TestUtils.hs']),
- ignore_stdout,
- ignore_stderr,
- when(have_profiling(), extra_ways(['prof'])),
- only_ways(prof_ways)
- ],
- multi_compile_and_run, ['prof_info', [('create_tso.c','')], '-prof'])
-
test('parse_tso_flags',
[extra_files(['TestUtils.hs']),
only_ways(['normal']),
=====================================
libraries/ghc-heap/tests/create_tso.c
=====================================
@@ -1,10 +1,80 @@
#include "Rts.h"
#include "RtsAPI.h"
-StgTSO* create_tso(){
- HaskellObj trueClosure = rts_mkBool(&MainCapability, 1);
+// Must be called from a safe FFI call.
+void create_and_unpack_tso_and_stack
+ // TSO
+ ( StgTSO ** outTso
+ , StgInfoTable ** outTsoInfoTablePtr
+ , int * outTsoHeapRepSize // Size of outHeapRep (in bytes)
+ , StgWord ** outTsoHeapRep // Array of words
+ , int * outTsoPointersSize // Size of outPointers (in words)
+ , StgClosure *** outTsoPointers // Array of all pointers of the TSO
+ // Stack
+ , StgTSO ** outStack
+ , StgInfoTable ** outStackInfoTablePtr
+ , int * outStackHeapRepSize // Size of outHeapRep (in bytes)
+ , StgWord ** outStackHeapRep // Array of words
+ , int * outStackPointersSize // Size of outPointers (in words)
+ , StgClosure *** outStackPointers // Array of all pointers of the TSO
+ )
+{
+ // Pause RTS
+ Capability * cap = rts_pause();
- StgTSO * tso = createGenThread(&MainCapability, 500U, trueClosure);
+ // Create TSO/Stack
+ HaskellObj trueClosure = rts_mkBool(cap, 1);
+ *outTso = createGenThread(cap, 500U, trueClosure);
- return tso;
+ // Unpack TSO
+ unpack_closure(
+ (StgClosure*)(*outTso),
+ outTsoInfoTablePtr,
+ outTsoHeapRepSize,
+ outTsoHeapRep,
+ outTsoPointersSize,
+ outTsoPointers);
+
+ // Unpack STACK
+ *outStack = (*outTsoPointers)[2];
+ unpack_closure(
+ (StgClosure*)(*outStack),
+ outStackInfoTablePtr,
+ outStackHeapRepSize,
+ outStackHeapRep,
+ outStackPointersSize,
+ outStackPointers);
+
+ // Resume RTS
+ rts_resume(cap);
+}
+
+// Assumed the rts is paused
+void unpack_closure
+ ( StgClosure * inClosure
+ , StgInfoTable ** outInfoTablePtr
+ , int * outHeapRepSize // Size of outHeapRep (in bytes)
+ , StgWord ** outHeapRep // Array of words
+ , int * outPointersSize // Size of outPointers (in words)
+ , StgClosure *** outPointers // Array of all pointers of the TSO
+ )
+{
+ *outInfoTablePtr = get_itbl(inClosure);
+
+ // Copy TSO pointers.
+ StgWord closureSizeW = heap_view_closureSize(inClosure);
+ int closureSizeB = sizeof(StgWord) * closureSizeW;
+ StgClosure ** pointers = malloc(closureSizeB);
+ *outPointersSize = collect_pointers(inClosure, closureSizeW, pointers);
+ *outPointers = pointers;
+
+ // Copy the heap rep.
+ StgWord * heapRep = malloc(closureSizeB);
+ for (int i = 0; i < closureSizeW; i++)
+ {
+ heapRep[i] = ((StgWord*)inClosure)[i];
+ }
+
+ *outHeapRepSize = closureSizeB;
+ *outHeapRep = heapRep;
}
=====================================
libraries/ghc-heap/tests/create_tso.h
=====================================
@@ -1,3 +1,19 @@
+#include "Rts.h"
#include "RtsAPI.h"
-StgTSO* create_tso();
+void create_and_unpack_tso_and_stack
+ // TSO
+ ( StgTSO ** outTso
+ , StgInfoTable ** outTsoInfoTablePtr
+ , int * outTsoHeapRepSize // Size of outHeapRep (in bytes)
+ , StgWord ** outTsoHeapRep // Array of words
+ , int * outTsoPointersSize // Size of outPointers (in words)
+ , StgClosure *** outTsoPointers // Array of all pointers of the TSO
+ // Stack
+ , StgTSO ** outStack
+ , StgInfoTable ** outStackInfoTablePtr
+ , int * outStackHeapRepSize // Size of outHeapRep (in bytes)
+ , StgWord ** outStackHeapRep // Array of words
+ , int * outStackPointersSize // Size of outPointers (in words)
+ , StgClosure *** outStackPointers // Array of all pointers of the TSO
+ );
\ No newline at end of file
=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
=====================================
@@ -31,14 +31,14 @@ main = do
tsoCount <- getTSOCount_c
tsos <- getTSOs_c
tsoList <- peekArray tsoCount tsos
- tsoClosures <- mapM createClosure tsoList
+ tsoClosures <- mapM createAndUnpackTSOClosure 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
+ heapClosures <- mapM _ 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.
=====================================
libraries/ghc-heap/tests/prof_info.hs deleted
=====================================
@@ -1,53 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface, MagicHash, CPP, BangPatterns #-}
-
-import Prelude
-import Foreign
-import Foreign.C.Types
-import GHC.Exts.Heap
-import GHC.Exts
-import Data.Functor
-
-import GHC.Word
-import Data.List (find)
-
-import TestUtils
-
-#include "ghcconfig.h"
-#include "rts/Constants.h"
-
-foreign import ccall unsafe "create_tso.h create_tso"
- c_create_tso:: IO (Ptr ())
-
-createTSOClosure :: IO (GenClosure Box)
-createTSOClosure = do
- ptr <- {-# SCC "MyCostCentre" #-} c_create_tso
- let addr = unpackAddr# ptr
- getClosureData ((unsafeCoerce# addr) :: LiftedClosure)
-
--- 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
-
- let costCentre = prof tso >>= cccs <&> ccs_cc
-
- case costCentre of
- Nothing -> error $ "No CostCentre found in TSO: " ++ show tso
- Just _ -> case findMyCostCentre (linkedCostCentres costCentre) of
- Just myCostCentre -> do
- assertEqual (cc_label myCostCentre) "MyCostCentre"
- assertEqual (cc_module myCostCentre) "Main"
- assertEqual (cc_srcloc myCostCentre) (Just "prof_info.hs:23:39-50")
- assertEqual (cc_mem_alloc myCostCentre) 0
- assertEqual (cc_time_ticks myCostCentre) 0
- assertEqual (cc_is_caf myCostCentre) False
- Nothing -> error "MyCostCentre not found!"
-
-linkedCostCentres :: Maybe CostCentre -> [CostCentre]
-linkedCostCentres Nothing = []
-linkedCostCentres (Just cc) = cc : linkedCostCentres (cc_link cc)
-
-findMyCostCentre:: [CostCentre] -> Maybe CostCentre
-findMyCostCentre ccs = find (\cc -> cc_label cc == "MyCostCentre") ccs
=====================================
libraries/ghc-heap/tests/tso_and_stack_closures.hs
=====================================
@@ -1,61 +1,159 @@
-{-# LANGUAGE ForeignFunctionInterface, MagicHash, BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+import Control.Monad (forM_, unless)
+import Data.List (find)
+import Data.Word
import Foreign
import Foreign.C.Types
-import GHC.Exts.Heap
+import GHC.IO ( IO(..) )
import GHC.Exts
-
+import GHC.Exts.Heap
+import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
import GHC.Word
import TestUtils
-foreign import ccall unsafe "create_tso.h create_tso"
- c_create_tso:: IO (Ptr ())
-
--- 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
+ (tso, stack) <- {-# SCC "MyCostCentre" #-} createAndUnpackTSOAndSTACKClosure
+ assertEqual (getClosureType tso) TSO
+ assertEqual (getClosureType stack) STACK
assertEqual (what_next tso) ThreadRunGHC
assertEqual (why_blocked tso) NotBlocked
assertEqual (saved_errno tso) 0
- -- The newly created TSO should be on the end of the run queue.
- let !_linkBox = unsafe_link tso
- _linkClosure <- getBoxedClosureData _linkBox
- assertEqual (name _linkClosure) "END_TSO_QUEUE"
- assertEqual (getClosureType _linkClosure) CONSTR_NOCAF
+#if defined(PROFILING)
+ let costCentre = ccs_cc <$> (cccs =<< prof tso)
+ case costCentre of
+ Nothing -> error $ "No CostCentre found in TSO: " ++ show tso
+ Just _ -> case findMyCostCentre (linkedCostCentres costCentre) of
+ Just myCostCentre -> do
+ assertEqual (cc_label myCostCentre) "MyCostCentre"
+ assertEqual (cc_module myCostCentre) "Main"
+ assertEqual (cc_srcloc myCostCentre) (Just "tso_and_stack_closures.hs:23:48-80")
+ assertEqual (cc_is_caf myCostCentre) False
+ Nothing -> error $ "MyCostCentre not found in:\n" ++ unlines (cc_label <$> linkedCostCentres costCentre)
+#endif
- let !global_linkBox = unsafe_global_link tso
- globalLinkClosure <- getBoxedClosureData global_linkBox
- assertEqual (getClosureType globalLinkClosure) TSO
+linkedCostCentres :: Maybe CostCentre -> [CostCentre]
+linkedCostCentres Nothing = []
+linkedCostCentres (Just cc) = cc : linkedCostCentres (cc_link cc)
- let !stackBox = tsoStack tso
- stackClosure <- getBoxedClosureData stackBox
- assertEqual (getClosureType stackClosure) STACK
+findMyCostCentre:: [CostCentre] -> Maybe CostCentre
+findMyCostCentre ccs = find (\cc -> cc_label cc == "MyCostCentre") ccs
- let !stackPointerBox = unsafeStackPointer stackClosure
- stackPointerClosure <- getBoxedClosureData stackPointerBox
- assertEqual (getClosureType stackPointerClosure) RET_SMALL
+getClosureType :: GenClosure b -> ClosureType
+getClosureType = tipe . info
- let !trecBox = unsafe_trec tso
- trecClosure <- getBoxedClosureData trecBox
- assertEqual (name trecClosure) "NO_TREC"
+type StgTso = Any
+type StgStack = Any
+data MBA a = MBA (MutableByteArray# a)
+data BA = BA ByteArray#
- let !blockedExceptionsBox = unsafe_blocked_exceptions tso
- blockedExceptionsClosure <- getBoxedClosureData blockedExceptionsBox
- assertEqual (name blockedExceptionsClosure) "END_TSO_QUEUE"
+foreign import ccall safe "create_tso.h create_and_unpack_tso_and_stack"
+ c_create_and_unpack_tso_and_stack
+ :: Ptr (Ptr StgTso)
+ -> Ptr (Ptr StgInfoTable)
+ -> Ptr CInt
+ -> Ptr (Ptr Word8)
+ -> Ptr CInt
+ -> Ptr (Ptr (Ptr Any))
+ -> Ptr (Ptr StgStack)
+ -> Ptr (Ptr StgInfoTable)
+ -> Ptr CInt
+ -> Ptr (Ptr Word8)
+ -> Ptr CInt
+ -> Ptr (Ptr (Ptr Any))
+ -> IO ()
- let !bqBox = unsafe_bq tso
- bqClosure <- getBoxedClosureData bqBox
- assertEqual (name bqClosure) "END_TSO_QUEUE"
+createAndUnpackTSOAndSTACKClosure :: IO (GenClosure (Ptr Any), GenClosure (Ptr Any))
+createAndUnpackTSOAndSTACKClosure = do
-createTSOClosure :: IO (GenClosure Box)
-createTSOClosure = do
- ptr <- c_create_tso
- createClosure ptr
+ alloca $ \ptrPtrTso -> do
+ alloca $ \ptrPtrTsoInfoTable -> do
+ alloca $ \ptrTsoHeapRepSize -> do
+ alloca $ \ptrPtrTsoHeapRep -> do
+ alloca $ \ptrTsoPointersSize -> do
+ alloca $ \ptrPtrPtrTsoPointers -> do
-getClosureType :: GenClosure b -> ClosureType
-getClosureType = tipe . info
+ alloca $ \ptrPtrStack -> do
+ alloca $ \ptrPtrStackInfoTable -> do
+ alloca $ \ptrStackHeapRepSize -> do
+ alloca $ \ptrPtrStackHeapRep -> do
+ alloca $ \ptrStackPointersSize -> do
+ alloca $ \ptrPtrPtrStackPointers -> do
+
+ c_create_and_unpack_tso_and_stack
+
+ ptrPtrTso
+ ptrPtrTsoInfoTable
+ ptrTsoHeapRepSize
+ ptrPtrTsoHeapRep
+ ptrTsoPointersSize
+ ptrPtrPtrTsoPointers
+
+ ptrPtrStack
+ ptrPtrStackInfoTable
+ ptrStackHeapRepSize
+ ptrPtrStackHeapRep
+ ptrStackPointersSize
+ ptrPtrPtrStackPointers
+
+ let fromHeapRep
+ ptrPtrClosure
+ ptrPtrClosureInfoTable
+ ptrClosureHeapRepSize
+ ptrPtrClosureHeapRep
+ ptrClosurePointersSize
+ ptrPtrPtrClosurePointers = do
+ ptrClosure :: Ptr Any <- peek ptrPtrClosure
+ ptrInfoTable :: Ptr StgInfoTable <- peek ptrPtrClosureInfoTable
+
+ heapRepSize :: Int <- fromIntegral <$> peek ptrClosureHeapRepSize
+ let I# heapRepSize# = heapRepSize
+ ptrHeapRep :: Ptr Word8 <- peek ptrPtrClosureHeapRep
+ MBA mutHeapRepBA <- IO $ \s -> let
+ (# s', mba# #) = newByteArray# heapRepSize# s
+ in (# s', MBA mba# #)
+ forM_ [0..heapRepSize-1] $ \i@(I# i#) -> do
+ W8# w <- peekElemOff ptrHeapRep i
+ IO (\s -> (# writeWord8Array# mutHeapRepBA i# w s, () #))
+ BA heapRep <- IO $ \s -> let
+ (# s', ba# #) = unsafeFreezeByteArray# mutHeapRepBA s
+ in (# s', BA ba# #)
+
+ pointersSize :: Int <- fromIntegral <$> peek ptrClosurePointersSize
+ ptrPtrPointers :: Ptr (Ptr Any) <- peek ptrPtrPtrClosurePointers
+ ptrPtrPointers :: [Ptr Any] <- sequence
+ [ peekElemOff ptrPtrPointers i
+ | i <- [0..pointersSize-1]
+ ]
+
+ getClosureDataFromHeapRep
+ (Just ptrClosure)
+ heapRep
+ ptrInfoTable
+ ptrPtrPointers
+
+ tso <- fromHeapRep
+ ptrPtrTso
+ ptrPtrTsoInfoTable
+ ptrTsoHeapRepSize
+ ptrPtrTsoHeapRep
+ ptrTsoPointersSize
+ ptrPtrPtrTsoPointers
+
+ stack <- fromHeapRep
+ ptrPtrStack
+ ptrPtrStackInfoTable
+ ptrStackHeapRepSize
+ ptrPtrStackHeapRep
+ ptrStackPointersSize
+ ptrPtrPtrStackPointers
+
+ return (tso, stack)
=====================================
rts/Heap.c
=====================================
@@ -93,6 +93,7 @@ StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *ptrs[siz
// No pointers
case ARR_WORDS:
+ case STACK:
break;
// Default layout
=====================================
rts/RtsAPI.c
=====================================
@@ -670,7 +670,7 @@ rts_unlock (Capability *cap)
* This is achieved almost entirely by the mechanism of acquiring and releasing
* Capabilities, resulting in a sort of mutex / critical section pattern.
* Correct usage of this API requires that you surround API calls in
- * rts_lock/rts_unlock or rts_pause/rts_resume. These ensure that the thread
+ * rts_lock/rts_unlock or rts_pause/rts_resume. This ensures that the thread
* owns a capability while calling other RtsAPI functions (in the case of
* rts_pause/rts_resume the thread owns *all* capabilities).
*
@@ -678,7 +678,7 @@ rts_unlock (Capability *cap)
* without objects unexpectedly moving, which is important for many of the
* functions in RtsAPI.
*
- * Another important consequence is:
+ * Other important consequences are:
*
* * There are at most `n_capabilities` threads currently in a
* rts_lock/rts_unlock section.
@@ -686,11 +686,6 @@ rts_unlock (Capability *cap)
* there will be no threads in a rts_lock/rts_unlock section.
* * rts_pause and rts_lock may block in order to enforce the above 2
* invariants.
- *
- * In particular, by ensuring that that code does not block indefinitely in a
- * rts_lock/rts_unlock or rts_pause/rts_resume section, we can be confident that
- * the RtsAPI functions will not cause a deadlock even when many threads are
- * attempting to use the RtsAPI concurrently.
*/
// See RtsAPI.h
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9e8e08bdc063d86fcd5c4f5ac11bd35407c103fd...778961af6f5ac608cc1269ea21720cf9b08a9289
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9e8e08bdc063d86fcd5c4f5ac11bd35407c103fd...778961af6f5ac608cc1269ea21720cf9b08a9289
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/20201012/02e98118/attachment-0001.html>
More information about the ghc-commits
mailing list