File: SummaryView.hs

package info (click to toggle)
threadscope 0.2.14.1-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm
  • size: 580 kB
  • sloc: haskell: 5,457; ansic: 10; makefile: 7
file content (943 lines) | stat: -rw-r--r-- 40,086 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
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