DynFlags refactoring VIII (#17957)

* Remove several uses of `sdocWithDynFlags`, especially in GHC.Llvm.*

* Add LlvmOpts datatype to store Llvm backend options

* Remove Outputable instances (for LlvmVar, LlvmLit, LlvmStatic and
  Llvm.MetaExpr) which require LlvmOpts.

* Rename ppMetaExpr into ppMetaAnnotExpr (pprMetaExpr is now used in place of `ppr :: MetaExpr -> SDoc`)

4 files changed, 42 insertions, 40 deletions

diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index 105254cfcc..38b9b8e582 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -21,9 +21,9 @@ module GHC.CmmToLlvm.Base (
         LlvmM,
         runLlvm, liftStream, withClearVars, varLookup, varInsert,
         markStackReg, checkStackReg,
-        funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
+        funLookup, funInsert, getLlvmVer, getDynFlags,
         dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
-        ghcInternalFunctions, getPlatform,
+        ghcInternalFunctions, getPlatform, getLlvmOpts,
 
         getMetaUniqueId,
         setUniqMeta, getUniqMeta,
@@ -114,10 +114,10 @@ widthToLlvmInt :: Width -> LlvmType
 widthToLlvmInt w = LMInt $ widthInBits w
 
 -- | GHC Call Convention for LLVM
-llvmGhcCC :: DynFlags -> LlvmCallConvention
-llvmGhcCC dflags
- | platformUnregisterised (targetPlatform dflags) = CC_Ccc
- | otherwise                                      = CC_Ghc
+llvmGhcCC :: Platform -> LlvmCallConvention
+llvmGhcCC platform
+ | platformUnregisterised platform = CC_Ccc
+ | otherwise                       = CC_Ghc
 
 -- | Llvm Function type for Cmm function
 llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
@@ -133,9 +133,8 @@ llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFuncti
 llvmFunSig' live lbl link
   = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
                       | otherwise   = (x, [])
-       dflags <- getDynFlags
        platform <- getPlatform
-       return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
+       return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs
                                  (map (toParams . getVarType) (llvmFunArgs platform live))
                                  (llvmFunAlign platform)
 
@@ -148,10 +147,10 @@ llvmInfAlign :: Platform -> LMAlign
 llvmInfAlign platform = Just (platformWordSizeInBytes platform)
 
 -- | Section to use for a function
-llvmFunSection :: DynFlags -> LMString -> LMSection
-llvmFunSection dflags lbl
-    | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])
-    | otherwise                     = Nothing
+llvmFunSection :: LlvmOpts -> LMString -> LMSection
+llvmFunSection opts lbl
+    | llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl])
+    | otherwise                  = Nothing
 
 -- | A Function's arguments
 llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
@@ -311,6 +310,7 @@ llvmVersionList = NE.toList . llvmVersionNE
 
 data LlvmEnv = LlvmEnv
   { envVersion :: LlvmVersion      -- ^ LLVM version
+  , envOpts    :: LlvmOpts         -- ^ LLVM backend options
   , envDynFlags :: DynFlags        -- ^ Dynamic flags
   , envOutput :: BufHandle         -- ^ Output buffer
   , envMask :: !Char               -- ^ Mask for creating unique values
@@ -342,8 +342,13 @@ instance Monad LlvmM where
 instance HasDynFlags LlvmM where
     getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
 
+-- | Get target platform
 getPlatform :: LlvmM Platform
-getPlatform = targetPlatform <$> getDynFlags
+getPlatform = llvmOptsPlatform <$> getLlvmOpts
+
+-- | Get LLVM options
+getLlvmOpts :: LlvmM LlvmOpts
+getLlvmOpts = LlvmM $ \env -> return (envOpts env, env)
 
 instance MonadUnique LlvmM where
     getUniqueSupplyM = do
@@ -370,6 +375,7 @@ runLlvm dflags ver out m = do
                       , envUsedVars = []
                       , envAliases = emptyUniqSet
                       , envVersion = ver
+                      , envOpts = initLlvmOpts dflags
                       , envDynFlags = dflags
                       , envOutput = out
                       , envMask = 'n'
@@ -426,14 +432,6 @@ getMetaUniqueId = LlvmM $ \env ->
 getLlvmVer :: LlvmM LlvmVersion
 getLlvmVer = getEnv envVersion
 
--- | Get the platform we are generating code for
-getDynFlag :: (DynFlags -> a) -> LlvmM a
-getDynFlag f = getEnv (f . envDynFlags)
-
--- | Get the platform we are generating code for
-getLlvmPlatform :: LlvmM Platform
-getLlvmPlatform = getDynFlag targetPlatform
-
 -- | Dumps the document if the corresponding flag has been set by the user
 dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
 dumpIfSetLlvm flag hdr fmt doc = do
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index e106a5e111..672fc84e43 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -178,7 +178,7 @@ barrier = do
 --   exceptions (where no code will be emitted instead).
 barrierUnless :: [Arch] -> LlvmM StmtData
 barrierUnless exs = do
-    platform <- getLlvmPlatform
+    platform <- getPlatform
     if platformArch platform `elem` exs
         then return (nilOL, [])
         else barrier
@@ -415,7 +415,7 @@ genCall target res args = do
                         ++ " 0 or 1, given " ++ show (length t) ++ "."
 
     -- extract Cmm call convention, and translate to LLVM call convention
-    platform <- lift $ getLlvmPlatform
+    platform <- lift $ getPlatform
     let lmconv = case target of
             ForeignTarget _ (ForeignConvention conv _ _ _) ->
               case conv of
@@ -993,6 +993,7 @@ genStore_slow addr val meta = do
     let stmts = stmts1 `appOL` stmts2
     dflags <- getDynFlags
     platform <- getPlatform
+    opts <- getLlvmOpts
     case getVarType vaddr of
         -- sometimes we need to cast an int to a pointer before storing
         LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do
@@ -1015,7 +1016,7 @@ genStore_slow addr val meta = do
                     (PprCmm.pprExpr platform addr <+> text (
                         "Size of Ptr: " ++ show (llvmPtrBits platform) ++
                         ", Size of var: " ++ show (llvmWidthInBits platform other) ++
-                        ", Var: " ++ showSDoc dflags (ppr vaddr)))
+                        ", Var: " ++ showSDoc dflags (ppVar opts vaddr)))
 
 
 -- | Unconditional branch
@@ -1041,7 +1042,8 @@ genCondBranch cond idT idF likely = do
             return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
         else do
             dflags <- getDynFlags
-            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
+            opts <- getLlvmOpts
+            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppVar opts vc) ++ ")"
 
 
 -- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.
@@ -1663,6 +1665,7 @@ genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
 genLoad_slow atomic e ty meta = do
   platform <- getPlatform
   dflags <- getDynFlags
+  opts <- getLlvmOpts
   runExprData $ do
     iptr <- exprToVarW e
     case getVarType iptr of
@@ -1678,7 +1681,7 @@ genLoad_slow atomic e ty meta = do
                         (PprCmm.pprExpr platform e <+> text (
                             "Size of Ptr: " ++ show (llvmPtrBits platform) ++
                             ", Size of var: " ++ show (llvmWidthInBits platform other) ++
-                            ", Var: " ++ showSDoc dflags (ppr iptr)))
+                            ", Var: " ++ showSDoc dflags (ppVar opts iptr)))
   where
     loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr
                   | otherwise = Load ptr
@@ -1873,7 +1876,7 @@ funEpilogue live = do
         loadUndef r = do
           let ty = (pLower . getVarType $ lmGlobalRegVar platform r)
           return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
-    platform <- getDynFlag targetPlatform
+    platform <- getPlatform
     let allRegs = activeStgRegs platform
     loads <- flip mapM allRegs $ \r -> case () of
       _ | (False, r) `elem` livePadded
diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs
index b32f619640..ac155179d1 100644
--- a/compiler/GHC/CmmToLlvm/Data.hs
+++ b/compiler/GHC/CmmToLlvm/Data.hs
@@ -17,7 +17,6 @@ import GHC.CmmToLlvm.Base
 import GHC.Cmm.BlockId
 import GHC.Cmm.CLabel
 import GHC.Cmm
-import GHC.Driver.Session
 import GHC.Platform
 
 import GHC.Data.FastString
@@ -71,7 +70,7 @@ genLlvmData (sec, CmmStaticsRaw lbl xs) = do
     label <- strCLabel_llvm lbl
     static <- mapM genData xs
     lmsec <- llvmSection sec
-    platform <- getLlvmPlatform
+    platform <- getPlatform
     let types   = map getStatType static
 
         strucTy = LMStruct types
@@ -113,9 +112,9 @@ llvmSectionType p t = case t of
 -- | Format a Cmm Section into a LLVM section name
 llvmSection :: Section -> LlvmM LMSection
 llvmSection (Section t suffix) = do
-  dflags <- getDynFlags
-  let splitSect = gopt Opt_SplitSections dflags
-      platform  = targetPlatform dflags
+  opts <- getLlvmOpts
+  let splitSect = llvmOptsSplitSections opts
+      platform  = llvmOptsPlatform opts
   if not splitSect
   then return Nothing
   else do
diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs
index 290234d48a..49374a9869 100644
--- a/compiler/GHC/CmmToLlvm/Ppr.hs
+++ b/compiler/GHC/CmmToLlvm/Ppr.hs
@@ -27,21 +27,22 @@ import GHC.Types.Unique
 --
 
 -- | Pretty print LLVM data code
-pprLlvmData :: LlvmData -> SDoc
-pprLlvmData (globals, types) =
+pprLlvmData :: LlvmOpts -> LlvmData -> SDoc
+pprLlvmData opts (globals, types) =
     let ppLlvmTys (LMAlias    a) = ppLlvmAlias a
         ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
         ppLlvmTys _other         = empty
 
         types'   = vcat $ map ppLlvmTys types
-        globals' = ppLlvmGlobals globals
+        globals' = ppLlvmGlobals opts globals
     in types' $+$ globals'
 
 
 -- | Pretty print LLVM code
 pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
-pprLlvmCmmDecl (CmmData _ lmdata)
-  = return (vcat $ map pprLlvmData lmdata, [])
+pprLlvmCmmDecl (CmmData _ lmdata) = do
+  opts <- getLlvmOpts
+  return (vcat $ map (pprLlvmData opts) lmdata, [])
 
 pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
   = do let lbl = case mb_info of
@@ -55,10 +56,11 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
 
        funDec <- llvmFunSig live lbl link
        dflags <- getDynFlags
+       opts <- getLlvmOpts
        platform <- getPlatform
-       let buildArg = fsLit . showSDoc dflags . ppPlainName
+       let buildArg = fsLit . showSDoc dflags . ppPlainName opts
            funArgs = map buildArg (llvmFunArgs platform live)
-           funSect = llvmFunSection dflags (decName funDec)
+           funSect = llvmFunSection opts (decName funDec)
 
        -- generate the info table
        prefix <- case mb_info of
@@ -92,7 +94,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
                             (Just $ LMBitc (LMStaticPointer defVar)
                                            i8Ptr)
 
-       return (ppLlvmGlobal alias $+$ ppLlvmFunction platform fun', [])
+       return (ppLlvmGlobal opts alias $+$ ppLlvmFunction opts fun', [])
 
 
 -- | The section we are putting info tables and their entry code into, should