[Git][ghc/ghc][wip/ghc-debug] Add WhatNext, WhyBlocked and TsoFlags
Sven Tennie
gitlab at gitlab.haskell.org
Wed Aug 12 13:24:18 UTC 2020
Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
5291dd15 by Sven Tennie at 2020-08-12T15:24:05+02:00
Add WhatNext, WhyBlocked and TsoFlags
Additionally extract TestUtils with common test functions.
- - - - -
9 changed files:
- 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/tests/TestUtils.hs
- libraries/ghc-heap/tests/all.T
- libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
- libraries/ghc-heap/tests/prof_info.hs
- libraries/ghc-heap/tests/tso_and_stack_closures.hs
- libraries/ghci/GHCi/Message.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -28,6 +28,9 @@ module GHC.Exts.Heap (
, GenClosure(..)
, ClosureType(..)
, PrimType(..)
+ , WhatNext(..)
+ , WhyBlocked(..)
+ , TsoFlags(..)
, HasHeapRep(getClosureDataX)
, getClosureData
=====================================
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
@@ -283,9 +286,9 @@ data GenClosure b
, blocked_exceptions :: !b
, 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
@@ -373,6 +376,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
=====================================
@@ -6,13 +6,14 @@ module GHC.Exts.Heap.FFIClosures where
import Prelude
import Foreign
import GHC.Exts.Heap.ProfInfo.Types
+import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
-- TODO use sum type for what_next, why_blocked, flags?
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,
@@ -39,17 +40,50 @@ peekTSOFields peekProfInfo ptr = do
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_prof = tso_prof'
}
+parseWhatNext :: Word16 -> WhatNext
+parseWhatNext w = case w of
+ (#const ThreadRunGHC) -> ThreadRunGHC
+ (#const ThreadInterpret) -> ThreadInterpret
+ (#const ThreadKilled) -> ThreadKilled
+ (#const ThreadComplete) -> ThreadComplete
+ _ -> WhatNextUnknownValue
+
+-- TODO: define mapping
+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
+
+-- TODO: define mapping
+parseTsoFlags :: Word32 -> [TsoFlags]
+parseTsoFlags _ = []
+
data StackFields = StackFields {
stack_size :: Word32,
stack_dirty :: Word8,
=====================================
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,21 +37,21 @@ 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']),
+ [extra_files(['create_tso.c','create_tso.h','TestUtils.hs']),
ignore_stdout,
ignore_stderr,
when(have_profiling(), extra_ways(['prof'])),
=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
=====================================
@@ -7,6 +7,8 @@ import Control.Concurrent
import GHC.Exts.Heap
import GHC.Exts
+import TestUtils
+
foreign import ccall safe "list_threads_and_misc_roots_c.h listThreadsAndMiscRoots"
listThreadsAndMiscRoots_c :: IO ()
@@ -44,19 +46,6 @@ main = do
return ()
-createClosure :: Ptr () -> IO (GenClosure Box)
-createClosure tsoPtr = do
- let addr = unpackAddr# tsoPtr
- getClosureData ((unsafeCoerce# addr) :: LiftedClosure)
-
-unpackAddr# :: Ptr () -> Addr#
-unpackAddr# (Ptr addr) = addr
-
-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/prof_info.hs
=====================================
@@ -10,6 +10,8 @@ import Data.Functor
import GHC.Word
import Data.List (find)
+import TestUtils
+
#include "ghcconfig.h"
#include "rts/Constants.h"
@@ -35,25 +37,17 @@ main = do
Nothing -> error $ "No CostCentre found in TSO: " ++ show tso
Just _ -> case findMyCostCentre (linkedCostCentres costCentre) of
Just myCostCentre -> do
- assertEqual (cc_ccID myCostCentre) 1
assertEqual (cc_label myCostCentre) "MyCostCentre"
assertEqual (cc_module myCostCentre) "Main"
- assertEqual (cc_srcloc myCostCentre) (Just "prof_info.hs:21:39-50")
+ 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
- assertEqual (cc_link myCostCentre) Nothing
Nothing -> error "MyCostCentre not found!"
-unpackAddr# :: Ptr () -> Addr#
-unpackAddr# (Ptr addr) = addr
-
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
-
-assertEqual :: (Eq a, Show a) => a -> a -> IO ()
-assertEqual x y = if x == y then return () else error $ "assertEqual: " ++ show x ++ " /= " ++ show y
=====================================
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,8 +7,7 @@ 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 (Ptr ())
@@ -55,16 +54,7 @@ main = do
createTSOClosure :: IO (GenClosure Box)
createTSOClosure = do
ptr <- c_create_tso
- let addr = unpackAddr# ptr
- getClosureData ((unsafeCoerce# addr) :: LiftedClosure)
-
-unpackAddr# :: Ptr () -> Addr#
-unpackAddr# (Ptr addr) = addr
-
-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
=====================================
@@ -455,6 +455,9 @@ 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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5291dd1525692f5a9cc0613a6a85c94143c5639d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5291dd1525692f5a9cc0613a6a85c94143c5639d
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/20200812/99589698/attachment-0001.html>
More information about the ghc-commits
mailing list