Modularize GHC.Core.Opt.LiberateCasewip/cmm-dominators

Progress towards #17957

4 files changed, 51 insertions, 16 deletions

diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs
index 1598526ada..50c027cf8a 100644
--- a/compiler/GHC/Core/Opt/LiberateCase.hs
+++ b/compiler/GHC/Core/Opt/LiberateCase.hs
@@ -5,11 +5,13 @@
 -}
 
 
-module GHC.Core.Opt.LiberateCase ( liberateCase ) where
+module GHC.Core.Opt.LiberateCase
+  ( LibCaseOpts(..)
+  , liberateCase
+  ) where
 
 import GHC.Prelude
 
-import GHC.Driver.Session
 import GHC.Core
 import GHC.Core.Unfold
 import GHC.Builtin.Types ( unitDataConId )
@@ -101,19 +103,17 @@ and the level of @h@ is zero (NB not one).
 ************************************************************************
 -}
 
-liberateCase :: DynFlags -> CoreProgram -> CoreProgram
-liberateCase dflags binds = do_prog (initLiberateCaseEnv dflags) binds
+liberateCase :: LibCaseOpts -> CoreProgram -> CoreProgram
+liberateCase opts binds = do_prog (initLiberateCaseEnv opts) binds
   where
     do_prog _   [] = []
     do_prog env (bind:binds) = bind' : do_prog env' binds
                              where
                                (env', bind') = libCaseBind env bind
 
-
-initLiberateCaseEnv :: DynFlags -> LibCaseEnv
-initLiberateCaseEnv dflags = LibCaseEnv
-   { lc_threshold = liberateCaseThreshold dflags
-   , lc_uf_opts   = unfoldingOpts dflags
+initLiberateCaseEnv :: LibCaseOpts -> LibCaseEnv
+initLiberateCaseEnv opts = LibCaseEnv
+   { lc_opts      = opts
    , lc_lvl       = 0
    , lc_lvl_env   = emptyVarEnv
    , lc_rec_env   = emptyVarEnv
@@ -388,6 +388,22 @@ lookupLevel env id
 {-
 ************************************************************************
 *                                                                      *
+         Options
+*                                                                      *
+************************************************************************
+-}
+
+-- | Options for the liberate case pass.
+data LibCaseOpts = LibCaseOpts
+  -- | Bomb-out size for deciding if potential liberatees are too big.
+  { lco_threshold :: !(Maybe Int)
+  -- | Unfolding options
+  , lco_unfolding_opts :: !UnfoldingOpts
+  }
+
+{-
+************************************************************************
+*                                                                      *
          The environment
 *                                                                      *
 ************************************************************************
@@ -398,14 +414,16 @@ type LibCaseLevel = Int
 topLevel :: LibCaseLevel
 topLevel = 0
 
+lc_threshold :: LibCaseEnv -> Maybe Int
+lc_threshold = lco_threshold . lc_opts
+
+lc_uf_opts :: LibCaseEnv -> UnfoldingOpts
+lc_uf_opts = lco_unfolding_opts . lc_opts
+
 data LibCaseEnv
   = LibCaseEnv {
-        lc_threshold :: Maybe Int,
-                -- ^ Bomb-out size for deciding if potential liberatees are too
-                -- big.
-
-        lc_uf_opts :: UnfoldingOpts,
-                -- ^ Unfolding options
+        lc_opts :: !LibCaseOpts,
+                -- ^ liberate case options
 
         lc_lvl :: LibCaseLevel, -- ^ Current level
                 -- The level is incremented when (and only when) going
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 4011e265e2..b223f07077 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -13,6 +13,7 @@ import GHC.Prelude
 import GHC.Driver.Session
 import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
 import GHC.Driver.Env
+import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )
 import GHC.Platform.Ways  ( hasWay, Way(WayProf) )
 
 import GHC.Core
@@ -493,7 +494,7 @@ doCorePass pass guts = do
                                  updateBinds cseProgram
 
     CoreLiberateCase          -> {-# SCC "LiberateCase" #-}
-                                 updateBinds (liberateCase dflags)
+                                 updateBinds (liberateCase (initLiberateCaseOpts dflags))
 
     CoreDoFloatInwards        -> {-# SCC "FloatInwards" #-}
                                  updateBinds (floatInwards platform)
diff --git a/compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs b/compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs
new file mode 100644
index 0000000000..c06ca62e5c
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs
@@ -0,0 +1,15 @@
+module GHC.Driver.Config.Core.Opt.LiberateCase
+  ( initLiberateCaseOpts
+  ) where
+
+import GHC.Driver.Session
+
+import GHC.Core.Opt.LiberateCase ( LibCaseOpts(..) )
+
+-- | Initialize configuration for the liberate case Core optomization
+-- pass.
+initLiberateCaseOpts :: DynFlags -> LibCaseOpts
+initLiberateCaseOpts dflags = LibCaseOpts
+  { lco_threshold = liberateCaseThreshold dflags
+  , lco_unfolding_opts = unfoldingOpts dflags
+  }
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 392f0a4f84..ace7a0ddbd 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -389,6 +389,7 @@ Library
         GHC.Driver.Config.Cmm.Parser
         GHC.Driver.Config.CmmToAsm
         GHC.Driver.Config.CmmToLlvm
+        GHC.Driver.Config.Core.Opt.LiberateCase
         GHC.Driver.Config.Diagnostic
         GHC.Driver.Config.Finder
         GHC.Driver.Config.HsToCore