[Git][ghc/ghc][master] ghc-heap: partial TSO/STACK decoding
Marge Bot
gitlab at gitlab.haskell.org
Sat Nov 28 20:41:47 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
625726f9 by David Eichmann at 2020-11-28T15:41:37-05:00
ghc-heap: partial TSO/STACK decoding
Co-authored-by: Sven Tennie <sven.tennie at gmail.com>
Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com>
Co-authored-by: Ben Gamari <bgamari.foss at gmail.com>
- - - - -
22 changed files:
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Runtime/Interpreter.hs
- 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_ProfilingEnabled.hsc
- + libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs
- + libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc
- + libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc
- + libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs
- 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/parse_tso_flags.hs
- + libraries/ghc-heap/tests/tso_and_stack_closures.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Heap.c
- rts/PrimOps.cmm
Changes:
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -37,7 +37,7 @@ import Data.ByteString (ByteString)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Maybe (catMaybes)
-import GHC.Exts.Heap
+import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS
-- -----------------------------------------------------------------------------
@@ -72,7 +72,7 @@ type ItblEnv = NameEnv (Name, ItblPtr)
-- We need the Name in the range so we know which
-- elements to filter out when unloading a module
-newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable)
+newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable)
deriving (Show, NFData)
data UnlinkedBCO
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -103,7 +103,7 @@ import qualified Data.ByteString.Lazy as LB
import Data.Array ((!))
import Data.IORef
import Foreign hiding (void)
-import GHC.Exts.Heap
+import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Exit
import GHC.IO.Handle.Types (Handle)
@@ -395,7 +395,7 @@ getBreakpointVar hsc_env ref ix =
mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
mapM (mkFinalizedHValue hsc_env) mb
-getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
+getClosure :: HscEnv -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)
getClosure hsc_env ref =
withForeignRef ref $ \hval -> do
mb <- iservCmd hsc_env (GetClosure hval)
=====================================
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
=====================================
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 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 :: !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
=====================================
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
=====================================
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'
+ }
+
=====================================
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'
+ }
=====================================
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
=====================================
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
=====================================
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
=====================================
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)
=====================================
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
=====================================
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 ()
=====================================
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, [''])
=====================================
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);
+}
=====================================
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
+ );
=====================================
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]
=====================================
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)
=====================================
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)
=====================================
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"
=====================================
rts/Heap.c
=====================================
@@ -203,7 +203,26 @@ StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *ptrs[siz
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 WEAK:
ptrs[nptrs++] = (StgClosure *)((StgWeak *)closure)->cfinalizers;
ptrs[nptrs++] = (StgClosure *)((StgWeak *)closure)->key;
=====================================
rts/PrimOps.cmm
=====================================
@@ -2371,11 +2371,11 @@ stg_unpackClosurezh ( P_ closure )
clos = UNTAG(closure);
W_ len;
- // The array returned is the raw data for the entire closure.
+ // The array returned, dat_arr, is the raw data for the entire closure.
// The length is variable based upon the closure type, ptrs, and non-ptrs
(len) = foreign "C" heap_view_closureSize(clos "ptr");
- W_ ptrs_arr_sz, ptrs_arr_cards, dat_arr_sz;
+ W_ dat_arr_sz;
dat_arr_sz = SIZEOF_StgArrBytes + WDS(len);
("ptr" dat_arr) = ccall allocateMightFail(MyCapability() "ptr", BYTES_TO_WDS(dat_arr_sz));
@@ -2396,7 +2396,7 @@ for:
W_ ptrArray;
- // Follow the pointers
+ // Collect pointers.
("ptr" ptrArray) = foreign "C" heap_view_closurePtrs(MyCapability() "ptr", clos "ptr");
return (info, dat_arr, ptrArray);
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/625726f988852f5779825a954609d187d9865dc1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/625726f988852f5779825a954609d187d9865dc1
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/20201128/aad6f911/attachment-0001.html>
More information about the ghc-commits
mailing list