Put CFG weights into their own module (#17957)

It avoids having to query DynFlags to get them

5 files changed, 119 insertions, 88 deletions

diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs
index dd46393649..e054e488b6 100644
--- a/compiler/GHC/CmmToAsm/CFG.hs
+++ b/compiler/GHC/CmmToAsm/CFG.hs
@@ -62,6 +62,7 @@ import GHC.Data.Maybe
 
 import GHC.Types.Unique
 import qualified GHC.CmmToAsm.CFG.Dominators as Dom
+import GHC.CmmToAsm.CFG.Weight
 import Data.IntMap.Strict (IntMap)
 import Data.IntSet (IntSet)
 
@@ -79,7 +80,6 @@ import GHC.Utils.Panic
 --import GHC.Data.OrdList
 --import GHC.Cmm.DebugBlock.Trace
 import GHC.Cmm.Ppr () -- For Outputable instances
-import qualified GHC.Driver.Session as D
 
 import Data.List (sort, nub, partition)
 import Data.STRef.Strict
@@ -329,12 +329,11 @@ shortcutWeightMap cuts cfg =
 --             \                  \
 --              -> C    =>         -> C
 --
-addImmediateSuccessor :: D.DynFlags -> BlockId -> BlockId -> CFG -> CFG
-addImmediateSuccessor dflags node follower cfg
-    = updateEdges . addWeightEdge node follower uncondWeight $ cfg
+addImmediateSuccessor :: Weights -> BlockId -> BlockId -> CFG -> CFG
+addImmediateSuccessor weights node follower cfg
+    = updateEdges . addWeightEdge node follower weight $ cfg
     where
-        uncondWeight = fromIntegral . D.uncondWeight .
-                       D.cfgWeightInfo $ dflags
+        weight = fromIntegral (uncondWeight weights)
         targets = getSuccessorEdges cfg node
         successors = map fst targets :: [BlockId]
         updateEdges = addNewSuccs . remOldSuccs
@@ -509,13 +508,12 @@ mapWeights f cfg =
 -- these cases.
 -- We assign the old edge info to the edge A -> B and assign B -> C the
 -- weight of an unconditional jump.
-addNodesBetween :: D.DynFlags -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG
-addNodesBetween dflags m updates =
+addNodesBetween :: Weights -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG
+addNodesBetween weights m updates =
   foldl'  updateWeight m .
           weightUpdates $ updates
     where
-      weight = fromIntegral . D.uncondWeight .
-                D.cfgWeightInfo $ dflags
+      weight = fromIntegral (uncondWeight weights)
       -- We might add two blocks for different jumps along a single
       -- edge. So we end up with edges:   A -> B -> C   ,   A -> D -> C
       -- in this case after applying the first update the weight for A -> C
@@ -585,24 +583,24 @@ addNodesBetween dflags m updates =
 
 -}
 -- | Generate weights for a Cmm proc based on some simple heuristics.
-getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG
+getCfgProc :: Weights -> RawCmmDecl -> CFG
 getCfgProc _       (CmmData {}) = mapEmpty
 getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph
 
-getCfg :: D.CfgWeights -> CmmGraph -> CFG
+getCfg :: Weights -> CmmGraph -> CFG
 getCfg weights graph =
   foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks
   where
-    D.CFGWeights
-            { D.uncondWeight = uncondWeight
-            , D.condBranchWeight = condBranchWeight
-            , D.switchWeight = switchWeight
-            , D.callWeight = callWeight
-            , D.likelyCondWeight = likelyCondWeight
-            , D.unlikelyCondWeight = unlikelyCondWeight
+    Weights
+            { uncondWeight = uncondWeight
+            , condBranchWeight = condBranchWeight
+            , switchWeight = switchWeight
+            , callWeight = callWeight
+            , likelyCondWeight = likelyCondWeight
+            , unlikelyCondWeight = unlikelyCondWeight
             --  Last two are used in other places
-            --, D.infoTablePenalty = infoTablePenalty
-            --, D.backEdgeBonus = backEdgeBonus
+            --, infoTablePenalty = infoTablePenalty
+            --, backEdgeBonus = backEdgeBonus
             } = weights
     -- Explicitly add all nodes to the cfg to ensure they are part of the
     -- CFG.
@@ -631,7 +629,7 @@ getCfg weights graph =
             mkEdge target weight = ((bid,target), mkEdgeInfo weight)
             branchInfo =
               foldRegsUsed
-                (panic "foldRegsDynFlags")
+                (panic "GHC.CmmToAsm.CFG.getCfg: foldRegsUsed")
                 (\info r -> if r == SpLim || r == HpLim || r == BaseReg
                     then HeapStackCheck else info)
                 NoInfo cond
@@ -671,7 +669,7 @@ findBackEdges root cfg =
     typedEdges =
       classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)]
 
-optimizeCFG :: Bool -> D.CfgWeights -> RawCmmDecl -> CFG -> CFG
+optimizeCFG :: Bool -> Weights -> RawCmmDecl -> CFG -> CFG
 optimizeCFG _ _ (CmmData {}) cfg = cfg
 optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg =
   (if doStaticPred then staticPredCfg (g_entry graph) else id) $
@@ -682,7 +680,7 @@ optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg =
 -- performance.
 --
 -- Most importantly we penalize jumps across info tables.
-optHsPatterns :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG
+optHsPatterns :: Weights -> RawCmmDecl -> CFG -> CFG
 optHsPatterns _ (CmmData {}) cfg = cfg
 optHsPatterns weights (CmmProc info _lab _live graph) cfg =
     {-# SCC optHsPatterns #-}
@@ -704,7 +702,7 @@ optHsPatterns weights (CmmProc info _lab _live graph) cfg =
               --Keep irrelevant edges irrelevant
               | weight <= 0 = 0
               | otherwise
-              = weight + fromIntegral (D.backEdgeBonus weights)
+              = weight + fromIntegral (backEdgeBonus weights)
         in  foldl'  (\cfg edge -> updateEdgeWeight update edge cfg)
                     cfg backedges
 
@@ -716,7 +714,7 @@ optHsPatterns weights (CmmProc info _lab _live graph) cfg =
         fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
         fupdate _ to weight
           | mapMember to info
-          = weight - (fromIntegral $ D.infoTablePenalty weights)
+          = weight - (fromIntegral $ infoTablePenalty weights)
           | otherwise = weight
 
     -- | If a block has two successors, favour the one with fewer
diff --git a/compiler/GHC/CmmToAsm/CFG/Weight.hs b/compiler/GHC/CmmToAsm/CFG/Weight.hs
new file mode 100644
index 0000000000..482e857b5a
--- /dev/null
+++ b/compiler/GHC/CmmToAsm/CFG/Weight.hs
@@ -0,0 +1,78 @@
+module GHC.CmmToAsm.CFG.Weight
+   ( Weights (..)
+   , defaultWeights
+   , parseWeights
+   )
+where
+
+import GHC.Prelude
+import GHC.Utils.Panic
+
+-- | Edge weights to use when generating a CFG from CMM
+data Weights = Weights
+   { uncondWeight       :: Int
+   , condBranchWeight   :: Int
+   , switchWeight       :: Int
+   , callWeight         :: Int
+   , likelyCondWeight   :: Int
+   , unlikelyCondWeight :: Int
+   , infoTablePenalty   :: Int
+   , backEdgeBonus      :: Int
+   }
+
+-- | Default edge weights
+defaultWeights :: Weights
+defaultWeights = Weights
+   { uncondWeight       = 1000
+   , condBranchWeight   = 800
+   , switchWeight       = 1
+   , callWeight         = -10
+   , likelyCondWeight   = 900
+   , unlikelyCondWeight = 300
+   , infoTablePenalty   = 300
+   , backEdgeBonus      = 400
+   }
+
+parseWeights :: String -> Weights -> Weights
+parseWeights s oldWeights =
+        foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments
+    where
+        assignments = map assignment $ settings s
+        update "uncondWeight" n w =
+            w {uncondWeight = n}
+        update "condBranchWeight" n w =
+            w {condBranchWeight = n}
+        update "switchWeight" n w =
+            w {switchWeight = n}
+        update "callWeight" n w =
+            w {callWeight = n}
+        update "likelyCondWeight" n w =
+            w {likelyCondWeight = n}
+        update "unlikelyCondWeight" n w =
+            w {unlikelyCondWeight = n}
+        update "infoTablePenalty" n w =
+            w {infoTablePenalty = n}
+        update "backEdgeBonus" n w =
+            w {backEdgeBonus = n}
+        update other _ _
+            = panic $ other ++
+                      " is not a CFG weight parameter. " ++
+                      exampleString
+        settings s
+            | (s1,rest) <- break (== ',') s
+            , null rest
+            = [s1]
+            | (s1,rest) <- break (== ',') s
+            = s1 : settings (drop 1 rest)
+
+        assignment as
+            | (name, _:val) <- break (== '=') as
+            = (name,read val)
+            | otherwise
+            = panic $ "Invalid CFG weight parameters." ++ exampleString
+
+        exampleString = "Example parameters: uncondWeight=1000," ++
+            "condBranchWeight=800,switchWeight=0,callWeight=300" ++
+            ",likelyCondWeight=900,unlikelyCondWeight=300" ++
+            ",infoTablePenalty=300,backEdgeBonus=400"
+
diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs
index e6b5489b9e..88cff6a3eb 100644
--- a/compiler/GHC/CmmToAsm/Config.hs
+++ b/compiler/GHC/CmmToAsm/Config.hs
@@ -10,6 +10,7 @@ where
 import GHC.Prelude
 import GHC.Platform
 import GHC.Cmm.Type (Width(..))
+import GHC.CmmToAsm.CFG.Weight
 
 -- | Native code generator configuration
 data NCGConfig = NCGConfig
@@ -29,6 +30,7 @@ data NCGConfig = NCGConfig
    , ncgDumpRegAllocStages    :: !Bool
    , ncgDumpAsmStats          :: !Bool
    , ncgDumpAsmConflicts      :: !Bool
+   , ncgCfgWeights            :: !Weights         -- ^ CFG edge weights
    }
 
 -- | Return Word size
diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs
index 5a77e051cc..acde673c59 100644
--- a/compiler/GHC/CmmToAsm/Monad.hs
+++ b/compiler/GHC/CmmToAsm/Monad.hs
@@ -16,7 +16,6 @@ module GHC.CmmToAsm.Monad (
 
         NatM, -- instance Monad
         initNat,
-        initConfig,
         addImportNat,
         addNodeBetweenNat,
         addImmediateSuccessorNat,
@@ -34,7 +33,7 @@ module GHC.CmmToAsm.Monad (
         getNewRegPairNat,
         getPicBaseMaybeNat,
         getPicBaseNat,
-        getDynFlags,
+        getCfgWeights,
         getModLoc,
         getFileId,
         getDebugBlock,
@@ -64,7 +63,6 @@ import GHC.Data.FastString      ( FastString )
 import GHC.Types.Unique.FM
 import GHC.Types.Unique.Supply
 import GHC.Types.Unique         ( Unique )
-import GHC.Driver.Session
 import GHC.Unit.Module
 
 import Control.Monad    ( ap )
@@ -72,6 +70,7 @@ import Control.Monad    ( ap )
 import GHC.Utils.Outputable (SDoc, ppr)
 import GHC.Utils.Panic      (pprPanic)
 import GHC.CmmToAsm.CFG
+import GHC.CmmToAsm.CFG.Weight
 
 data NcgImpl statics instr jumpDest = NcgImpl {
     ncgConfig                 :: !NCGConfig,
@@ -107,7 +106,6 @@ data NatM_State
                 natm_delta       :: Int,
                 natm_imports     :: [(CLabel)],
                 natm_pic         :: Maybe Reg,
-                natm_dflags      :: DynFlags,
                 natm_config      :: NCGConfig,
                 natm_this_module :: Module,
                 natm_modloc      :: ModLocation,
@@ -127,17 +125,16 @@ newtype NatM result = NatM (NatM_State -> (result, NatM_State))
 unNat :: NatM a -> NatM_State -> (a, NatM_State)
 unNat (NatM a) = a
 
-mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
+mkNatM_State :: UniqSupply -> Int -> NCGConfig -> Module -> ModLocation ->
                 DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
-mkNatM_State us delta dflags this_mod
+mkNatM_State us delta config this_mod
         = \loc dwf dbg cfg ->
                 NatM_State
                         { natm_us = us
                         , natm_delta = delta
                         , natm_imports = []
                         , natm_pic = Nothing
-                        , natm_dflags = dflags
-                        , natm_config = initConfig dflags
+                        , natm_config = config
                         , natm_this_module = this_mod
                         , natm_modloc = loc
                         , natm_fileid = dwf
@@ -145,49 +142,6 @@ mkNatM_State us delta dflags this_mod
                         , natm_cfg = cfg
                         }
 
--- | Initialize the native code generator configuration from the DynFlags
-initConfig :: DynFlags -> NCGConfig
-initConfig dflags = NCGConfig
-   { ncgPlatform              = targetPlatform dflags
-   , ncgProcAlignment         = cmmProcAlignment dflags
-   , ncgDebugLevel            = debugLevel dflags
-   , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags
-   , ncgPIC                   = positionIndependent dflags
-   , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags
-   , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags
-   , ncgSplitSections         = gopt Opt_SplitSections dflags
-   , ncgRegsIterative         = gopt Opt_RegsIterative dflags
-   , ncgAsmLinting            = gopt Opt_DoAsmLinting dflags
-
-     -- With -O1 and greater, the cmmSink pass does constant-folding, so
-     -- we don't need to do it again in the native code generator.
-   , ncgDoConstantFolding     = optLevel dflags < 1
-
-   , ncgDumpRegAllocStages    = dopt Opt_D_dump_asm_regalloc_stages dflags
-   , ncgDumpAsmStats          = dopt Opt_D_dump_asm_stats dflags
-   , ncgDumpAsmConflicts      = dopt Opt_D_dump_asm_conflicts dflags
-   , ncgBmiVersion            = case platformArch (targetPlatform dflags) of
-                                 ArchX86_64 -> bmiVersion dflags
-                                 ArchX86    -> bmiVersion dflags
-                                 _          -> Nothing
-
-     -- We Assume  SSE1 and SSE2 operations are available on both
-     -- x86 and x86_64. Historically we didn't default to SSE2 and
-     -- SSE1 on x86, which results in defacto nondeterminism for how
-     -- rounding behaves in the associated x87 floating point instructions
-     -- because variations in the spill/fpu stack placement of arguments for
-     -- operations would change the precision and final result of what
-     -- would otherwise be the same expressions with respect to single or
-     -- double precision IEEE floating point computations.
-   , ncgSseVersion =
-      let v | sseVersion dflags < Just SSE2 = Just SSE2
-            | otherwise                     = sseVersion dflags
-      in case platformArch (targetPlatform dflags) of
-            ArchX86_64 -> v
-            ArchX86    -> v
-            _          -> Nothing
-   }
-
 initNat :: NatM_State -> NatM a -> (a, NatM_State)
 initNat init_st m
         = case unNat m init_st of { (r,st) -> (r,st) }
@@ -234,13 +188,12 @@ getUniqueNat = NatM $ \ st ->
     case takeUniqFromSupply $ natm_us st of
     (uniq, us') -> (uniq, st {natm_us = us'})
 
-instance HasDynFlags NatM where
-    getDynFlags = NatM $ \ st -> (natm_dflags st, st)
-
-
 getDeltaNat :: NatM Int
 getDeltaNat = NatM $ \ st -> (natm_delta st, st)
 
+-- | Get CFG edge weights
+getCfgWeights :: NatM Weights
+getCfgWeights = NatM $ \ st -> (ncgCfgWeights (natm_config st), st)
 
 setDeltaNat :: Int -> NatM ()
 setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
@@ -262,9 +215,8 @@ updateCfgNat f
 -- | Record that we added a block between `from` and `old`.
 addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
 addNodeBetweenNat from between to
- = do   df <- getDynFlags
-        let jmpWeight = fromIntegral . uncondWeight .
-                        cfgWeightInfo $ df
+ = do   weights <- getCfgWeights
+        let jmpWeight = fromIntegral (uncondWeight weights)
         updateCfgNat (updateCfg jmpWeight from between to)
   where
     -- When transforming A -> B to A -> A' -> B
@@ -284,8 +236,8 @@ addNodeBetweenNat from between to
 --   block -> X to `succ` -> X
 addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
 addImmediateSuccessorNat block succ = do
-   dflags <- getDynFlags
-   updateCfgNat (addImmediateSuccessor dflags block succ)
+   weights <- getCfgWeights
+   updateCfgNat (addImmediateSuccessor weights block succ)
 
 getBlockIdNat :: NatM BlockId
 getBlockIdNat
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index 51ee9ffce9..cbf3da9925 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -57,6 +57,7 @@ import GHC.CmmToAsm.Monad
    , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat
    , getPicBaseMaybeNat, getDebugBlock, getFileId
    , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform
+   , getCfgWeights
    )
 import GHC.CmmToAsm.CFG
 import GHC.CmmToAsm.Format
@@ -2106,10 +2107,10 @@ genCCall is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid
       --  bid -> lbl2
       --  bid -> lbl1 -> lbl2
       --  We also changes edges originating at bid to start at lbl2 instead.
-      dflags <- getDynFlags
+      weights <- getCfgWeights
       updateCfgNat (addWeightEdge bid lbl1 110 .
                     addWeightEdge lbl1 lbl2 110 .
-                    addImmediateSuccessor dflags bid lbl2)
+                    addImmediateSuccessor weights bid lbl2)
 
       -- The following instruction sequence corresponds to the pseudo-code
       --