From 44b0c6380711c669b74c65f29a0a6cf0311053da Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Thu, 30 Jun 2022 17:26:29 +0000
Subject: TEMP

---
 compiler/GHC/Core/EndPass.hs      |  2 +-
 compiler/GHC/Core/Lint.hs         |  2 +-
 compiler/GHC/Core/Opt/Counting.hs | 52 +++++++++++++++++++++++++--------------
 3 files changed, 36 insertions(+), 20 deletions(-)

diff --git a/compiler/GHC/Core/EndPass.hs b/compiler/GHC/Core/EndPass.hs
index da00de13a0..ce51fa1903 100644
--- a/compiler/GHC/Core/EndPass.hs
+++ b/compiler/GHC/Core/EndPass.hs
@@ -18,7 +18,7 @@ module GHC.Core.EndPass (
 
 import GHC.Prelude
 
-import GHC.Driver.Session
+--import GHC.Driver.Session
 
 import GHC.Core
 import GHC.Core.Lint
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 441f3a6570..630818b466 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -30,7 +30,7 @@ module GHC.Core.Lint (
 
 import GHC.Prelude
 
-import GHC.Driver.Session
+--import GHC.Driver.Session
 
 import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree )
 import GHC.Unit.Module.ModGuts
diff --git a/compiler/GHC/Core/Opt/Counting.hs b/compiler/GHC/Core/Opt/Counting.hs
index 83f12a00da..8d9c984d9f 100644
--- a/compiler/GHC/Core/Opt/Counting.hs
+++ b/compiler/GHC/Core/Opt/Counting.hs
@@ -4,10 +4,13 @@
 -}
 
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE LambdaCase #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
 module GHC.Core.Opt.Counting (
+    SimplCountOpts,
+
     SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
     pprSimplCount, plusSimplCount, zeroSimplCount,
     isZeroSimplCount, hasDetailedCounts, Tick(..),
@@ -17,8 +20,6 @@ module GHC.Core.Opt.Counting (
 
 import GHC.Prelude
 
-import GHC.Driver.Session
-
 import GHC.Types.Var
 import GHC.Types.Error
 
@@ -38,14 +39,24 @@ import GHC.Utils.Panic (throwGhcException, GhcException(..), panic)
 getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
 getVerboseSimplStats = getPprDebug          -- For now, anyway
 
-zeroSimplCount     :: DynFlags -> SimplCount
+zeroSimplCount     :: SimplCountOpts -> SimplCount
 isZeroSimplCount   :: SimplCount -> Bool
 hasDetailedCounts  :: SimplCount -> Bool
 pprSimplCount      :: SimplCount -> SDoc
-doSimplTick        :: DynFlags -> Tick -> SimplCount -> SimplCount
-doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount
+doSimplTick        :: SimplCountOpts
+                   -> Tick -> SimplCount -> SimplCount
+doFreeSimplTick    :: Tick -> SimplCount -> SimplCount
 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 
+data SimplCountOpts
+  = VerySimplCountOpts
+    {
+    }
+  | SimplCountOpts
+    { sc_historySize :: !Int
+      -- ^ Simplification history size
+    }
+
 data SimplCount
    = VerySimplCount !Int        -- Used when don't want detailed stats
 
@@ -67,14 +78,16 @@ simplCountN :: SimplCount -> Int
 simplCountN (VerySimplCount n)         = n
 simplCountN (SimplCount { ticks = n }) = n
 
-zeroSimplCount dflags
-                -- This is where we decide whether to do
-                -- the VerySimpl version or the full-stats version
-  | dopt Opt_D_dump_simpl_stats dflags
-  = SimplCount {ticks = 0, details = Map.empty,
+--  | dopt Opt_D_dump_simpl_stats dflags
+
+-- This is where we decide whether to do
+-- the VerySimpl version or the full-stats version
+zeroSimplCount = \case
+  SimplCountOpts {} ->
+    SimplCount {ticks = 0, details = Map.empty,
                 n_log = 0, log1 = [], log2 = []}
-  | otherwise
-  = VerySimplCount 0
+  VerySimplCountOpts {} ->
+    VerySimplCount 0
 
 isZeroSimplCount (VerySimplCount n)         = n==0
 isZeroSimplCount (SimplCount { ticks = n }) = n==0
@@ -86,12 +99,15 @@ doFreeSimplTick tick sc@SimplCount { details = dts }
   = sc { details = dts `addTick` tick }
 doFreeSimplTick _ sc = sc
 
-doSimplTick dflags tick
+doSimplTick cfg tick
     sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })
-  | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
-  | otherwise                = sc1 { n_log = nl+1, log1 = tick : l1 }
+  | SimplCountOpts { sc_historySize = sc } <- cfg
+  , nl >= sc
+  = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
+  | otherwise               
+  = sc1 { n_log = nl + 1, log1 = tick : l1 }
   where
-    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
+    sc1 = sc { ticks = tks + 1, details = dts `addTick` tick }
 
 doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)
 
@@ -136,8 +152,8 @@ pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
 newtype SimplCountM a = SimplCountM { unSimplCountM :: StateT SimplCount IO a }
   deriving (Functor, Applicative, Monad, MonadIO) via (StateT SimplCount IO)
 
-runSimplCountM :: DynFlags -> SimplCountM a -> IO (a, SimplCount)
-runSimplCountM dflags m = runStateT (unSimplCountM m) (zeroSimplCount dflags)
+runSimplCountM :: SimplCountOpts -> SimplCountM a -> IO (a, SimplCount)
+runSimplCountM cfg m = runStateT (unSimplCountM m) (zeroSimplCount cfg)
 
 tellSimplCountIO :: IO (a, SimplCount) -> SimplCountM a
 tellSimplCountIO m = SimplCountM $ do
-- 
cgit v1.2.1