From d755699c9bf8daee0c32387f525cd30e8c97a301 Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Thu, 29 Feb 2024 01:07:04 -1000
Subject: [PATCH] imp:stats: also show RTS memory usage stats

---
 hledger-ui/package.yaml               |  2 +-
 hledger-web/package.yaml              |  2 +-
 hledger/Hledger/Cli/CliOptions.hs     |  2 +-
 hledger/Hledger/Cli/Commands/Stats.hs | 53 ++++++++++++++++++++++-----
 hledger/package.yaml                  |  2 +-
 5 files changed, 48 insertions(+), 13 deletions(-)

diff --git a/hledger-ui/package.yaml b/hledger-ui/package.yaml
index 1a1922dfc..31114aae2 100644
--- a/hledger-ui/package.yaml
+++ b/hledger-ui/package.yaml
@@ -118,4 +118,4 @@ executables:
     - hledger-ui
     when:
     - condition: flag(threaded)
-      ghc-options: -threaded
+      ghc-options: -threaded -with-rtsopts=-T
diff --git a/hledger-web/package.yaml b/hledger-web/package.yaml
index d539e9957..e20a07603 100644
--- a/hledger-web/package.yaml
+++ b/hledger-web/package.yaml
@@ -149,7 +149,7 @@ executables:
     - condition: flag(library-only)
       buildable: false
     - condition: flag(threaded)
-      ghc-options: -threaded
+      ghc-options: -threaded -with-rtsopts=-T
 
 tests:
   test:
diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs
index 9058fdbda..a401853ac 100644
--- a/hledger/Hledger/Cli/CliOptions.hs
+++ b/hledger/Hledger/Cli/CliOptions.hs
@@ -481,7 +481,7 @@ data CliOpts = CliOpts {
                                         -- 1. the COLUMNS env var, if set
                                         -- 2. the width reported by the terminal, if supported
                                         -- 3. the default (80)
-    ,progstarttime_   :: POSIXTime
+    ,progstarttime_   :: POSIXTime      -- system POSIX time at start
  } deriving (Show)
 
 instance Default CliOpts where def = defcliopts
diff --git a/hledger/Hledger/Cli/Commands/Stats.hs b/hledger/Hledger/Cli/Commands/Stats.hs
index 09e73672a..1b84c3a90 100644
--- a/hledger/Hledger/Cli/Commands/Stats.hs
+++ b/hledger/Hledger/Cli/Commands/Stats.hs
@@ -7,6 +7,7 @@ Print some statistics for the journal.
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Hledger.Cli.Commands.Stats (
   statsmode
@@ -15,22 +16,25 @@ module Hledger.Cli.Commands.Stats (
 where
 
 import Data.Default (def)
-import Data.List (nub, sortOn)
+import Data.List (intercalate, nub, sortOn)
 import Data.List.Extra (nubSort)
+import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import Data.HashSet (size, fromList)
 import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TB
 import Data.Time.Calendar (Day, addDays, diffDays)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import GHC.Stats
 import System.Console.CmdArgs.Explicit hiding (Group)
+import System.Mem (performMajorGC)
 import Text.Printf (printf)
-import qualified Data.Map as Map
+import Text.Tabular.AsciiWide
 
 import Hledger
 import Hledger.Cli.CliOptions
 import Hledger.Cli.Utils (writeOutputLazyText)
-import Text.Tabular.AsciiWide
-import Data.Time.Clock.POSIX (getPOSIXTime)
 
 
 statsmode = hledgerCommandMode
@@ -53,11 +57,41 @@ stats opts@CliOpts{reportspec_=rspec, progstarttime_} j = do
       (ls, txncounts) = unzip $ map showstats intervalspans
       numtxns = sum txncounts
       b = unlinesB ls
-  writeOutputLazyText opts $ TB.toLazyText b
+  writeOutputLazyText opts $ TL.init $ TB.toLazyText b
   t <- getPOSIXTime
   let dt = t - progstarttime_
-  printf "Run time (throughput)    : %.2fs (%.0f txns/s)\n" 
-    (realToFrac dt :: Float) (fromIntegral numtxns / realToFrac dt :: Float)
+  rtsStatsEnabled <- getRTSStatsEnabled
+  if rtsStatsEnabled
+  then do
+    -- do one last GC for most accurate memory stats; probably little effect, hopefully little wasted time
+    performMajorGC
+    RTSStats{..} <- getRTSStats
+    printf
+      (intercalate ", "
+        ["Runtime stats            : %.2f s elapsed"
+        ,"%.0f txns/s"
+        -- ,"%0.0f MB avg live"
+        ,"%0.0f MB max live"
+        ,"%0.0f MB peak allocation"
+        -- ,"(%0.0f MiB"
+        -- ,"%0.0f MiB)"
+        ] ++ "\n")
+      (realToFrac dt :: Float)
+      (fromIntegral numtxns / realToFrac dt :: Float)
+      -- (toMegabytes $ fromIntegral cumulative_live_bytes / fromIntegral major_gcs)
+      (toMegabytes max_live_bytes)
+      (toMegabytes max_mem_in_use_bytes)
+  else
+    printf
+      (intercalate ", "
+        ["Runtime stats            : %.2f s elapsed"
+        ,"%.0f txns/s"
+        ] ++ "\n(add +RTS -T -RTS for more)\n")
+      (realToFrac dt :: Float)
+      (fromIntegral numtxns / realToFrac dt :: Float)
+
+toMegabytes n = realToFrac n / 1000000 ::Float  -- SI preferred definition, 10^6
+-- toMebibytes n = realToFrac n / 1048576 ::Float  -- traditional computing definition, 2^20
 
 showLedgerStats :: Ledger -> Day -> DateSpan -> (TB.Builder, Int)
 showLedgerStats l today spn =
@@ -65,8 +99,9 @@ showLedgerStats l today spn =
     ,tnum)
   where
     showRow (label, val) = Group NoLine $ map (Header . textCell TopLeft)
-      [fitText (Just w1) (Just w1) False True label `T.append` ": ", T.pack val]
-    w1 = maximum $ map (T.length . fst) stts
+      [fitText (Just w) (Just w) False True label `T.append` ": ", T.pack val]
+    w = 25  -- keep synced with labels above
+    -- w = maximum $ map (T.length . fst) stts
     (stts, tnum) = ([
        ("Main file", path) -- ++ " (from " ++ source ++ ")")
       ,("Included files", unlines $ drop 1 $ journalFilePaths j)
diff --git a/hledger/package.yaml b/hledger/package.yaml
index bbdb7ce2c..68f54b452 100644
--- a/hledger/package.yaml
+++ b/hledger/package.yaml
@@ -192,7 +192,7 @@ executables:
     cpp-options: -DVERSION="1.32.99"
     when:
     - condition: flag(threaded)
-      ghc-options: -threaded
+      ghc-options: -threaded -with-rtsopts=-T
     dependencies:
     - hledger