[Git][ghc/ghc][wip/ghc-debug] 8 commits: Decode CostCentreStacks, CostCentres and InfoTables (#18405)
Sven Tennie
gitlab at gitlab.haskell.org
Sat Aug 22 11:26:56 UTC 2020
Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
9aa7aef9 by Sven Tennie at 2020-08-22T12:10:02+02:00
Decode CostCentreStacks, CostCentres and InfoTables (#18405)
Use cache and loop breakers for CostCentre, CostCentreStack and IndexTable decoding (#18405)
Cleanup
Query caches once, not twice
Fix Haddock for EndTSOQueue
Run prof_info test only in prof_ways (#18405)
That's the required way for collecting PROFILING data (e.g.
CostCentres).
Add missing module to ghc-heap.cabal
Rearrange #ifdef with GHC version
This prevents some "unused" warnings.
Fix cpp redefinition warnings
With --Werror this made the build fail.
Add dummy import for PeekProfInfo_ProfilingEnabled for non-profiled builds
This circumvents #15197. Otherwise PeekProfInfo_ProfilingEnabled
wouldn't be available for make-based builds.
Add assertions to prof_info test (#18405)
Cache only CostCentres during ProfInfo decoding
Looks like caches for CostCentreStacks and IndexTables are not needed.
Fix warning
- - - - -
96f56aab by Sven Tennie at 2020-08-22T12:13:22+02:00
Fix types in tests
Use `Ptr ()` instead of `Word` to communicate that addresses/pointers
are meant.
Cleanup
- - - - -
19a4b3b4 by Sven Tennie at 2020-08-22T12:13:25+02:00
Introduce LiftedClosure
This is a representation for closures that do not have a represantation
in the Haskell language. I.e. things like TSOs.
Fix prof_info test
Line number of self defined cost centre changed.
- - - - -
a95d99cf by Sven Tennie at 2020-08-22T12:13:25+02:00
Expect stack_marking starting from GHC 8.10
This field was introduced with GHC 8.10.
- - - - -
c6f86b1d by Sven Tennie at 2020-08-22T12:13:25+02:00
Add WhatNext, WhyBlocked and TsoFlags
Additionally extract TestUtils with common test functions.
Parse TSO flags
- - - - -
eef76d26 by Sven Tennie at 2020-08-22T12:13:25+02:00
END_TSO_QUEUE is not a closure type on it's own
Indeed it's a CONSTR_NOCAF.
Delete unused function
- - - - -
2731382e by Sven Tennie at 2020-08-22T12:13:25+02:00
Rename boundTaskExiting and getTask (#18405)
Both are directly related to myTask, which the new names now reflect.
- - - - -
d92c67f0 by Sven Tennie at 2020-08-22T12:18:29+02:00
Mark unsafe accesses (#18405)
StgTSO and StgStack are very dynamic by nature. Accesses to outdated
pointers lead to segmentation faults or absolutely wrong results.
So, make sure (by naming) that the users nows about these facts.
- - - - -
24 changed files:
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Runtime/Interpreter.hs
- includes/rts/Task.h
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.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/Exts/Heap/ProfInfo/Types.hs
- + libraries/ghc-heap/GHC/Exts/Heap/Ptr/Utils.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- + libraries/ghc-heap/tests/TestUtils.hs
- libraries/ghc-heap/tests/all.T
- libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
- + libraries/ghc-heap/tests/parse_tso_flags.hs
- + libraries/ghc-heap/tests/prof_info.hs
- libraries/ghc-heap/tests/tso_and_stack_closures.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/RtsAPI.c
- rts/Schedule.c
- rts/Task.c
- rts/Task.h
- rts/sm/NonMoving.c
Changes:
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -36,7 +36,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
-- -----------------------------------------------------------------------------
@@ -71,7 +71,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
=====================================
@@ -94,7 +94,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)
@@ -386,7 +386,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)
=====================================
includes/rts/Task.h
=====================================
@@ -15,9 +15,9 @@
typedef struct Task_ Task;
-// Create a new Task for a bound thread. This Task must be released
-// by calling boundTaskExiting. The Task is cached in
-// thread-local storage and will remain even after boundTaskExiting()
+// Create a new Task for a bound thread. This Task must be released
+// by calling exitMyTask(). The Task is cached in
+// thread-local storage and will remain even after exitMyTask()
// has been called; to free the memory, see freeMyTask().
//
Task* newBoundTask (void);
@@ -25,11 +25,10 @@ Task* newBoundTask (void);
// Return the current OS thread's Task, which is created if it doesn't already
// exist. After you have finished using RTS APIs, you should call freeMyTask()
// to release this thread's Task.
-Task* getTask (void);
+Task* getMyTask (void);
-// The current task is a bound task that is exiting.
-//
-void boundTaskExiting (Task *task);
+// Exit myTask - This is the counterpart of newBoundTask().
+void exitMyTask (void);
// Free a Task if one was previously allocated by newBoundTask().
// This is not necessary unless the thread that called newBoundTask()
@@ -37,4 +36,3 @@ void boundTaskExiting (Task *task);
// functions.
//
void freeMyTask(void);
-
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -9,6 +9,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UnliftedFFITypes #-}
{-|
Module : GHC.Exts.Heap
@@ -23,9 +24,13 @@ values, i.e. to investigate sharing and lazy evaluation.
module GHC.Exts.Heap (
-- * Closure types
Closure
+ , LiftedClosure
, GenClosure(..)
, ClosureType(..)
, PrimType(..)
+ , WhatNext(..)
+ , WhyBlocked(..)
+ , TsoFlags(..)
, HasHeapRep(getClosureDataX)
, getClosureData
@@ -38,6 +43,12 @@ module GHC.Exts.Heap (
, peekItbl
, pokeItbl
+ -- * Cost Centre (profiling) types
+ , StgTSOProfInfo(..)
+ , IndexTable(..)
+ , CostCentre(..)
+ , CostCentreStack(..)
+
-- * Closure inspection
, getBoxedClosureData
, allClosures
@@ -52,9 +63,19 @@ 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.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
@@ -71,12 +92,19 @@ 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').
-- Inside a GHC context 'b' is usually a 'GHC.Exts.Heap.Closures.Box'
-- containing a thunk or an evaluated heap object. Outside it can be a
-- 'Word' for "raw" usage of pointers.
+
getClosureDataX ::
(forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
-- ^ Helper function to get info table, memory and pointers of the
@@ -166,6 +194,7 @@ getClosureData = getClosureDataX getClosureRaw
-- @collect_pointers()@ in @rts/Heap.c at .
--
-- For most use cases 'getClosureData' is an easier to use alternative.
+
getClosureX :: forall a b.
(forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
-- ^ Helper function to get info table, memory and pointers of the
@@ -325,16 +354,15 @@ getClosureX get_closure_raw x = do
allocaArray (length wds) (\ptr -> do
pokeArray ptr wds
- fields <- FFIClosures.peekTSOFields ptr
-
+ fields <- FFIClosures.peekTSOFields peekStgTSOProfInfo ptr
pure $ TSOClosure
{ info = itbl
- , _link = (pts !! 0)
- , global_link = (pts !! 1)
+ , unsafe_link = (pts !! 0)
+ , unsafe_global_link = (pts !! 1)
, tsoStack = (pts !! 2)
- , trec = (pts !! 3)
- , blocked_exceptions = (pts !! 4)
- , bq = (pts !! 5)
+ , unsafe_trec = (pts !! 3)
+ , unsafe_blocked_exceptions = (pts !! 4)
+ , unsafe_bq = (pts !! 5)
, what_next = FFIClosures.tso_what_next fields
, why_blocked = FFIClosures.tso_why_blocked fields
, flags = FFIClosures.tso_flags fields
@@ -343,6 +371,7 @@ getClosureX get_closure_raw x = do
, 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
}
)
STACK -> do
@@ -359,8 +388,8 @@ getClosureX get_closure_raw x = do
{ info = itbl
, stack_size = FFIClosures.stack_size fields
, stack_dirty = FFIClosures.stack_dirty fields
- , stackPointer = (pts !! 0)
- , stack = FFIClosures.stack fields
+ , unsafeStackPointer = (pts !! 0)
+ , unsafeStack = FFIClosures.stack fields
#if __GLASGOW_HASKELL__ >= 811
, stack_marking = FFIClosures.stack_marking fields
#endif
=====================================
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
@@ -271,35 +276,42 @@ data GenClosure b
-- | Representation of StgTSO: A Thread State Object.
-- The values for 'what_next', 'why_blocked' and 'flags' are defined in
-- @Constants.h at .
+ -- Fields marked as @unsafe@ are backed by dynamic pointers and should only
+ -- be accessed when the garbage collector is stopped. Otherwise segmentation
+ -- faults may happen when an invalidated pointer is accessed.
| TSOClosure
{ info :: !StgInfoTable
-- pointers
- , _link :: !b
- , global_link :: !b
+ , unsafe_link :: !b
+ , unsafe_global_link :: !b
, tsoStack :: !b -- ^ stackobj from StgTSO
- , trec :: !b
- , blocked_exceptions :: !b
- , bq :: !b
+ , unsafe_trec :: !b
+ , unsafe_blocked_exceptions :: !b
+ , unsafe_bq :: !b
-- values
- , what_next :: Word16
- , why_blocked :: Word16
- , flags :: Word32
+ , 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'.
+ -- | Representation of StgStack: The 'tsoStack' of a 'TSOClosure'.
+ -- Fields marked as @unsafe@ are backed by dynamic pointers and should only
+ -- be accessed when the garbage collector is stopped. Otherwise segmentation
+ -- faults may happen when an invalidated pointer is accessed.
| StackClosure
{ info :: !StgInfoTable
, stack_size :: !Word32 -- ^ stack size in *words*
, stack_dirty :: !Word8 -- ^ non-zero => dirty
-#if __GLASGOW_HASKELL__ >= 811
+#if __GLASGOW_HASKELL__ >= 810
, stack_marking :: Word8
#endif
- , stackPointer :: !b -- ^ current stack pointer
- , stack :: [Word]
+ , unsafeStackPointer :: !b -- ^ current stack pointer
+ , unsafeStack :: [Word]
}
------------------------------------------------------------
@@ -366,6 +378,43 @@ data PrimType
| PDouble
deriving (Eq, Show, Generic)
+data WhatNext
+ = ThreadRunGHC
+ | ThreadInterpret
+ | ThreadKilled
+ | ThreadComplete
+ | WhatNextUnknownValue -- ^ 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 -- ^ Please report this as a bug
+ deriving (Eq, Show, Generic)
+
+data TsoFlags
+ = TsoLocked
+ | TsoBlockx
+ | TsoInterruptible
+ | TsoStoppedOnBreakpoint
+ | TsoMarked
+ | TsoSqueezed
+ | TsoAllocLimit
+ | TsoFlagsUnknownValue -- ^ 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.hsc
=====================================
@@ -5,26 +5,28 @@ module GHC.Exts.Heap.FFIClosures where
import Prelude
import Foreign
-
--- TODO use sum type for what_next, why_blocked, flags?
+import GHC.Exts.Heap.ProfInfo.Types
+import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
data TSOFields = TSOFields {
- tso_what_next :: Word16,
- tso_why_blocked :: Word16,
- tso_flags :: Word32,
+ 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
--- TODO StgTSOProfInfo prof is optionally included, but looks very interesting.
+ tso_tot_stack_size :: Word32,
+ tso_prof :: Maybe StgTSOProfInfo
}
-- | Get non-pointer fields from @StgTSO_@ (@TSO.h@)
-peekTSOFields :: Ptr a -> IO TSOFields
-peekTSOFields ptr = do
+peekTSOFields :: (Ptr tsoPtr -> IO (Maybe StgTSOProfInfo))
+ -> Ptr tsoPtr
+ -> IO TSOFields
+peekTSOFields peekProfInfo ptr = do
what_next' <- (#peek struct StgTSO_, what_next) ptr
why_blocked' <- (#peek struct StgTSO_, why_blocked) ptr
flags' <- (#peek struct StgTSO_, flags) ptr
@@ -33,22 +35,69 @@ peekTSOFields 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
return TSOFields {
- tso_what_next = what_next',
- tso_why_blocked = why_blocked',
- tso_flags = flags',
+ 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_dirty = dirty',
tso_alloc_limit = alloc_limit',
- tso_tot_stack_size = tot_stack_size'
+ 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
+
+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
+
+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 _ = [TsoFlagsUnknownValue]
+
+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
+#if __GLASGOW_HASKELL__ >= 810
stack_marking :: Word8,
#endif
stack :: [Word]
@@ -59,7 +108,7 @@ 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
+#if __GLASGOW_HASKELL__ >= 810
marking' <- (#peek struct StgStack_, marking) ptr
#endif
@@ -69,7 +118,7 @@ peekStackFields ptr = do
return StackFields {
stack_size = stack_size',
stack_dirty = dirty',
-#if __GLASGOW_HASKELL__ >= 811
+#if __GLASGOW_HASKELL__ >= 810
stack_marking = marking',
#endif
stack = stack'
=====================================
libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE CPP, DeriveGeneric #-}
+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,168 @@
+{-# LANGUAGE CPP, DeriveGeneric #-}
+module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled(
+ peekStgTSOProfInfo
+) where
+
+#if __GLASGOW_HASKELL__ >= 811
+
+-- 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.ProfInfo.PeekProfInfo_ProfilingDisabled.
+#define PROFILING
+
+#include "Rts.h"
+#undef BLOCK_SIZE
+#undef MBLOCK_SIZE
+#undef BLOCKS_PER_MBLOCK
+#include "DerivedConstants.h"
+
+import Prelude
+import Foreign
+
+import Foreign.C.String
+import GHC.Exts.Heap.ProfInfo.Types
+
+import Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IntMap
+
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IntSet
+
+import Control.Monad.Trans.State
+import Control.Monad.IO.Class
+
+import GHC.Exts.Heap.Ptr.Utils
+
+-- Use Int based containers for pointers (addresses) for better performance.
+-- These will be queried a lot!
+type AddressSet = IntSet
+type AddressMap = IntMap
+
+data Cache = Cache {
+ ccCache :: AddressMap CostCentre
+}
+type DecoderMonad a = StateT Cache IO a
+
+peekStgTSOProfInfo :: Ptr a -> IO (Maybe StgTSOProfInfo)
+peekStgTSOProfInfo tsoPtr = do
+ cccs_ptr <- peekByteOff tsoPtr cccsOffset
+ cccs' <- evalStateT (peekCostCentreStack IntSet.empty cccs_ptr) $ Cache IntMap.empty
+
+ return $ Just StgTSOProfInfo {
+ cccs = cccs'
+ }
+
+cccsOffset :: Int
+cccsOffset = (#const OFFSET_StgTSO_cccs) + (#size StgHeader)
+
+peekCostCentreStack :: AddressSet -> Ptr costCentreStack -> DecoderMonad (Maybe CostCentreStack)
+peekCostCentreStack _ ptr | ptr == nullPtr = return Nothing
+peekCostCentreStack loopBreakers ptr | IntSet.member (ptrToInt ptr) loopBreakers = return Nothing
+peekCostCentreStack loopBreakers ptr = do
+ ccs_ccsID' <- liftIO $ (#peek struct CostCentreStack_, ccsID) ptr
+ ccs_cc_ptr <- liftIO $ (#peek struct CostCentreStack_, cc) ptr
+ ccs_cc' <- peekCostCentre ccs_cc_ptr
+ ccs_prevStack_ptr <- liftIO $ (#peek struct CostCentreStack_, prevStack) ptr
+ let loopBreakers' = (IntSet.insert ptrAsInt loopBreakers)
+ ccs_prevStack' <- peekCostCentreStack loopBreakers' ccs_prevStack_ptr
+ ccs_indexTable_ptr <- liftIO $ (#peek struct CostCentreStack_, indexTable) ptr
+ ccs_indexTable' <- peekIndexTable loopBreakers' ccs_indexTable_ptr
+ ccs_root_ptr <- liftIO $ (#peek struct CostCentreStack_, root) ptr
+ ccs_root' <- peekCostCentreStack loopBreakers' ccs_root_ptr
+ ccs_depth' <- liftIO $ (#peek struct CostCentreStack_, depth) ptr
+ ccs_scc_count' <- liftIO $ (#peek struct CostCentreStack_, scc_count) ptr
+ ccs_selected' <- liftIO $ (#peek struct CostCentreStack_, selected) ptr
+ ccs_time_ticks' <- liftIO $ (#peek struct CostCentreStack_, time_ticks) ptr
+ ccs_mem_alloc' <- liftIO $ (#peek struct CostCentreStack_, mem_alloc) ptr
+ ccs_inherited_alloc' <- liftIO $ (#peek struct CostCentreStack_, inherited_alloc) ptr
+ ccs_inherited_ticks' <- liftIO $ (#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 :: Ptr costCentre -> DecoderMonad CostCentre
+peekCostCentre ptr = do
+ cache <- get
+ case IntMap.lookup ptrAsInt (ccCache cache) of
+ (Just a) -> return a
+ Nothing -> do
+ cc_ccID' <- liftIO $ (#peek struct CostCentre_, ccID) ptr
+ cc_label_ptr <- liftIO $ (#peek struct CostCentre_, label) ptr
+ cc_label' <- liftIO $ peekCString cc_label_ptr
+ cc_module_ptr <- liftIO $ (#peek struct CostCentre_, module) ptr
+ cc_module' <- liftIO $ peekCString cc_module_ptr
+ cc_srcloc_ptr <- liftIO $ (#peek struct CostCentre_, srcloc) ptr
+ cc_srcloc' <- liftIO $ do
+ if cc_srcloc_ptr == nullPtr then
+ return Nothing
+ else
+ fmap Just (peekCString cc_srcloc_ptr)
+ cc_mem_alloc' <- liftIO $ (#peek struct CostCentre_, mem_alloc) ptr
+ cc_time_ticks' <- liftIO $ (#peek struct CostCentre_, time_ticks) ptr
+ cc_is_caf' <- liftIO $ (#peek struct CostCentre_, is_caf) ptr
+ cc_link_ptr <- liftIO $ (#peek struct CostCentre_, link) ptr
+ cc_link' <- if cc_link_ptr == nullPtr then
+ return Nothing
+ else
+ fmap Just (peekCostCentre 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'
+ }
+
+ let updatedCCCache = IntMap.insert ptrAsInt result (ccCache cache)
+ put $ cache { ccCache = updatedCCCache }
+
+ return result
+ where
+ ptrAsInt = ptrToInt ptr
+
+peekIndexTable :: AddressSet -> Ptr indexTable -> DecoderMonad (Maybe IndexTable)
+peekIndexTable _ ptr | ptr == nullPtr = return Nothing
+peekIndexTable loopBreakers ptr = do
+ it_cc_ptr <- liftIO $ (#peek struct IndexTable_, cc) ptr
+ it_cc' <- peekCostCentre it_cc_ptr
+ it_ccs_ptr <- liftIO $ (#peek struct IndexTable_, ccs) ptr
+ it_ccs' <- peekCostCentreStack loopBreakers it_ccs_ptr
+ it_next_ptr <- liftIO $ (#peek struct IndexTable_, next) ptr
+ it_next' <- peekIndexTable loopBreakers it_next_ptr
+ it_back_edge' <- liftIO $ (#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'
+ }
+
+#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,44 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module GHC.Exts.Heap.ProfInfo.Types where
+
+import Prelude
+import Data.Word
+import GHC.Generics
+
+data StgTSOProfInfo = StgTSOProfInfo {
+ cccs :: Maybe CostCentreStack
+} deriving (Show, Generic)
+
+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)
+
+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)
+
+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/Exts/Heap/Ptr/Utils.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE CPP, DeriveGeneric, MagicHash #-}
+
+module GHC.Exts.Heap.Ptr.Utils where
+
+import Prelude
+import GHC.Ptr
+import GHC.Exts
+
+-- | casts a @Ptr@ to an @Int@
+ptrToInt :: Ptr a -> Int
+ptrToInt (Ptr a#) = I# (addr2Int# a#)
=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -25,6 +25,8 @@ library
build-depends: base >= 4.9.0 && < 5.0
, ghc-prim > 0.2 && < 0.8
, rts == 1.0.*
+ , containers >= 0.6.2.1 && < 0.7
+ , transformers == 0.5.*
ghc-options: -Wall
cmm-sources: cbits/HeapPrim.cmm
@@ -40,3 +42,7 @@ library
GHC.Exts.Heap.InfoTableProf
GHC.Exts.Heap.Utils
GHC.Exts.Heap.FFIClosures
+ GHC.Exts.Heap.ProfInfo.Types
+ GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
+ GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled
+ GHC.Exts.Heap.Ptr.Utils
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE MagicHash #-}
+module TestUtils where
+
+import GHC.Exts.Heap (getClosureData, LiftedClosure, Box, GenClosure)
+import Foreign (Ptr)
+import GHC.Exts (Ptr, Addr#, unsafeCoerce#)
+import GHC.Ptr (Ptr(Ptr))
+
+assertEqual :: (Show a, Eq a) => a -> a -> IO ()
+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,15 +37,32 @@ test('closure_size_noopt',
compile_and_run, [''])
test('tso_and_stack_closures',
- [extra_files(['create_tso.c','create_tso.h']),
+ [extra_files(['create_tso.c','create_tso.h', 'TestUtils.hs']),
ignore_stdout,
ignore_stderr
],
multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], ''])
test('list_threads_and_misc_roots',
- [extra_files(['list_threads_and_misc_roots_c.c','list_threads_and_misc_roots_c.h']),
+ [extra_files(['list_threads_and_misc_roots_c.c','list_threads_and_misc_roots_c.h','TestUtils.hs']),
ignore_stdout,
ignore_stderr
],
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']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ compile_and_run, [''])
=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
=====================================
@@ -7,11 +7,7 @@ import Control.Concurrent
import GHC.Exts.Heap
import GHC.Exts
-
--- Invent a type to bypass the type constraints of getClosureData.
--- Infact this will be a Word#, that is directly given to unpackClosure#
--- (which is a primop that expects a pointer to a closure).
-data FoolClosure
+import TestUtils
foreign import ccall safe "list_threads_and_misc_roots_c.h listThreadsAndMiscRoots"
listThreadsAndMiscRoots_c :: IO ()
@@ -20,13 +16,13 @@ foreign import ccall safe "list_threads_and_misc_roots_c.h getTSOCount"
getTSOCount_c :: IO Int
foreign import ccall safe "list_threads_and_misc_roots_c.h getTSOs"
- getTSOs_c :: IO (Ptr Word)
+ getTSOs_c :: IO (Ptr (Ptr ()))
foreign import ccall safe "list_threads_and_misc_roots_c.h getMiscRootsCount"
getMiscRootsCount_c :: IO Int
foreign import ccall safe "list_threads_and_misc_roots_c.h getMiscRoots"
- getMiscRoots_c :: IO (Ptr Word)
+ getMiscRoots_c :: IO (Ptr (Ptr ()))
main :: IO ()
main = do
@@ -50,19 +46,6 @@ main = do
return ()
-createClosure :: Word -> IO (GenClosure Box)
-createClosure tsoPtr = do
- let wPtr = unpackWord# tsoPtr
- getClosureData ((unsafeCoerce# wPtr) :: FoolClosure)
-
-unpackWord# :: Word -> Word#
-unpackWord# (W# w#) = w#
-
-assertEqual :: (Show a, Eq a) => a -> a -> IO ()
-assertEqual a b
- | a /= b = error (show a ++ " /= " ++ show b)
- | otherwise = return ()
-
assertIsClosureType :: ClosureType -> IO ()
assertIsClosureType t
| t `elem` enumerate = return ()
=====================================
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]
+ 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/prof_info.hs
=====================================
@@ -0,0 +1,53 @@
+{-# 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,4 +1,4 @@
-{-# LANGUAGE ForeignFunctionInterface, MagicHash, CPP, BangPatterns #-}
+{-# LANGUAGE ForeignFunctionInterface, MagicHash, BangPatterns #-}
import Foreign
import Foreign.C.Types
@@ -7,16 +7,10 @@ import GHC.Exts
import GHC.Word
-#include "ghcconfig.h"
-#include "rts/Constants.h"
+import TestUtils
foreign import ccall unsafe "create_tso.h create_tso"
- c_create_tso:: IO Word
-
--- Invent a type to bypass the type constraints of getClosureData.
--- Infact this will be a Word#, that is directly given to unpackClosure#
--- (which is a primop that expects a pointer to a closure).
-data FoolStgTSO
+ 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
@@ -28,14 +22,13 @@ main = do
assertEqual (why_blocked tso) NotBlocked
assertEqual (saved_errno tso) 0
- print $ "tso : "++ show tso
-
-- The newly created TSO should be on the end of the run queue.
- let !_linkBox = _link tso
+ let !_linkBox = unsafe_link tso
_linkClosure <- getBoxedClosureData _linkBox
assertEqual (name _linkClosure) "END_TSO_QUEUE"
+ assertEqual (getClosureType _linkClosure) CONSTR_NOCAF
- let !global_linkBox = global_link tso
+ let !global_linkBox = unsafe_global_link tso
globalLinkClosure <- getBoxedClosureData global_linkBox
assertEqual (getClosureType globalLinkClosure) TSO
@@ -43,35 +36,26 @@ main = do
stackClosure <- getBoxedClosureData stackBox
assertEqual (getClosureType stackClosure) STACK
- let !stackPointerBox = stackPointer stackClosure
+ let !stackPointerBox = unsafeStackPointer stackClosure
stackPointerClosure <- getBoxedClosureData stackPointerBox
assertEqual (getClosureType stackPointerClosure) RET_SMALL
- let !trecBox = trec tso
+ let !trecBox = unsafe_trec tso
trecClosure <- getBoxedClosureData trecBox
assertEqual (name trecClosure) "NO_TREC"
- let !blockedExceptionsBox = blocked_exceptions tso
+ let !blockedExceptionsBox = unsafe_blocked_exceptions tso
blockedExceptionsClosure <- getBoxedClosureData blockedExceptionsBox
assertEqual (name blockedExceptionsClosure) "END_TSO_QUEUE"
- let !bqBox = bq tso
+ let !bqBox = unsafe_bq tso
bqClosure <- getBoxedClosureData bqBox
assertEqual (name bqClosure) "END_TSO_QUEUE"
createTSOClosure :: IO (GenClosure Box)
createTSOClosure = do
ptr <- c_create_tso
- let wPtr = unpackWord# ptr
- getClosureData ((unsafeCoerce# wPtr) :: FoolStgTSO)
-
-unpackWord# :: Word -> Word#
-unpackWord# (W# w#) = w#
-
-assertEqual :: (Show a, Eq a) => a -> a -> IO ()
-assertEqual a b
- | a /= b = error (show a ++ " /= " ++ show b)
- | otherwise = return ()
+ createClosure ptr
getClosureType :: GenClosure b -> ClosureType
getClosureType = tipe . info
=====================================
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/RtsAPI.c
=====================================
@@ -621,21 +621,21 @@ rts_unlock (Capability *cap)
task = cap->running_task;
ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
- // Now release the Capability. With the capability released, GC
- // may happen. NB. does not try to put the current Task on the
+ // Now release the Capability. With the capability released, GC
+ // may happen. NB. does not try to put the current Task on the
// worker queue.
- // NB. keep cap->lock held while we call boundTaskExiting(). This
+ // NB. keep cap->lock held while we call exitMyTask(). This
// is necessary during shutdown, where we want the invariant that
// after shutdownCapability(), all the Tasks associated with the
- // Capability have completed their shutdown too. Otherwise we
- // could have boundTaskExiting()/workerTaskStop() running at some
+ // Capability have completed their shutdown too. Otherwise we
+ // could have exitMyTask()/workerTaskStop() running at some
// random point in the future, which causes problems for
// freeTaskManager().
ACQUIRE_LOCK(&cap->lock);
releaseCapability_(cap,false);
// Finally, we can release the Task to the free list.
- boundTaskExiting(task);
+ exitMyTask();
RELEASE_LOCK(&cap->lock);
if (task->incall == NULL) {
@@ -794,7 +794,7 @@ void rts_done (void)
void hs_try_putmvar (/* in */ int capability,
/* in */ HsStablePtr mvar)
{
- Task *task = getTask();
+ Task *task = getMyTask();
Capability *cap;
Capability *task_old_cap USED_IF_THREADS;
=====================================
rts/Schedule.c
=====================================
@@ -2082,7 +2082,7 @@ forkProcess(HsStablePtr *entry
RELEASE_LOCK(&capabilities[i]->lock);
}
- boundTaskExiting(task);
+ exitMyTask();
// just return the pid
return pid;
@@ -2762,7 +2762,7 @@ exitScheduler (bool wait_foreign USED_IF_THREADS)
// debugBelch("n_failed_trygrab_idles = %d, n_idle_caps = %d\n",
// n_failed_trygrab_idles, n_idle_caps);
- boundTaskExiting(task);
+ exitMyTask();
}
void
@@ -2821,7 +2821,7 @@ performGC_(bool force_major)
waitForCapability(&cap,task);
scheduleDoGC(&cap,task,force_major,false);
releaseCapability(cap);
- boundTaskExiting(task);
+ exitMyTask();
}
void
=====================================
rts/Task.c
=====================================
@@ -116,7 +116,7 @@ freeTaskManager (void)
return tasksRunning;
}
-Task* getTask (void)
+Task* getMyTask (void)
{
Task *task;
@@ -304,7 +304,7 @@ newBoundTask (void)
stg_exit(EXIT_FAILURE);
}
- task = getTask();
+ task = getMyTask();
task->stopped = false;
@@ -315,13 +315,12 @@ newBoundTask (void)
}
void
-boundTaskExiting (Task *task)
+exitMyTask (void)
{
+ Task* task = myTask();
#if defined(THREADED_RTS)
ASSERT(osThreadId() == task->id);
#endif
- ASSERT(myTask() == task);
-
endInCall(task);
// Set task->stopped, but only if this is the last call (#4850).
@@ -522,7 +521,7 @@ void rts_setInCallCapability (
int preferred_capability,
int affinity USED_IF_THREADS)
{
- Task *task = getTask();
+ Task *task = getMyTask();
task->preferred_capability = preferred_capability;
#if defined(THREADED_RTS)
@@ -539,7 +538,7 @@ void rts_pinThreadToNumaNode (
{
#if defined(THREADED_RTS)
if (RtsFlags.GcFlags.numa) {
- Task *task = getTask();
+ Task *task = getMyTask();
task->node = capNoToNumaNode(node);
if (!DEBUG_IS_ON || !RtsFlags.DebugFlags.numa) { // faking NUMA
setThreadNode(numa_map[task->node]);
=====================================
rts/Task.h
=====================================
@@ -150,7 +150,7 @@ typedef struct Task_ {
bool worker; // == true if this is a worker Task
bool stopped; // == true between newBoundTask and
- // boundTaskExiting, or in a worker Task.
+ // exitMyTask, or in a worker Task.
// So that we can detect when a finalizer illegally calls back into Haskell
bool running_finalizers;
=====================================
rts/sm/NonMoving.c
=====================================
@@ -1215,7 +1215,7 @@ static void nonmovingMark_(MarkQueue *mark_queue, StgWeak **dead_weaks, StgTSO *
#if defined(THREADED_RTS)
finish:
- boundTaskExiting(task);
+ exitMyTask();
// We are done...
mark_thread = 0;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/26f2302e80c4d92f344997b120af5dba0c2fa4f9...d92c67f01bdd1da6f6f8ecebd5365aed3d62dab5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/26f2302e80c4d92f344997b120af5dba0c2fa4f9...d92c67f01bdd1da6f6f8ecebd5365aed3d62dab5
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/20200822/3d235ce8/attachment-0001.html>
More information about the ghc-commits
mailing list