threadscope-0.2.11: GUI/SummaryView.hs
module GUI.SummaryView (
SummaryView,
summaryViewNew,
summaryViewSetEvents,
summaryViewSetInterval,
) where
import GHC.RTS.Events
import GUI.Types
import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat
import Control.Exception (assert)
import Control.Monad
import Data.Array
import qualified Data.IntMap as IM
import Data.IORef
import Data.List as L
import Data.Maybe
import Data.Word (Word64)
import Numeric (showFFloat)
import Text.Printf
------------------------------------------------------------------------------
type Events = Array Int Event
data SummaryView = SummaryView {
-- we cache the stats for the whole interval
cacheEventsStats :: !(IORef (Maybe (Events, SummaryStats, Bool)))
-- widgets for time stuff
, labelTimeTotal :: Label
, labelTimeMutator :: Label
, labelTimeGC :: Label
, labelTimeProductivity :: Label
-- widgets for heap stuff
, labelHeapMaxSize
, labelHeapMaxResidency
, labelHeapAllocTotal
, labelHeapAllocRate
, labelHeapMaxSlop :: (Label, Label, Label, Label)
, tableHeap :: Widget
-- widgets for GC stuff
, labelGcCopied :: (Label, Label, Label, Label)
, labelGcParWorkBalance :: Label
, storeGcStats :: ListStore GcStatsEntry
, tableGc :: Widget
-- widgets for sparks stuff
, storeSparkStats :: ListStore (Cap, SparkCounts)
}
------------------------------------------------------------------------------
summaryViewNew :: Builder -> IO SummaryView
summaryViewNew builder = do
cacheEventsStats <- newIORef Nothing
let getWidget cast = builderGetObject builder cast
getLabel = getWidget castToLabel
getHeapLabels w1 w2 w3 w4 = liftM4 (,,,) (getLabel w1) (getLabel w2)
(getLabel w3) (getLabel w4)
labelTimeTotal <- getWidget castToLabel "labelTimeTotal"
labelTimeMutator <- getWidget castToLabel "labelTimeMutator"
labelTimeGC <- getWidget castToLabel "labelTimeGC"
labelTimeProductivity <- getWidget castToLabel "labelTimeProductivity"
labelHeapMaxSize <- getHeapLabels "labelHeapMaxSize" "labelHeapMaxSizeUnit"
"labelHeapMaxSizeBytes" "labelHeapMaxSizeUnit1"
labelHeapMaxResidency <- getHeapLabels "labelHeapMaxResidency" "labelHeapMaxResidencyUnit"
"labelHeapMaxResidencyBytes" "labelHeapMaxResidencyUnit1"
labelHeapAllocTotal <- getHeapLabels "labelHeapAllocTotal" "labelHeapAllocTotalUnit"
"labelHeapAllocTotalBytes" "labelHeapAllocTotalUnit1"
labelHeapAllocRate <- getHeapLabels "labelHeapAllocRate" "labelHeapAllocRateUnit"
"labelHeapAllocRateBytes" "labelHeapAllocRateUnit1"
labelHeapMaxSlop <- getHeapLabels "labelHeapMaxSlop" "labelHeapMaxSlopUnit"
"labelHeapMaxSlopBytes" "labelHeapMaxSlopUnit1"
tableHeap <- getWidget castToWidget "tableHeap"
labelGcCopied <- getHeapLabels "labelGcCopied" "labelGcCopiedUnit"
"labelGcCopiedBytes" "labelGcCopiedUnit1"
labelGcParWorkBalance <- getWidget castToLabel "labelGcParWorkBalance"
storeGcStats <- listStoreNew []
tableGc <- getWidget castToWidget "tableGC"
storeSparkStats <- listStoreNew []
let summaryView = SummaryView{..}
treeviewGcStats <- getWidget castToTreeView "treeviewGcStats"
Compat.treeViewSetModel treeviewGcStats (Just storeGcStats)
let addGcColumn = addColumn treeviewGcStats storeGcStats
addGcColumn "Generation" $ \(GcStatsEntry gen _ _ _ _ _) ->
[ cellText := if gen == -1 then "GC Total" else "Gen " ++ show gen ]
addGcColumn "Collections" $ \(GcStatsEntry _ colls _ _ _ _) ->
[ cellText := show colls ]
addGcColumn "Par collections" $ \(GcStatsEntry _ _ pcolls _ _ _) ->
[ cellText := show pcolls ]
addGcColumn "Elapsed time" $ \(GcStatsEntry _ _ _ time _ _) ->
[ cellText := (printf "%5.2fs" (timeToSecondsDbl time) :: String) ]
addGcColumn "Avg pause" $ \(GcStatsEntry _ _ _ _ avgpause _) ->
[ cellText := (printf "%3.4fs" avgpause :: String) ]
addGcColumn "Max pause" $ \(GcStatsEntry _ _ _ _ _ maxpause) ->
[ cellText := (printf "%3.4fs" maxpause :: String) ]
treeviewSparkStats <- getWidget castToTreeView "treeviewSparkStats"
Compat.treeViewSetModel treeviewSparkStats (Just storeSparkStats)
let addSparksColumn = addColumn treeviewSparkStats storeSparkStats
addSparksColumn "HEC" $ \(hec, _) ->
[ cellText := if hec == -1 then "Total" else "HEC " ++ show hec ]
addSparksColumn "Total" $ \(_, SparkCounts total _ _ _ _ _) ->
[ cellText := show total ]
addSparksColumn "Converted" $ \(_, SparkCounts _ conv _ _ _ _) ->
[ cellText := show conv ]
addSparksColumn "Overflowed" $ \(_, SparkCounts _ _ ovf _ _ _) ->
[ cellText := show ovf ]
addSparksColumn "Dud" $ \(_, SparkCounts _ _ _ dud _ _) ->
[ cellText := show dud ]
addSparksColumn "GC'd" $ \(_, SparkCounts _ _ _ _ gc _) ->
[ cellText := show gc ]
addSparksColumn "Fizzled" $ \(_, SparkCounts _ _ _ _ _ fiz) ->
[ cellText := show fiz ]
return summaryView
where
addColumn view store title mkAttrs = do
col <- treeViewColumnNew
cell <- cellRendererTextNew
treeViewColumnSetTitle col title
treeViewColumnPackStart col cell False
treeViewAppendColumn view col
cellLayoutSetAttributes col cell store mkAttrs
------------------------------------------------------------------------------
summaryViewSetEvents :: SummaryView -> Maybe (Array Int Event) -> IO ()
summaryViewSetEvents view@SummaryView{cacheEventsStats} Nothing = do
writeIORef cacheEventsStats Nothing
setSummaryStatsEmpty view
summaryViewSetEvents view@SummaryView{cacheEventsStats} (Just events) = do
let stats = summaryStats events Nothing
-- this is an almost certain indicator that there
-- are no heap events in the eventlog:
hasHeapEvents = heapMaxSize (summHeapStats stats) /= Just 0
writeIORef cacheEventsStats (Just (events, stats, hasHeapEvents))
setSummaryStats view stats hasHeapEvents
summaryViewSetInterval :: SummaryView -> Maybe Interval -> IO ()
summaryViewSetInterval view@SummaryView{cacheEventsStats} Nothing = do
cache <- readIORef cacheEventsStats
case cache of
Nothing -> return ()
Just (_, stats, hasHeap) -> setSummaryStats view stats hasHeap
summaryViewSetInterval view@SummaryView{cacheEventsStats} (Just interval) = do
cache <- readIORef cacheEventsStats
case cache of
Nothing -> return ()
Just (events, _, hasHeap) -> setSummaryStats view stats hasHeap
where stats = summaryStats events (Just interval)
------------------------------------------------------------------------------
setSummaryStats :: SummaryView -> SummaryStats -> Bool -> IO ()
setSummaryStats view SummaryStats{..} hasHeapEvents = do
setTimeStats view summTimeStats
if hasHeapEvents
then do setHeapStatsAvailable view True
setHeapStats view summHeapStats
setGcStats view summGcStats
else setHeapStatsAvailable view False
setSparkStats view summSparkStats
setTimeStats :: SummaryView -> TimeStats -> IO ()
setTimeStats SummaryView{..} TimeStats{..} =
mapM_ (\(label, text) -> set label [ labelText := text ])
[ (labelTimeTotal , showFFloat (Just 2) (timeToSecondsDbl timeTotal) "s")
, (labelTimeMutator , showFFloat (Just 2) (timeToSecondsDbl timeMutator) "s")
, (labelTimeGC , showFFloat (Just 2) (timeToSecondsDbl timeGC) "s")
, (labelTimeProductivity, showFFloat (Just 1) (timeProductivity * 100) "% of mutator vs total")
]
setHeapStats :: SummaryView -> HeapStats -> IO ()
setHeapStats SummaryView{..} HeapStats{..} = do
setHeapStatLabels labelHeapMaxSize heapMaxSize "" ""
setHeapStatLabels labelHeapMaxResidency heapMaxResidency "" ""
setHeapStatLabels labelHeapAllocTotal heapTotalAlloc "" ""
setHeapStatLabels labelHeapAllocRate heapAllocRate "/s" " per second (of mutator time)"
setHeapStatLabels labelHeapMaxSlop heapMaxSlop "" ""
setHeapStatLabels labelGcCopied heapCopiedDuringGc "" ""
where
setHeapStatLabels labels stat unitSuffix unitSuffixLong =
let texts = case stat of
Nothing -> ("N/A", "", "", "")
Just b -> ( formatBytesInUnit b u, formatUnit u ++ unitSuffix
, formatBytes b, "bytes" ++ unitSuffixLong)
where u = getByteUnit b
in setLabels labels texts
setLabels (short,shortunit,long,longunit) (short', shortunit', long', longunit') = do
mapM_ (\(label, text) -> set label [ labelText := text ])
[ (short, short'), (shortunit, shortunit')
, (long, long'), (longunit, longunit') ]
setGcStats :: SummaryView -> GcStats -> IO ()
setGcStats SummaryView{..} GcStats{..} = do
let balText = maybe "N/A"
(printf "%.2f%% (serial 0%%, perfect 100%%)")
gcParWorkBalance
set labelGcParWorkBalance [ labelText := balText ]
listStoreClear storeGcStats
mapM_ (listStoreAppend storeGcStats) (gcTotalStats:gcGenStats)
setSparkStats :: SummaryView -> SparkStats -> IO ()
setSparkStats SummaryView{..} SparkStats{..} = do
listStoreClear storeSparkStats
mapM_ (listStoreAppend storeSparkStats) ((-1,totalSparkStats):capSparkStats)
data ByteUnit = TiB | GiB | MiB | KiB | B deriving Show
byteUnitVal :: ByteUnit -> Word64
byteUnitVal TiB = 2^40
byteUnitVal GiB = 2^30
byteUnitVal MiB = 2^20
byteUnitVal KiB = 2^10
byteUnitVal B = 1
getByteUnit :: Word64 -> ByteUnit
getByteUnit b
| b >= 2^40 = TiB
| b >= 2^30 = GiB
| b >= 2^20 = MiB
| b >= 2^10 = KiB
| otherwise = B
formatBytesInUnit :: Word64 -> ByteUnit -> String
formatBytesInUnit n u =
formatFixed (fromIntegral n / fromIntegral (byteUnitVal u))
where
formatFixed x = showFFloat (Just 1) x ""
formatUnit :: ByteUnit -> String
formatUnit = show
formatBytes :: Word64 -> String
formatBytes b = ppWithCommas b
ppWithCommas :: Word64 -> String
ppWithCommas =
let spl [] = []
spl l = let (c3, cs) = L.splitAt 3 l
in c3 : spl cs
in L.reverse . L.intercalate "," . spl . L.reverse . show
setSummaryStatsEmpty :: SummaryView -> IO ()
setSummaryStatsEmpty SummaryView{..} = do
mapM_ (\label -> set label [ labelText := ""
, widgetTooltipText
:= (Nothing :: Maybe String) ]) $
[ labelTimeTotal, labelTimeMutator
, labelTimeGC, labelTimeProductivity ] ++
[ w
| (a,b,c,d) <- [ labelHeapMaxSize, labelHeapMaxResidency
, labelHeapAllocTotal, labelHeapAllocRate
, labelHeapMaxSlop, labelGcCopied ]
, w <- [ a,b,c,d] ]
listStoreClear storeGcStats
listStoreClear storeSparkStats
setHeapStatsAvailable :: SummaryView -> Bool -> IO ()
setHeapStatsAvailable SummaryView{..} available
| available = do
forM_ unavailableWidgets $ \widget ->
set widget [ widgetTooltipText := (Nothing :: Maybe String)
, widgetSensitive := True ]
| otherwise = do
forM_ allLabels $ \label -> set label [ labelText := "" ]
listStoreClear storeGcStats
forM_ unavailableLabels $ \label ->
set label [ labelText := "(unavailable)" ]
forM_ unavailableWidgets $ \widget ->
set widget [ widgetTooltipText := Just msgInfoUnavailable, widgetSensitive := False ]
where
allLabels =
[ labelTimeMutator, labelTimeGC
, labelTimeProductivity, labelGcParWorkBalance ] ++
[ w | (a,b,c,d) <- [ labelHeapMaxSize, labelHeapMaxResidency
, labelHeapAllocTotal, labelHeapAllocRate
, labelHeapMaxSlop, labelGcCopied ]
, w <- [ a,b,c,d] ]
unavailableLabels =
[ labelTimeMutator, labelTimeGC
, labelTimeProductivity, labelGcParWorkBalance
, case labelGcCopied of (w,_,_,_) -> w ] ++
[ c | (_,_,c,_) <- [ labelHeapMaxSize, labelHeapMaxResidency
, labelHeapAllocTotal, labelHeapAllocRate
, labelHeapMaxSlop ] ]
unavailableWidgets = [ toWidget labelTimeMutator, toWidget labelTimeGC
, toWidget labelTimeProductivity
, tableHeap, tableGc ]
msgInfoUnavailable = "This eventlog does not contain heap or GC information."
------------------------------------------------------------------------------
-- Calculating the stats we want to display
--
data SummaryStats = SummaryStats {
summTimeStats :: TimeStats,
summHeapStats :: HeapStats,
summGcStats :: GcStats,
summSparkStats :: SparkStats
}
data TimeStats = TimeStats {
timeTotal :: !Word64, -- we really should have a better type for elapsed time
timeGC :: !Word64,
timeMutator :: !Word64,
timeProductivity :: !Double
}
data HeapStats = HeapStats {
heapMaxSize :: Maybe Word64,
heapMaxResidency :: Maybe Word64,
heapMaxSlop :: Maybe Word64,
heapTotalAlloc :: Maybe Word64,
heapAllocRate :: Maybe Word64,
heapCopiedDuringGc :: Maybe Word64
}
data GcStats = GcStats {
gcNumThreads :: !Int,
gcParWorkBalance :: !(Maybe Double),
gcGenStats :: [GcStatsEntry],
gcTotalStats :: !GcStatsEntry
}
data GcStatsEntry = GcStatsEntry !Int !Int !Int !Word64 !Double !Double
data SparkStats = SparkStats {
capSparkStats :: [(Cap, SparkCounts)],
totalSparkStats :: !SparkCounts
}
data SparkCounts = SparkCounts !Word64 !Word64 !Word64 !Word64 !Word64 !Word64
-- | Take the events, and optionally some sub-range, and generate the summary
-- stats for that range.
--
-- We take a two-step approach:
-- * a single pass over the events, accumulating into an intermediate
-- 'StatsAccum' record,
-- * then look at that 'StatsAccum' record and construct the various final
-- stats that we want to present.
--
summaryStats :: Array Int Event -> Maybe Interval -> SummaryStats
summaryStats events minterval =
SummaryStats {
summHeapStats = hs,
summGcStats = gs,
summSparkStats = ss,
summTimeStats = ts
}
where
!statsAccum = accumStats events minterval
gs = gcStats statsAccum
ss = sparkStats statsAccum
ts = timeStats events minterval gs
hs = heapStats statsAccum ts
-- | Linearly accumulate the stats from the events array,
-- either the full thing or some sub-range.
accumStats :: Array Int Event -> Maybe Interval -> StatsAccum
accumStats events minterval =
foldl' accumEvent start [ events ! i | i <- range eventsRange ]
where
eventsRange = selectEventRange events minterval
-- If we're starting from time zero then we know many of the stats
-- also start at from, where as from other points it's just unknown
start | fst eventsRange == 0 = zeroStatsAccum
| otherwise = emptyStatsAccum
-- | Given the event array and a time interval, return the range of array
-- indicies containing that interval. The Nothing interval means to select
-- the whole array range.
--
selectEventRange :: Array Int Event -> Maybe Interval -> (Int, Int)
selectEventRange arr Nothing = bounds arr
selectEventRange arr (Just (start, end)) = (lbound, ubound)
where
!lbound = either snd id $ findArrayRange cmp arr start
!ubound = either fst id $ findArrayRange cmp arr end
cmp ts (Event ts' _ _) = compare ts ts'
findArrayRange :: (key -> val -> Ordering)
-> Array Int val -> key -> Either (Int,Int) Int
findArrayRange cmp arr key =
binarySearch a0 b0 key
where
(a0,b0) = bounds arr
binarySearch a b key
| a > b = Left (b,a)
| otherwise = case cmp key (arr ! mid) of
LT -> binarySearch a (mid-1) key
EQ -> Right mid
GT -> binarySearch (mid+1) b key
where mid = (a + b) `div` 2
------------------------------------------------------------------------------
-- Final step where we convert from StatsAccum to various presentation forms
timeStats :: Array Int Event -> Maybe Interval -> GcStats -> TimeStats
timeStats events minterval
GcStats { gcTotalStats = GcStatsEntry _ _ _ timeGC _ _ } =
TimeStats {..}
where
timeTotal = intervalEnd - intervalStart
timeMutator = timeTotal - timeGC
timeProductivity = timeToSecondsDbl timeMutator
/ timeToSecondsDbl timeTotal
(intervalStart, intervalEnd) =
case minterval of
Just (s,e) -> (s, e)
Nothing -> (0, evTime (events ! ub))
where
(_lb, ub) = bounds events
heapStats :: StatsAccum -> TimeStats -> HeapStats
heapStats StatsAccum{..} TimeStats{timeMutator} =
HeapStats {
heapMaxSize = dmaxMemory,
heapMaxResidency = dmaxResidency,
heapMaxSlop = dmaxSlop,
heapTotalAlloc = if totalAlloc == 0
then Nothing
else Just totalAlloc,
heapAllocRate = if timeMutator == 0 || totalAlloc == 0
then Nothing
else Just $ truncate (fromIntegral totalAlloc / timeToSecondsDbl timeMutator),
heapCopiedDuringGc = if dcopied == Just 0
then Nothing
else dcopied
}
where
totalAlloc = sum [ end - start
| (end,start) <- IM.elems dallocTable ]
gcStats :: StatsAccum -> GcStats
gcStats StatsAccum{..} =
GcStats {
gcNumThreads = nThreads,
gcParWorkBalance,
gcGenStats = [ mkGcStatsEntry gen (gcGather gen)
| gen <- gens ],
gcTotalStats = mkGcStatsEntry gcGenTot (gcGather gcGenTot)
}
where
nThreads = fromMaybe 1 dmaxParNThreads
gcParWorkBalance | nThreads <= 1
|| fromMaybe 0 dparMaxCopied <= 0 = Nothing
| otherwise =
Just $
100 * ((maybe 0 fromIntegral dparTotCopied
/ maybe 0 fromIntegral dparMaxCopied) - 1)
/ (fromIntegral nThreads - 1)
gens = [0..maxGeneration]
where
-- Does not work for generationless GCs, but works reasonably
-- for > 2 gens and perfectly for 2 gens.
maxGeneration = maximum $ 1
: [ maxGen
| RtsGC { gcGenStat } <- IM.elems dGCTable
, not (IM.null gcGenStat)
, let (maxGen, _) = IM.findMax gcGenStat ]
gcGather :: Gen -> GenStat
gcGather gen = gcSum gen $ map gcGenStat $ IM.elems dGCTable
-- TODO: Consider per-HEC display of GC stats and then use
-- the values summed over all generations at key gcGenTot at each cap.
gcSum :: Gen -> [IM.IntMap GenStat] -> GenStat
gcSum gen l =
GenStat (sumPr gcAll) (sumPr gcPar)
(gcElapsed mainGen) (gcMaxPause mainGen)
where
l_genGC = map (IM.findWithDefault emptyGenStat gen) l
sumPr proj = sum $ map proj l_genGC
_maxPr proj = L.maximum $ map proj l_genGC
_minPr proj = L.minimum $ filter (> 0) $ map proj l_genGC
-- This would be the most balanced way of aggregating gcElapsed,
-- if only the event times were accurate.
_avgPr proj = let vs = filter (> 0) $ map proj l_genGC
in sum vs `div` fromIntegral (length vs)
-- But since the times include scheduling noise,
-- we only use the times from the main cap for each GC
-- and so get readings almost identical to +RTS -s.
mainGen = IM.findWithDefault emptyGenStat gen mainStat
mainStat = gcGenStat (fromMaybe (defaultGC 0) dGCMain)
mkGcStatsEntry :: Gen -> GenStat -> GcStatsEntry
mkGcStatsEntry gen GenStat{..} =
GcStatsEntry gen gcAll gcPar gcElapsedS gcAvgPauseS gcMaxPauseS
where
gcElapsedS = gcElapsed
gcMaxPauseS = timeToSecondsDbl gcMaxPause
gcAvgPauseS
| gcAll == 0 = 0
| otherwise = timeToSeconds $
fromIntegral gcElapsed / fromIntegral gcAll
sparkStats :: StatsAccum -> SparkStats
sparkStats StatsAccum{dsparkTable} =
SparkStats {
capSparkStats =
[ (cap, mkSparkStats sparkCounts)
| (cap, sparkCounts) <- capsSparkCounts ],
totalSparkStats =
mkSparkStats $
foldl' (binopSparks (+)) zeroSparks
[ sparkCounts | (_cap, sparkCounts) <- capsSparkCounts ]
}
where
capsSparkCounts =
[ (cap, sparkCounts)
| (cap, (countsEnd, countsStart)) <- IM.assocs dsparkTable
, let sparkCounts = binopSparks (-) countsEnd countsStart ]
mkSparkStats RtsSpark {sparkCreated, sparkDud, sparkOverflowed,
sparkConverted, sparkFizzled, sparkGCd} =
-- in our final presentation we show the total created,
-- and the breakdown of that into outcomes:
SparkCounts (sparkCreated + sparkDud + sparkOverflowed)
sparkConverted sparkOverflowed
sparkDud sparkGCd sparkFizzled
------------------------------------------------------------------------------
timeToSecondsDbl :: Integral a => a -> Double
timeToSecondsDbl t = timeToSeconds $ fromIntegral t
timeToSeconds :: Double -> Double
timeToSeconds t = t / tIME_RESOLUTION
where tIME_RESOLUTION = 1000000
------------------------------------------------------------------------------
-- The single-pass stats accumulation stuff
--
-- | Data collected and computed gradually while events are scanned.
data StatsAccum = StatsAccum
{ dallocTable :: !(IM.IntMap (Word64, Word64)) -- indexed by caps
, dcopied :: !(Maybe Word64)
, dmaxResidency :: !(Maybe Word64)
, dmaxSlop :: !(Maybe Word64)
, dmaxMemory :: !(Maybe Word64)
--, dmaxFrag :: Maybe Word64 -- not important enough
, dGCTable :: !(IM.IntMap RtsGC) -- indexed by caps
-- Here we store the official +RTS -s timings of GCs,
-- that is times aggregated from the main caps of all GCs.
-- For now only gcElapsed and gcMaxPause are needed, so the rest
-- of the fields stays at default values.
, dGCMain :: !(Maybe RtsGC)
, dparMaxCopied :: !(Maybe Word64)
, dparTotCopied :: !(Maybe Word64)
, dmaxParNThreads :: !(Maybe Int)
--, dtaskTable -- of questionable usefulness, hard to get
, dsparkTable :: !(IM.IntMap (RtsSpark, RtsSpark)) -- indexed by caps
--, dInitExitT -- TODO. At least init time can be included in the total
-- time registered in the eventlog. Can we measure this
-- as the time between some initial events?
--, dGCTime -- Is better computed after all events are scanned,
-- e.g., because the same info can be used to calculate
-- per-cap GCTime and other per-cap stats.
--, dtotalTime -- TODO: can we measure this excluding INIT or EXIT times?
}
data RtsSpark = RtsSpark
{ sparkCreated, sparkDud, sparkOverflowed
, sparkConverted, sparkFizzled, sparkGCd :: !Word64
}
zeroSparks :: RtsSpark
zeroSparks = RtsSpark 0 0 0 0 0 0
binopSparks :: (Word64 -> Word64 -> Word64) -> RtsSpark -> RtsSpark -> RtsSpark
binopSparks op (RtsSpark crt1 dud1 ovf1 cnv1 fiz1 gcd1)
(RtsSpark crt2 dud2 ovf2 cnv2 fiz2 gcd2) =
RtsSpark (crt1 `op` crt2) (dud1 `op` dud2) (ovf1 `op` ovf2)
(cnv1 `op` cnv2) (fiz1 `op` fiz2) (gcd1 `op` gcd2)
type Gen = Int
type Cap = Int
data GcMode =
ModeInit | ModeStart | ModeSync Cap | ModeGHC Cap Gen | ModeEnd | ModeIdle
deriving Eq
data RtsGC = RtsGC
{ gcMode :: !GcMode
, gcStartTime :: !Timestamp
, gcGenStat :: !(IM.IntMap GenStat) -- indexed by generations
}
-- Index at the @gcGenStat@ map at which we store the sum of stats over all
-- generations, or the single set of stats for non-genenerational GC models.
gcGenTot :: Gen
gcGenTot = -1
data GenStat = GenStat
{ -- Sum over all seqential and pararell GC invocations.
gcAll :: !Int
, -- Only parallel GCs. For GC models without stop-the-world par, always 0.
gcPar :: !Int
, gcElapsed :: !Timestamp
, gcMaxPause :: !Timestamp
}
emptyStatsAccum :: StatsAccum
emptyStatsAccum = StatsAccum
{ dallocTable = IM.empty
, dcopied = Nothing
, dmaxResidency = Nothing
, dmaxSlop = Nothing
, dmaxMemory = Nothing
, dGCTable = IM.empty
, dGCMain = Nothing
, dparMaxCopied = Nothing
, dparTotCopied = Nothing
, dmaxParNThreads = Nothing
, dsparkTable = IM.empty
}
-- | At the beginning of a program run, we know for sure several of the
-- stats start at zero:
zeroStatsAccum :: StatsAccum
zeroStatsAccum = emptyStatsAccum {
dcopied = Just 0,
dmaxResidency = Just 0,
dmaxSlop = Just 0,
dmaxMemory = Just 0,
dallocTable = -- a hack: we assume no more than 999 caps
IM.fromDistinctAscList $ zip [0..999] $ repeat (0, 0)
-- FIXME: but also, we should have a way to init to 0 for all caps.
}
defaultGC :: Timestamp -> RtsGC
defaultGC time = RtsGC
{ gcMode = ModeInit
, gcStartTime = time
, gcGenStat = IM.empty
}
emptyGenStat :: GenStat
emptyGenStat = GenStat
{ gcAll = 0
, gcPar = 0
, gcElapsed = 0
, gcMaxPause = 0
}
-- Fail only when assertions are turned on.
errorAs :: String -> a -> a
errorAs msg a = assert (error msg) a
accumEvent :: StatsAccum -> Event -> StatsAccum
accumEvent !statsAccum ev =
let -- For events that contain a counter with a running sum.
-- Eventually we'll subtract the last found
-- event from the first. Intervals beginning at time 0
-- are a special case, because morally the first event should have
-- value 0, but it may be absent, so we start with @Just (0, 0)@.
alterCounter n Nothing = Just (n, n)
alterCounter n (Just (_previous, first)) = Just (n, first)
-- For events that contain discrete increments. We assume the event
-- is emitted close to the end of the process it measures,
-- so we ignore the first found event, because most of the process
-- could have happened before the start of the current inverval.
-- This is consistent with @alterCounter@. For interval beginning
-- at time 0, we start with @Just 0@.
alterIncrement _ Nothing = Just 0
alterIncrement n (Just k) = Just (k + n)
-- For events that contain sampled values, where a max is sought.
alterMax n Nothing = Just n
alterMax n (Just k) | n > k = Just n
alterMax _ jk = jk
-- Scan events, updating summary data.
scan !sd@StatsAccum{..} Event{evTime, evSpec, evCap} =
let cap = fromMaybe (error "Error: missing cap; use 'ghc-events validate' to verify the eventlog") evCap
capGC = IM.findWithDefault (defaultGC evTime) cap dGCTable
in case evSpec of
HeapAllocated{allocBytes} ->
sd { dallocTable =
IM.alter (alterCounter allocBytes) cap dallocTable }
HeapLive{liveBytes} ->
sd { dmaxResidency = alterMax liveBytes dmaxResidency}
HeapSize{sizeBytes} ->
sd { dmaxMemory = alterMax sizeBytes dmaxMemory}
StartGC ->
assert (gcMode capGC `elem` [ModeInit, ModeEnd, ModeIdle]) $
let newGC = capGC { gcMode = ModeStart
, gcStartTime = evTime
}
-- TODO: Index with generations, not caps?
in sd { dGCTable = IM.insert cap newGC dGCTable }
GlobalSyncGC ->
-- All caps must be stopped. Those that take part in the GC
-- are in ModeInit or ModeStart, those that do not
-- are in ModeInit, ModeEnd or ModeIdle.
assert (L.all (notModeGHCEtc . gcMode) (IM.elems dGCTable)) $
sd { dGCTable = IM.mapWithKey setSync dGCTable }
where
notModeGHCEtc ModeGHC{} = False
notModeGHCEtc ModeSync{} = False
notModeGHCEtc _ = True
someInit = L.any ((== ModeInit) . gcMode) (IM.elems dGCTable)
setSync capKey dGC@RtsGC{gcGenStat}
| someInit =
-- If even one cap could possibly have started GC before
-- the start of the selected interval, skip the GC on all caps.
-- We don't verify the overwritten modes in this case.
-- TODO: we could be smarter and defer the decision to EndGC,
-- when we can deduce if the suspect caps take part in GC
-- or not at all.
dGC { gcMode = ModeInit }
| otherwise =
let totGC = IM.findWithDefault emptyGenStat gcGenTot gcGenStat
in case gcMode dGC of
-- Cap takes part in the GC (not known if seq or par).
-- Here is the moment where all caps taking place in the GC
-- are identified and we can aggregate all their data
-- at once (currently we just increment a counter for each).
-- The EndGC events can come much later for some caps and at
-- that time other caps are already inside their new GC.
ModeStart ->
dGC { gcMode = ModeSync cap
, gcGenStat =
if capKey == cap
then IM.insert gcGenTot
totGC{ gcAll = gcAll totGC + 1 }
gcGenStat
else gcGenStat
}
-- Cap is not in the GC. Mark it as idle to complete
-- the identification of caps that take part
-- in the current GC. Without overwriting the mode,
-- the cap could be processed later on as if
-- it took part in the GC, giving wrong results.
ModeEnd -> dGC { gcMode = ModeIdle }
ModeIdle -> dGC
-- Impossible.
ModeInit -> errorAs "scanEvents: GlobalSyncGC ModeInit" dGC
ModeSync{} -> errorAs "scanEvents: GlobalSyncGC ModeSync" dGC
ModeGHC{} -> -- error "scanEvents: GlobalSyncGC ModeGHC"
dGC -- workaround for #46
GCStatsGHC{..} ->
-- All caps must be stopped. Those that take part in the GC
-- are in ModeInit or ModeSync, those that do not
-- are in ModeInit or ModeIdle.
assert (L.all (notModeStartEtc . gcMode) (IM.elems dGCTable)) $
sd { dcopied = alterIncrement copied dcopied -- sum over caps
, dmaxSlop = alterMax slop dmaxSlop -- max over all caps
, dGCTable = IM.mapWithKey setParSeq dGCTable
, dparMaxCopied = alterIncrement parMaxCopied dparMaxCopied
, dparTotCopied = alterIncrement parTotCopied dparTotCopied
, dmaxParNThreads = alterMax parNThreads dmaxParNThreads
}
where
notModeStartEtc ModeStart = False
notModeStartEtc ModeGHC{} = False
notModeStartEtc ModeEnd = False
notModeStartEtc _ = True
someInit = L.any ((== ModeInit) . gcMode) (IM.elems dGCTable)
setParSeq capKey dGC@RtsGC{gcGenStat}
| someInit =
-- Just starting the selected interval, so skip the GC.
dGC
| otherwise =
let genGC = IM.findWithDefault emptyGenStat gen gcGenStat
totGC = IM.findWithDefault emptyGenStat gcGenTot gcGenStat
in case gcMode dGC of
-- Cap takes part in seq GC.
ModeSync capSync | parNThreads == 1 ->
assert (cap == capSync) $
dGC { gcMode = ModeGHC cap gen
, gcGenStat =
-- Already inserted into gcGenTot in GlobalSyncGC,
-- so only inserting into gen.
if capKey == cap
then IM.insert gen
genGC{ gcAll = gcAll genGC + 1 }
gcGenStat
else gcGenStat
}
-- Cap takes part in par GC.
ModeSync capSync ->
assert (cap == capSync) $
assert (parNThreads > 1) $
dGC { gcMode = ModeGHC cap gen
, gcGenStat =
if capKey == cap
then IM.insert gen
genGC{ gcAll = gcAll genGC + 1
, gcPar = gcPar genGC + 1
}
(IM.insert gcGenTot
-- Already incremented gcAll in SyncGC.
totGC{ gcPar = gcPar totGC + 1 }
gcGenStat)
else gcGenStat
}
-- Cap not in the current GC, leave it alone.
ModeIdle -> dGC
-- Impossible.
ModeInit -> errorAs "scanEvents: GCStatsGHC ModeInit" dGC
ModeGHC{} -> -- error "scanEvents: GCStatsGHC ModeGHC"
dGC -- workaround for #46
-- The last two cases are copied from case @GlobalSyncGC@
-- to work around low-resolution timestamps (#35).
-- Normally, these states would be impossible here, because
-- @GlobalSyncGC@ would already transition away from these
-- states. But if @GlobalSyncGC@ comes too early, the states
-- can appear here. The computed stats are usually only
-- slightly different than if @GlobalSyncGC@ made the state
-- transitions, because the timestamps of @GCStatsGHC@
-- and @GlobalSyncGC@ are normally only slightly different.
--
-- Cap takes part in the GC (not known if seq or par).
-- Here is the moment where all caps taking place in the GC
-- are identified and we can aggregate all their data
-- at once (currently we just increment a counter for each).
-- The EndGC events can come much later for some caps and at
-- that time other caps are already inside their new GC.
ModeStart ->
dGC { gcMode = ModeSync cap
, gcGenStat =
if capKey == cap
then IM.insert gcGenTot
totGC{ gcAll = gcAll totGC + 1 }
gcGenStat
else gcGenStat
}
-- Cap is not in the GC. Mark it as idle to complete
-- the identification of caps that take part
-- in the current GC. Without overwritin the mode,
-- the cap could be processed later on as if
-- it took part in the GC, giving wrong results.
ModeEnd -> dGC { gcMode = ModeIdle }
EndGC ->
assert (gcMode capGC `notElem` [ModeEnd, ModeIdle]) $
let endedGC = capGC { gcMode = ModeEnd }
duration = evTime - gcStartTime capGC
timeGC gen gstat =
let genGC =
IM.findWithDefault emptyGenStat gen (gcGenStat gstat)
newGenGC =
genGC { gcElapsed = gcElapsed genGC + duration
, gcMaxPause = max (gcMaxPause genGC) duration
}
in gstat { gcGenStat = IM.insert gen newGenGC
(gcGenStat gstat) }
timeGenTot = timeGC gcGenTot endedGC
updateMainCap mainCap _ dgm | mainCap /= cap = dgm
updateMainCap _ currentGen dgm =
-- We are at the EndGC event of the main cap of current GC.
-- The timings from this cap are the only that +RTS -s uses.
-- We will record them in the dGCMain field to be able
-- to display a look-alike of +RTS -s.
timeGC currentGen dgm
in case gcMode capGC of
-- We don't know the exact timing of this GC started before
-- the selected interval, so we skip it and clear its mode.
ModeInit -> sd { dGCTable = IM.insert cap endedGC dGCTable }
-- There is no GlobalSyncGC nor GCStatsGHC for this GC.
-- Consequently, we can't determine the main cap,
-- so skip it and and clear its mode.
ModeStart -> sd { dGCTable = IM.insert cap endedGC dGCTable }
-- There is no GCStatsGHC for this GC. Gather partial data.
ModeSync mainCap ->
let dgm = fromMaybe (defaultGC evTime) dGCMain
mainGenTot = updateMainCap mainCap gcGenTot dgm
in sd { dGCTable = IM.insert cap timeGenTot dGCTable
, dGCMain = Just mainGenTot
}
-- All is known, so we update the times.
ModeGHC mainCap gen ->
let newTime = timeGC gen timeGenTot
dgm = fromMaybe (defaultGC evTime) dGCMain
mainGenTot = updateMainCap mainCap gcGenTot dgm
newMain = updateMainCap mainCap gen mainGenTot
in sd { dGCTable = IM.insert cap newTime dGCTable
, dGCMain = Just newMain
}
ModeEnd -> errorAs "scanEvents: EndGC ModeEnd" sd
ModeIdle -> errorAs "scanEvents: EndGC ModeIdle"
$ sd { dGCTable = IM.insert cap endedGC dGCTable }
SparkCounters crt dud ovf cnv fiz gcd _rem ->
-- We are guranteed the first spark counters event has all zeroes,
-- do we don't need to rig the counters for maximal interval.
let current = RtsSpark crt dud ovf cnv fiz gcd
in sd { dsparkTable =
IM.alter (alterCounter current) cap dsparkTable }
_ -> sd
in scan statsAccum ev