[Git][ghc/ghc][wip/ghc-debug] 2 commits: Decode CostCentreStacks, CostCentres and InfoTables (#18405)
Sven Tennie
gitlab at gitlab.haskell.org
Sun Jul 19 16:20:19 UTC 2020
Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC
Commits:
c46e93ab by Sven Tennie at 2020-07-19T11:33:34+02:00
Decode CostCentreStacks, CostCentres and InfoTables (#18405)
- - - - -
1518108a by Sven Tennie at 2020-07-19T18:20:03+02:00
Use cache and loop breakers for CostCentre, CostCentreStack and IndexTable decoding (#18405)
- - - - -
16 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.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/cbits/utils.c
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/tests/all.T
- + 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
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
=====================================
@@ -93,7 +93,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)
@@ -385,7 +385,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
=====================================
@@ -9,6 +9,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UnliftedFFITypes #-}
{-|
Module : GHC.Exts.Heap
@@ -38,6 +39,12 @@ module GHC.Exts.Heap (
, peekItbl
, pokeItbl
+ -- * Cost Centre (profiling) types
+ , StgTSOProfInfo(..)
+ , IndexTable(..)
+ , CostCentre(..)
+ , CostCentreStack(..)
+
-- * Closure inspection
, getBoxedClosureData
, allClosures
@@ -52,9 +59,12 @@ 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
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled
import GHC.Exts.Heap.InfoTable
#endif
import GHC.Exts.Heap.Utils
@@ -71,13 +81,17 @@ import Foreign
#include "ghcconfig.h"
+foreign import ccall "isEndTsoQueue" isEndTsoQueue_c :: Addr# -> Bool
+
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 ::
+
+-- TODO: Remove Show constraint
+ getClosureDataX :: Show b =>
(forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
-- ^ Helper function to get info table, memory and pointers of the
-- closure. The order of @[b]@ is significant and determined by
@@ -166,7 +180,9 @@ 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.
+
+-- TODO: Remove Show constraint
+getClosureX :: forall a b. Show b =>
(forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
-- ^ Helper function to get info table, memory and pointers of the
-- closure
@@ -324,26 +340,34 @@ getClosureX get_closure_raw x = do
allocaArray (length wds) (\ptr -> do
pokeArray ptr wds
-
- fields <- FFIClosures.peekTSOFields ptr
-
- pure $ TSOClosure
- { info = itbl
- , _link = (pts !! 0)
- , global_link = (pts !! 1)
- , tsoStack = (pts !! 2)
- , trec = (pts !! 3)
- , blocked_exceptions = (pts !! 4)
- , bq = (pts !! 5)
- , 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
- }
+-- TODO: remove prints
+ print $ "tso ptr : " ++ show ptr
+ print $ "tso pts : " ++ show pts
+ print $ "tso info table : " ++ show itbl
+-- TODO: Does this work? I.e. do we emit EndTSOQueues?
+ if isEndTsoQueue_c (unpackPtr ptr) then
+ pure $ EndTSOQueue { info = itbl }
+ else do
+ fields <- FFIClosures.peekTSOFields peekStgTSOProfInfo ptr
+
+ pure $ TSOClosure
+ { info = itbl
+ , _link = (pts !! 0)
+ , global_link = (pts !! 1)
+ , tsoStack = (pts !! 2)
+ , trec = (pts !! 3)
+ , blocked_exceptions = (pts !! 4)
+ , bq = (pts !! 5)
+ , 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
+ }
)
STACK -> do
unless (length pts == 1) $
@@ -372,3 +396,6 @@ getClosureX get_closure_raw x = do
-- | Like 'getClosureDataX', but taking a 'Box', so it is easier to work with.
getBoxedClosureData :: Box -> IO Closure
getBoxedClosureData (Box a) = getClosureData a
+
+unpackPtr :: Ptr a -> Addr#
+unpackPtr (Ptr addr) = addr
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -40,6 +40,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
@@ -281,7 +283,12 @@ data GenClosure b
, tso_dirty:: Word32 -- ^ non-zero => dirty
, alloc_limit :: Int64
, tot_stack_size :: Word32
+ , prof :: Maybe StgTSOProfInfo
}
+-- | Marker for the end of TSO queues
+-- Technically it has the same structure as an StgTSO, but most data isn't initialized.
+ | EndTSOQueue
+ { info :: !StgInfoTable }
-- Representation of StgStack: The 'tsoStack' of a 'TSOClosure'.
| StackClosure
{ info :: !StgInfoTable
=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc
=====================================
@@ -5,6 +5,7 @@ module GHC.Exts.Heap.FFIClosures where
import Prelude
import Foreign
+import GHC.Exts.Heap.ProfInfo.Types
-- TODO use sum type for what_next, why_blocked, flags?
@@ -18,13 +19,15 @@ data TSOFields = TSOFields {
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,6 +36,7 @@ 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',
@@ -42,7 +46,8 @@ peekTSOFields ptr = do
tso_saved_errno = saved_errno',
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'
}
data StackFields = StackFields {
=====================================
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,180 @@
+{-# LANGUAGE CPP, DeriveGeneric #-}
+module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled(
+ peekStgTSOProfInfo
+) where
+
+-- Manually defining PROFILING gives the #peek and #poke macros an accurate
+-- representation of the C structures when hsc2hs runs. This is valid because
+-- a non-profiling build would use
+-- GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled.
+#define PROFILING
+
+#include "Rts.h"
+#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
+
+-- TODO: Use IntSet for better performance?
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Control.Monad.Trans.State
+import Control.Monad.IO.Class
+
+import GHC.Exts.Heap.Ptr.Utils
+
+-- TODO: Remove cache? Looks like it's not needed anymore due to loop breakers
+data Cache = Cache {
+ ccCache :: IntMap CostCentre,
+ ccsCache :: IntMap CostCentreStack,
+ indexTableCache :: IntMap IndexTable
+}
+type DecoderMonad a = StateT Cache IO a
+
+peekStgTSOProfInfo :: Ptr a -> IO (Maybe StgTSOProfInfo)
+#if __GLASGOW_HASKELL__ < 811
+peekStgTSOProfInfo _ = return Nothing
+#else
+peekStgTSOProfInfo tsoPtr = do
+-- TODO: Use getCurrentCCS# ? Or GHC.Stack.CCS.getCurrentCCS ?
+ print $ "peekStgTSOProfInfo - tsoPtr : " ++ show tsoPtr
+ cccs_ptr <- peekByteOff tsoPtr cccsOffset
+ cccs' <- evalStateT (peekCostCentreStack Set.empty cccs_ptr) $ Cache IntMap.empty IntMap.empty IntMap.empty
+
+ return $ Just StgTSOProfInfo {
+ cccs = cccs'
+ }
+
+cccsOffset :: Int
+cccsOffset = (#const OFFSET_StgTSO_cccs) + (#size StgHeader)
+
+peekCostCentreStack :: Set (Ptr a) -> Ptr a -> DecoderMonad (Maybe CostCentreStack)
+peekCostCentreStack _ ptr | ptr == nullPtr = return Nothing
+peekCostCentreStack loopBreakers ptr | Set.member ptr loopBreakers = return Nothing
+peekCostCentreStack loopBreakers ptr = do
+ cache <- get
+ let ptrAsInt = ptrToInt ptr
+ if IntMap.member ptrAsInt (ccsCache cache) then do
+ liftIO $ print $ "CCS Cache hit : " ++ show ptr
+ -- TODO: There's a IntMap function that returns a Maybe
+ return $ Just $ (ccsCache cache) IntMap.! ptrAsInt
+ else do
+ liftIO $ print $ "peekCostCentreStack - ptr : " ++ show ptr
+ 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
+ -- TODO: Extract loopBreakers' to remove duplication
+ ccs_prevStack' <- peekCostCentreStack (Set.insert ptr loopBreakers) ccs_prevStack_ptr
+ -- TODO: Decide about index tables
+ ccs_indexTable_ptr <- liftIO $ (#peek struct CostCentreStack_, indexTable) ptr
+ ccs_indexTable' <- peekIndexTable (Set.insert ptr loopBreakers) ccs_indexTable_ptr
+ ccs_root_ptr <- liftIO $ (#peek struct CostCentreStack_, root) ptr
+ ccs_root' <- peekCostCentreStack (Set.insert ptr 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
+
+ let result = 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'
+ }
+
+ let updatedCCSCache = IntMap.insert ptrAsInt result (ccsCache cache)
+ put $ cache { ccsCache = updatedCCSCache }
+
+ return $ Just result
+
+peekCostCentre :: Ptr a -> DecoderMonad CostCentre
+peekCostCentre ptr = do
+ cache <- get
+ let ptrAsInt = ptrToInt ptr
+ if IntMap.member ptrAsInt (ccCache cache) then do
+ liftIO $ print $ "CC Cache hit : " ++ show ptr
+ return $ (ccCache cache) IntMap.! ptrAsInt
+ else 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
+
+peekIndexTable :: Set (Ptr costCentreStack) -> Ptr a -> DecoderMonad (Maybe IndexTable)
+peekIndexTable _ ptr | ptr == nullPtr = return Nothing
+peekIndexTable loopBreakers ptr = do
+ cache <- get
+ let ptrAsInt = ptrToInt ptr
+ if IntMap.member ptrAsInt (indexTableCache cache) then do
+ liftIO $ print $ "IndexTable Cache hit : " ++ show ptr
+ return $ Just $ (indexTableCache cache) IntMap.! ptrAsInt
+ else 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
+
+ let result = IndexTable {
+ it_cc = it_cc',
+ it_ccs = it_ccs',
+ it_next = it_next',
+ it_back_edge = it_back_edge'
+ }
+
+ let updatedIndexTableCache = IntMap.insert ptrAsInt result (indexTableCache cache)
+ put $ cache { indexTableCache = updatedIndexTableCache }
+
+ return $ Just result
+#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)
+
+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)
+
+data IndexTable = IndexTable {
+ it_cc :: CostCentre,
+ it_ccs :: Maybe CostCentreStack,
+ it_next :: Maybe IndexTable,
+ it_back_edge :: Bool
+} deriving (Show, Generic)
=====================================
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/cbits/utils.c
=====================================
@@ -0,0 +1,8 @@
+#include <stdio.h>
+#include "Rts.h"
+
+bool isEndTsoQueue(StgTSO* tso){
+ errorBelch("tso: %p", tso);
+ errorBelch("END_TSO_QUEUE: %p", END_TSO_QUEUE);
+ return tso == END_TSO_QUEUE;
+}
=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -25,9 +25,12 @@ library
build-depends: base >= 4.9.0 && < 5.0
, ghc-prim > 0.2 && < 0.7
, rts == 1.0.*
+ , containers >= 0.6.2.1 && < 0.7
+ , transformers == 0.5.*
ghc-options: -Wall
cmm-sources: cbits/HeapPrim.cmm
+ c-sources: cbits/utils.c
default-extensions: NoImplicitPrelude
@@ -40,3 +43,6 @@ 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
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -49,3 +49,11 @@ test('list_threads_and_misc_roots',
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']),
+ ignore_stdout,
+ ignore_stderr,
+# only_ways(prof_ways)
+ ],
+ multi_compile_and_run, ['prof_info', [('create_tso.c','-optc=-g -opta=-g')], '-prof -debug -fprof-auto'])
=====================================
libraries/ghc-heap/tests/prof_info.hs
=====================================
@@ -0,0 +1,38 @@
+{-# LANGUAGE ForeignFunctionInterface, MagicHash, CPP, BangPatterns #-}
+
+import Foreign
+import Foreign.C.Types
+import GHC.Exts.Heap
+import GHC.Exts
+
+import GHC.Word
+
+#include "ghcconfig.h"
+#include "rts/Constants.h"
+
+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
+
+-- 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
+
+-- TODO: remove print, add assertion
+ print $ "tso : "++ show tso
+
+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#
=====================================
libraries/ghc-heap/tests/tso_and_stack_closures.hs
=====================================
@@ -28,8 +28,6 @@ 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
_linkClosure <- getBoxedClosureData _linkBox
=====================================
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,17 @@ 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
+#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"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6cc0baaafd69fb9f472d7d4116ad840cbdfe2efd...1518108a32231f34d2562be0d04805f7840e8298
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6cc0baaafd69fb9f472d7d4116ad840cbdfe2efd...1518108a32231f34d2562be0d04805f7840e8298
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/20200719/aa3d6971/attachment-0001.html>
More information about the ghc-commits
mailing list