diff options
Diffstat (limited to 'libraries')
18 files changed, 1020 insertions, 15 deletions
diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs index 7ecdaac9bc..2dfe788406 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap.hs @@ -27,6 +27,9 @@ module GHC.Exts.Heap ( , GenClosure(..) , ClosureType(..) , PrimType(..) + , WhatNext(..) + , WhyBlocked(..) + , TsoFlags(..) , HasHeapRep(getClosureData) , getClosureDataFromHeapRep , getClosureDataFromHeapRepPrim @@ -40,6 +43,12 @@ module GHC.Exts.Heap ( , peekItbl , pokeItbl + -- * Cost Centre (profiling) types + , StgTSOProfInfo(..) + , IndexTable(..) + , CostCentre(..) + , CostCentreStack(..) + -- * Closure inspection , getBoxedClosureData , allClosures @@ -54,12 +63,14 @@ import Prelude import GHC.Exts.Heap.Closures import GHC.Exts.Heap.ClosureTypes import GHC.Exts.Heap.Constants +import GHC.Exts.Heap.ProfInfo.Types #if defined(PROFILING) import GHC.Exts.Heap.InfoTableProf #else 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 @@ -330,6 +341,45 @@ getClosureDataFromHeapRepPrim getConDesc itbl heapRep pts = do , finalizer = pts !! 3 , link = pts !! 4 } + TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts + -> withArray rawHeapWords (\ptr -> do + fields <- FFIClosures.peekTSOFields ptr + pure $ TSOClosure + { info = itbl + , link = u_lnk + , global_link = u_gbl_lnk + , tsoStack = tso_stack + , trec = u_trec + , blocked_exceptions = u_blk_ex + , bq = u_bq + , 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 + , prof = FFIClosures.tso_prof fields + }) + | otherwise + -> fail $ "Expected 6 ptr arguments to TSO, found " + ++ show (length pts) + STACK + | [] <- pts + -> withArray rawHeapWords (\ptr -> do + fields <- FFIClosures.peekStackFields ptr + pure $ StackClosure + { info = itbl + , stack_size = FFIClosures.stack_size fields + , stack_dirty = FFIClosures.stack_dirty fields +#if __GLASGOW_HASKELL__ >= 811 + , stack_marking = FFIClosures.stack_marking fields +#endif + }) + | otherwise + -> fail $ "Expected 0 ptr argument to STACK, found " + ++ show (length pts) _ -> pure $ UnsupportedClosure itbl diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs index 8a959fc2a0..3c5d5f1c32 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -12,6 +12,9 @@ module GHC.Exts.Heap.Closures ( Closure , GenClosure(..) , PrimType(..) + , WhatNext(..) + , WhyBlocked(..) + , TsoFlags(..) , allClosures #if __GLASGOW_HASKELL__ >= 809 -- The closureSize# primop is unsupported on earlier GHC releases but we @@ -40,6 +43,8 @@ import GHC.Exts.Heap.InfoTable import GHC.Exts.Heap.InfoTableProf () #endif +import GHC.Exts.Heap.ProfInfo.Types + import Data.Bits import Data.Int import Data.Word @@ -100,11 +105,11 @@ type Closure = GenClosure Box -- | This is the representation of a Haskell value on the heap. It reflects -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/Closures.h> -- --- The data type is parametrized by the type to store references in. Usually --- this is a 'Box' with the type synonym 'Closure'. +-- The data type is parametrized by `b`: the type to store references in. +-- Usually this is a 'Box' with the type synonym 'Closure'. -- --- All Heap objects have the same basic layout. A header containing a pointer --- to the info table and a payload with various fields. The @info@ field below +-- All Heap objects have the same basic layout. A header containing a pointer to +-- the info table and a payload with various fields. The @info@ field below -- always refers to the info table pointed to by the header. The remaining -- fields are the payload. -- @@ -268,6 +273,39 @@ 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@. + | TSOClosure + { info :: !StgInfoTable + -- pointers + , link :: !b + , global_link :: !b + , tsoStack :: !b -- ^ stackobj from StgTSO + , trec :: !b + , blocked_exceptions :: !b + , bq :: !b + -- values + , what_next :: !WhatNext + , why_blocked :: !WhyBlocked + , flags :: ![TsoFlags] + , threadId :: !Word64 + , saved_errno :: !Word32 + , tso_dirty :: !Word32 -- ^ non-zero => dirty + , alloc_limit :: !Int64 + , tot_stack_size :: !Word32 + , prof :: !(Maybe StgTSOProfInfo) + } + + -- | 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 + } + ------------------------------------------------------------ -- Unboxed unlifted closures @@ -332,6 +370,43 @@ data PrimType | PDouble deriving (Eq, Show, Generic) +data WhatNext + = ThreadRunGHC + | ThreadInterpret + | ThreadKilled + | ThreadComplete + | WhatNextUnknownValue Word16 -- ^ Please report this as a bug + deriving (Eq, Show, Generic) + +data WhyBlocked + = NotBlocked + | BlockedOnMVar + | BlockedOnMVarRead + | BlockedOnBlackHole + | BlockedOnRead + | BlockedOnWrite + | BlockedOnDelay + | BlockedOnSTM + | BlockedOnDoProc + | BlockedOnCCall + | BlockedOnCCall_Interruptible + | BlockedOnMsgThrowTo + | ThreadMigrating + | BlockedOnIOCompletion + | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug + deriving (Eq, Show, Generic) + +data TsoFlags + = TsoLocked + | TsoBlockx + | TsoInterruptible + | TsoStoppedOnBreakpoint + | TsoMarked + | TsoSqueezed + | TsoAllocLimit + | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug + deriving (Eq, Show, Generic) + -- | For generic code, this function returns all referenced closures. allClosures :: GenClosure b -> [b] allClosures (ConstrClosure {..}) = ptrArgs diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs new file mode 100644 index 0000000000..14004b0b1f --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} + +module GHC.Exts.Heap.FFIClosures (module Reexport) where + +-- NOTE [hsc and CPP workaround] +-- +-- # Problem +-- +-- Often, .hsc files are used to get the correct offsets of C struct fields. +-- Those structs may be affected by CPP directives e.g. profiled vs not profiled +-- closure headers is affected by the PROFILED cpp define. Since we are building +-- multiple variants of the RTS, we must support all possible offsets e.g. by +-- running hsc2hs with cpp defines corresponding to each RTS flavour. The +-- problem is that GHC's build system runs hsc2hs *only once* per .hsc file +-- without properly setting cpp defines. This results in the same (probably +-- incorrect) offsets into our C structs. +-- +-- +-- # Workaround +-- +-- To work around this issue, we create multiple .hsc files each manually +-- defining thir cpp defines (see e.g. FFIClosures_ProfilingDisabled.hsc and +-- FFIClosures_ProfilingEnabled.hsc). Then we rely on cpp defines working +-- correctly in .hs files and use CPP to switch on which .hsc module to +-- re-export (see below). In each case we import the desired .hsc module as +-- `Reexport` and we import `()` (i.e. nothing) from all other .hsc variants +-- just so that the build system sees all .hsc file as dependencies. +-- +-- +-- # Future Work +-- +-- * Duplication of the code in the .hsc files could be reduced simply by +-- placing the code in a single .hsc.in file and `#include`ing it from each +-- .hsc file. The .hsc files would only be responsible for setting the correct +-- cpp defines. This currently doesn't work as hadrian doesn't know to copy +-- the .hsc.in file to the build directory. +-- * The correct solution would be for the build system to run `hsc2hs` with the +-- correct cpp defines once per RTS flavour. +-- + +#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 diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc new file mode 100644 index 0000000000..eabb098a15 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module GHC.Exts.Heap.FFIClosures_ProfilingDisabled where + +-- See [hsc and CPP workaround] + +#undef PROFILING +#include "Rts.h" + +import Prelude +import Foreign +import GHC.Exts +import GHC.Exts.Heap.ProfInfo.PeekProfInfo +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__ >= 811 + (#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__ >= 811 + 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__ >= 811 + 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__ >= 811 + stack_marking = marking', +#endif + stack_sp = sp' + } + diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc new file mode 100644 index 0000000000..124940d1cd --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module GHC.Exts.Heap.FFIClosures_ProfilingEnabled where + +-- See [hsc and CPP workaround] + +#define PROFILING +#include "Rts.h" + +import Prelude +import Foreign +import GHC.Exts +import GHC.Exts.Heap.ProfInfo.PeekProfInfo +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__ >= 811 + (#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__ >= 811 + 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__ >= 811 + 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__ >= 811 + stack_marking = marking', +#endif + stack_sp = sp' + } diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs new file mode 100644 index 0000000000..48dce2b8cb --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} + +module GHC.Exts.Heap.ProfInfo.PeekProfInfo (module Reexport) where + +-- See [hsc and CPP workaround] + +#if defined(PROFILING) +import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled as Reexport +import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled () +#else +import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled as Reexport +import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled () +#endif diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc new file mode 100644 index 0000000000..0f574b4f03 --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc @@ -0,0 +1,12 @@ +module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled( + peekStgTSOProfInfo +) where + +import Prelude +import Foreign +import GHC.Exts.Heap.ProfInfo.Types + +-- | This implementation is used when PROFILING is undefined. +-- It always returns 'Nothing', because there is no profiling info available. +peekStgTSOProfInfo :: Ptr tsoPtr -> IO (Maybe StgTSOProfInfo) +peekStgTSOProfInfo _ = return Nothing diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc new file mode 100644 index 0000000000..363d73d79a --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc @@ -0,0 +1,165 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MagicHash #-} + +module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled( + peekStgTSOProfInfo +) where + +#if __GLASGOW_HASKELL__ >= 811 + +-- See [hsc and CPP workaround] + +#define PROFILING + +#include "Rts.h" +#undef BLOCK_SIZE +#undef MBLOCK_SIZE +#undef BLOCKS_PER_MBLOCK +#include "DerivedConstants.h" + +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Foreign +import Foreign.C.String +import GHC.Exts +import GHC.Exts.Heap.ProfInfo.Types +import Prelude + +-- Use Int based containers for pointers (addresses) for better performance. +-- These will be queried a lot! +type AddressSet = IntSet +type AddressMap = IntMap + +peekStgTSOProfInfo :: Ptr a -> IO (Maybe StgTSOProfInfo) +peekStgTSOProfInfo tsoPtr = do + cccs_ptr <- peekByteOff tsoPtr cccsOffset + costCenterCacheRef <- newIORef IntMap.empty + cccs' <- peekCostCentreStack IntSet.empty costCenterCacheRef cccs_ptr + + return $ Just StgTSOProfInfo { + cccs = cccs' + } + +cccsOffset :: Int +cccsOffset = (#const OFFSET_StgTSO_cccs) + (#size StgHeader) + +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 + ccs_ccsID' <- (#peek struct CostCentreStack_, ccsID) ptr + ccs_cc_ptr <- (#peek struct CostCentreStack_, cc) ptr + ccs_cc' <- peekCostCentre costCenterCacheRef ccs_cc_ptr + ccs_prevStack_ptr <- (#peek struct CostCentreStack_, prevStack) ptr + let loopBreakers' = (IntSet.insert ptrAsInt loopBreakers) + ccs_prevStack' <- peekCostCentreStack loopBreakers' costCenterCacheRef ccs_prevStack_ptr + ccs_indexTable_ptr <- (#peek struct CostCentreStack_, indexTable) ptr + ccs_indexTable' <- peekIndexTable loopBreakers' costCenterCacheRef ccs_indexTable_ptr + ccs_root_ptr <- (#peek struct CostCentreStack_, root) ptr + ccs_root' <- peekCostCentreStack loopBreakers' costCenterCacheRef ccs_root_ptr + ccs_depth' <- (#peek struct CostCentreStack_, depth) ptr + ccs_scc_count' <- (#peek struct CostCentreStack_, scc_count) ptr + ccs_selected' <- (#peek struct CostCentreStack_, selected) ptr + ccs_time_ticks' <- (#peek struct CostCentreStack_, time_ticks) ptr + ccs_mem_alloc' <- (#peek struct CostCentreStack_, mem_alloc) ptr + ccs_inherited_alloc' <- (#peek struct CostCentreStack_, inherited_alloc) ptr + ccs_inherited_ticks' <- (#peek struct CostCentreStack_, inherited_ticks) ptr + + return $ Just CostCentreStack { + ccs_ccsID = ccs_ccsID', + ccs_cc = ccs_cc', + ccs_prevStack = ccs_prevStack', + ccs_indexTable = ccs_indexTable', + ccs_root = ccs_root', + ccs_depth = ccs_depth', + ccs_scc_count = ccs_scc_count', + ccs_selected = ccs_selected', + ccs_time_ticks = ccs_time_ticks', + ccs_mem_alloc = ccs_mem_alloc', + ccs_inherited_alloc = ccs_inherited_alloc', + ccs_inherited_ticks = ccs_inherited_ticks' + } + where + ptrAsInt = ptrToInt ptr + +peekCostCentre :: IORef (AddressMap CostCentre) -> Ptr costCentre -> IO CostCentre +peekCostCentre costCenterCacheRef ptr = do + costCenterCache <- readIORef costCenterCacheRef + case IntMap.lookup ptrAsInt costCenterCache of + (Just a) -> return a + Nothing -> do + cc_ccID' <- (#peek struct CostCentre_, ccID) ptr + cc_label_ptr <- (#peek struct CostCentre_, label) ptr + cc_label' <- peekCString cc_label_ptr + cc_module_ptr <- (#peek struct CostCentre_, module) ptr + cc_module' <- peekCString cc_module_ptr + cc_srcloc_ptr <- (#peek struct CostCentre_, srcloc) ptr + cc_srcloc' <- do + if cc_srcloc_ptr == nullPtr then + return Nothing + else + fmap Just (peekCString cc_srcloc_ptr) + cc_mem_alloc' <- (#peek struct CostCentre_, mem_alloc) ptr + cc_time_ticks' <- (#peek struct CostCentre_, time_ticks) ptr + cc_is_caf' <- (#peek struct CostCentre_, is_caf) ptr + cc_link_ptr <- (#peek struct CostCentre_, link) ptr + cc_link' <- if cc_link_ptr == nullPtr then + return Nothing + else + fmap Just (peekCostCentre costCenterCacheRef cc_link_ptr) + + let result = CostCentre { + cc_ccID = cc_ccID', + cc_label = cc_label', + cc_module = cc_module', + cc_srcloc = cc_srcloc', + cc_mem_alloc = cc_mem_alloc', + cc_time_ticks = cc_time_ticks', + cc_is_caf = cc_is_caf', + cc_link = cc_link' + } + + writeIORef costCenterCacheRef (IntMap.insert ptrAsInt result costCenterCache) + + return result + where + ptrAsInt = ptrToInt ptr + +peekIndexTable :: AddressSet -> IORef (AddressMap CostCentre) -> Ptr indexTable -> IO (Maybe IndexTable) +peekIndexTable _ _ ptr | ptr == nullPtr = return Nothing +peekIndexTable loopBreakers costCenterCacheRef ptr = do + it_cc_ptr <- (#peek struct IndexTable_, cc) ptr + it_cc' <- peekCostCentre costCenterCacheRef it_cc_ptr + it_ccs_ptr <- (#peek struct IndexTable_, ccs) ptr + it_ccs' <- peekCostCentreStack loopBreakers costCenterCacheRef it_ccs_ptr + it_next_ptr <- (#peek struct IndexTable_, next) ptr + it_next' <- peekIndexTable loopBreakers costCenterCacheRef it_next_ptr + it_back_edge' <- (#peek struct IndexTable_, back_edge) ptr + + return $ Just IndexTable { + it_cc = it_cc', + it_ccs = it_ccs', + it_next = it_next', + it_back_edge = it_back_edge' + } + +-- | casts a @Ptr@ to an @Int@ +ptrToInt :: Ptr a -> Int +ptrToInt (Ptr a##) = I## (addr2Int## a##) + +#else +import Prelude +import Foreign + +import GHC.Exts.Heap.ProfInfo.Types + +peekStgTSOProfInfo :: Ptr a -> IO (Maybe StgTSOProfInfo) +peekStgTSOProfInfo _ = return Nothing +#endif diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs new file mode 100644 index 0000000000..b6915b374d --- /dev/null +++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveGeneric #-} + +module GHC.Exts.Heap.ProfInfo.Types where + +import Prelude +import Data.Word +import GHC.Generics + +-- | This is a somewhat faithful representation of StgTSOProfInfo. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/TSO.h> +-- for more details on this data structure. +data StgTSOProfInfo = StgTSOProfInfo { + cccs :: Maybe CostCentreStack +} deriving (Show, Generic) + +-- | This is a somewhat faithful representation of CostCentreStack. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h> +-- for more details on this data structure. +data CostCentreStack = CostCentreStack { + ccs_ccsID :: Int, + ccs_cc :: CostCentre, + ccs_prevStack :: Maybe CostCentreStack, + ccs_indexTable :: Maybe IndexTable, + ccs_root :: Maybe CostCentreStack, + ccs_depth :: Word, + ccs_scc_count :: Word64, + ccs_selected :: Word, + ccs_time_ticks :: Word, + ccs_mem_alloc :: Word64, + ccs_inherited_alloc :: Word64, + ccs_inherited_ticks :: Word +} deriving (Show, Generic, Eq) + +-- | This is a somewhat faithful representation of CostCentre. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h> +-- for more details on this data structure. +data CostCentre = CostCentre { + cc_ccID :: Int, + cc_label :: String, + cc_module :: String, + cc_srcloc :: Maybe String, + cc_mem_alloc :: Word64, + cc_time_ticks :: Word, + cc_is_caf :: Bool, + cc_link :: Maybe CostCentre +} deriving (Show, Generic, Eq) + +-- | This is a somewhat faithful representation of IndexTable. See +-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h> +-- for more details on this data structure. +data IndexTable = IndexTable { + it_cc :: CostCentre, + it_ccs :: Maybe CostCentreStack, + it_next :: Maybe IndexTable, + it_back_edge :: Bool +} deriving (Show, Generic, Eq) diff --git a/libraries/ghc-heap/ghc-heap.cabal.in b/libraries/ghc-heap/ghc-heap.cabal.in index e0f15abd3f..8937b4aa46 100644 --- a/libraries/ghc-heap/ghc-heap.cabal.in +++ b/libraries/ghc-heap/ghc-heap.cabal.in @@ -25,6 +25,7 @@ library build-depends: base >= 4.9.0 && < 5.0 , ghc-prim > 0.2 && < 0.9 , rts == 1.0.* + , containers >= 0.6.2.1 && < 0.7 ghc-options: -Wall cmm-sources: cbits/HeapPrim.cmm @@ -39,3 +40,10 @@ library GHC.Exts.Heap.InfoTable.Types GHC.Exts.Heap.InfoTableProf GHC.Exts.Heap.Utils + GHC.Exts.Heap.FFIClosures + GHC.Exts.Heap.FFIClosures_ProfilingDisabled + GHC.Exts.Heap.FFIClosures_ProfilingEnabled + GHC.Exts.Heap.ProfInfo.Types + GHC.Exts.Heap.ProfInfo.PeekProfInfo + GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled + GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled diff --git a/libraries/ghc-heap/tests/TestUtils.hs b/libraries/ghc-heap/tests/TestUtils.hs new file mode 100644 index 0000000000..4f297cae3a --- /dev/null +++ b/libraries/ghc-heap/tests/TestUtils.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MagicHash #-} +module TestUtils where + +assertEqual :: (Show a, Eq a) => a -> a -> IO () +assertEqual a b + | a /= b = error (show a ++ " /= " ++ show b) + | otherwise = return () diff --git a/libraries/ghc-heap/tests/all.T b/libraries/ghc-heap/tests/all.T index 89e6f47ecb..fcafb9fa45 100644 --- a/libraries/ghc-heap/tests/all.T +++ b/libraries/ghc-heap/tests/all.T @@ -36,3 +36,18 @@ test('closure_size_noopt', ], compile_and_run, ['']) +test('tso_and_stack_closures', + [extra_files(['create_tso.c','create_tso.h','TestUtils.hs']), + only_ways(['profthreaded']), + ignore_stdout, + ignore_stderr + ], + multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], '']) + +test('parse_tso_flags', + [extra_files(['TestUtils.hs']), + only_ways(['normal']), + ignore_stdout, + ignore_stderr + ], + compile_and_run, ['']) diff --git a/libraries/ghc-heap/tests/create_tso.c b/libraries/ghc-heap/tests/create_tso.c new file mode 100644 index 0000000000..4b00333197 --- /dev/null +++ b/libraries/ghc-heap/tests/create_tso.c @@ -0,0 +1,82 @@ +#include "Rts.h" +#include "RtsAPI.h" + +// Assumes the rts is paused +void unpack_closure + ( StgClosure * inClosure + , const 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; +} + +// Must be called from a safe FFI call. +void create_and_unpack_tso_and_stack + // TSO + ( StgTSO ** outTso + , const 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 + , const 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 + PauseToken * token = rts_pause(); + Capability * cap = pauseTokenCapability(token); + + // Create TSO/Stack + HaskellObj trueClosure = rts_mkBool(cap, 1); + *outTso = createGenThread(cap, 500U, trueClosure); + + // Unpack TSO + unpack_closure( + (StgClosure*)(*outTso), + outTsoInfoTablePtr, + outTsoHeapRepSize, + outTsoHeapRep, + outTsoPointersSize, + outTsoPointers); + + // Unpack STACK + StgClosure * outStackAsClosure = (*outTsoPointers)[2]; + *outStack = (StgTSO *)outStackAsClosure; + unpack_closure( + outStackAsClosure, + outStackInfoTablePtr, + outStackHeapRepSize, + outStackHeapRep, + outStackPointersSize, + outStackPointers); + + // Resume RTS + rts_resume(token); +} diff --git a/libraries/ghc-heap/tests/create_tso.h b/libraries/ghc-heap/tests/create_tso.h new file mode 100644 index 0000000000..1c24cc2e82 --- /dev/null +++ b/libraries/ghc-heap/tests/create_tso.h @@ -0,0 +1,19 @@ +#include "Rts.h" +#include "RtsAPI.h" + +void create_and_unpack_tso_and_stack + // TSO + ( StgTSO ** outTso + , const 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 + , const 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 + ); diff --git a/libraries/ghc-heap/tests/parse_tso_flags.hs b/libraries/ghc-heap/tests/parse_tso_flags.hs new file mode 100644 index 0000000000..51802a32be --- /dev/null +++ b/libraries/ghc-heap/tests/parse_tso_flags.hs @@ -0,0 +1,17 @@ +import GHC.Exts.Heap.Closures +import GHC.Exts.Heap.FFIClosures +import TestUtils + +main :: IO() +main = do + assertEqual (parseTsoFlags 0) [] + assertEqual (parseTsoFlags 1) [TsoFlagsUnknownValue 1] + assertEqual (parseTsoFlags 2) [TsoLocked] + assertEqual (parseTsoFlags 4) [TsoBlockx] + assertEqual (parseTsoFlags 8) [TsoInterruptible] + assertEqual (parseTsoFlags 16) [TsoStoppedOnBreakpoint] + assertEqual (parseTsoFlags 64) [TsoMarked] + assertEqual (parseTsoFlags 128) [TsoSqueezed] + assertEqual (parseTsoFlags 256) [TsoAllocLimit] + + assertEqual (parseTsoFlags 6) [TsoLocked, TsoBlockx] diff --git a/libraries/ghc-heap/tests/tso_and_stack_closures.hs b/libraries/ghc-heap/tests/tso_and_stack_closures.hs new file mode 100644 index 0000000000..42e871bb1f --- /dev/null +++ b/libraries/ghc-heap/tests/tso_and_stack_closures.hs @@ -0,0 +1,167 @@ +{-# 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.IO ( IO(..) ) +import GHC.Exts +import GHC.Exts.Heap +import qualified GHC.Exts.Heap.FFIClosures as FFIClosures +import GHC.Word + +import TestUtils + +main :: IO () +main = do + (tso, stack) <- {-# SCC "MyCostCentre" #-} createAndUnpackTSOAndSTACKClosure + assertEqual (getClosureType tso) TSO + assertEqual (what_next tso) ThreadRunGHC + assertEqual (why_blocked tso) NotBlocked + assertEqual (saved_errno tso) 0 + forM_ (flags tso) $ \flag -> case flag of + TsoFlagsUnknownValue _ -> error $ "Unknown flag: " ++ show flag + _ | flag `elem` + [ TsoLocked + , TsoBlockx + , TsoStoppedOnBreakpoint + , TsoSqueezed + ] -> error $ "Unexpected flag: " ++ show flag + _ -> return () + + assertEqual (getClosureType stack) STACK + +#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 + +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 + +getClosureType :: GenClosure b -> ClosureType +getClosureType = tipe . info + +type StgTso = Any +type StgStack = Any +data MBA a = MBA (MutableByteArray# a) +data BA = BA ByteArray# + +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 () + +createAndUnpackTSOAndSTACKClosure + :: IO ( GenClosure (Ptr Any) + , GenClosure (Ptr Any) + ) +createAndUnpackTSOAndSTACKClosure = do + + alloca $ \ptrPtrTso -> do + alloca $ \ptrPtrTsoInfoTable -> do + alloca $ \ptrTsoHeapRepSize -> do + alloca $ \ptrPtrTsoHeapRep -> do + alloca $ \ptrTsoPointersSize -> do + alloca $ \ptrPtrPtrTsoPointers -> do + + 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 + ptrPtrClosureInfoTable + ptrClosureHeapRepSize + ptrPtrClosureHeapRep + ptrClosurePointersSize + ptrPtrPtrClosurePointers = do + 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# (extendWord8# 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 + heapRep + ptrInfoTable + ptrPtrPointers + + tso <- fromHeapRep + ptrPtrTsoInfoTable + ptrTsoHeapRepSize + ptrPtrTsoHeapRep + ptrTsoPointersSize + ptrPtrPtrTsoPointers + + stack <- fromHeapRep + ptrPtrStackInfoTable + ptrStackHeapRepSize + ptrPtrStackHeapRep + ptrStackPointersSize + ptrPtrPtrStackPointers + + return (tso, stack) diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index ad94776a9f..d21686a326 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables, - GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-} + GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, + CPP #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -- | @@ -29,7 +30,7 @@ import GHCi.TH.Binary () -- For Binary instances import GHCi.BreakArray import GHC.LanguageExtensions -import GHC.Exts.Heap +import qualified GHC.Exts.Heap as Heap import GHC.ForeignSrcLang import GHC.Fingerprint import Control.Concurrent @@ -110,7 +111,7 @@ data Message a where -> Int -- constr tag -> Int -- pointer tag -> ByteString -- constructor desccription - -> Message (RemotePtr StgInfoTable) + -> Message (RemotePtr Heap.StgInfoTable) -- | Evaluate a statement EvalStmt @@ -211,7 +212,7 @@ data Message a where -- type reconstruction. GetClosure :: HValueRef - -> Message (GenClosure HValueRef) + -> Message (Heap.GenClosure HValueRef) -- | Evaluate something. This is used to support :force in GHCi. Seq @@ -449,10 +450,20 @@ instance Binary (FunPtr a) where get = castPtrToFunPtr <$> get -- Binary instances to support the GetClosure message -instance Binary StgInfoTable -instance Binary ClosureType -instance Binary PrimType -instance Binary a => Binary (GenClosure a) +#if MIN_VERSION_ghc_heap(8,11,0) +instance Binary Heap.StgTSOProfInfo +instance Binary Heap.CostCentreStack +instance Binary Heap.CostCentre +instance Binary Heap.IndexTable +instance Binary Heap.WhatNext +instance Binary Heap.WhyBlocked +instance Binary Heap.TsoFlags +#endif + +instance Binary Heap.StgInfoTable +instance Binary Heap.ClosureType +instance Binary Heap.PrimType +instance Binary a => Binary (Heap.GenClosure a) data Msg = forall a . (Binary a, Show a) => Msg (Message a) diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs index 0a99845966..858c312b34 100644 --- a/libraries/ghci/GHCi/Run.hs +++ b/libraries/ghci/GHCi/Run.hs @@ -32,7 +32,7 @@ import Data.Binary.Get import Data.ByteString (ByteString) import qualified Data.ByteString.Unsafe as B import GHC.Exts -import GHC.Exts.Heap +import qualified GHC.Exts.Heap as Heap import GHC.Stack import Foreign hiding (void) import Foreign.C @@ -93,8 +93,8 @@ run m = case m of toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc StartTH -> startTH GetClosure ref -> do - clos <- getClosureData =<< localRef ref - mapM (\(Box x) -> mkRemoteRef (HValue x)) clos + clos <- Heap.getClosureData =<< localRef ref + mapM (\(Heap.Box x) -> mkRemoteRef (HValue x)) clos Seq ref -> doSeq ref ResumeSeq ref -> resumeSeq ref _other -> error "GHCi.Run.run" |