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 "GCed" $ \(_, 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       , showTimeWithUnit timeTotal)
    , (labelTimeMutator     , showTimeWithUnit timeMutator)
    , (labelTimeGC          , showTimeWithUnit timeGC)
    , (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


------------------------------------------------------------------------------

showTimeWithUnit :: Integral a => a -> String
showTimeWithUnit t =
    showFFloat (Just 3) t'' unit
  where
    (t'', unit) =
      case timeToSecondsDbl t of
        t' | t' < 1e-6  -> (t' / 1e-9, "ns")
           | t' < 1e-3  -> (t' / 1e-6, "μs")
           | t' < 1     -> (t' / 1e-3, "ms")
           | otherwise  -> (t', "s")

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 interval.
      -- 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 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 }
          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 guaranteed 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