Extract hard-coded LLVM opt flags into a file

To resolve ticket #11295, I think it makes sense to stop hard-coding
the pass sequences used by GHC when compiling with LLVM into the
compiler
itself.

This patchset introduces a companion to the existing `llvm-targets` file
called `llvm-passes`. The passes file is a simple association list that
holds the default LLVM `opt` pass sequence used by GHC. This allows end
users to easily save their favorite optimization flags when compiling
with LLVM.

The main benefit for ticket #11295 is that when adding a custom pass
sequence, it tends to be an extremely long string that would be
unsightly in the code.

This is essentially part 1 of 2 for ticket #11295.

Test Plan: ./validate

Reviewers: bgamari, angerman

Reviewed By: angerman

Subscribers: rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4695

4 files changed, 33 insertions, 20 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 0ed65d39fd..5ea83ce2c7 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1474,10 +1474,12 @@ runPhase (RealPhase LlvmOpt) input_fn dflags
   where
         -- we always (unless -optlo specified) run Opt since we rely on it to
         -- fix up some pretty big deficiencies in the code we generate
-        llvmOpts = case optLevel dflags of
-          0 -> "-mem2reg -globalopt"
-          1 -> "-O1 -globalopt"
-          _ -> "-O2"
+        optIdx = max 0 $ min 2 $ optLevel dflags  -- ensure we're in [0,2]
+        llvmOpts = case lookup optIdx $ llvmPasses dflags of
+                    Just passes -> passes
+                    Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "
+                                      ++ "is missing passes for level "
+                                      ++ show optIdx)
 
         -- don't specify anything if user has specified commands. We do this
         -- for opt but not llc since opt is very specifically for optimisation
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 0406d0e03a..a20aac5689 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -79,7 +79,7 @@ module DynFlags (
         unsafeFlags, unsafeFlagsForInfer,
 
         -- ** LLVM Targets
-        LlvmTarget(..), LlvmTargets,
+        LlvmTarget(..), LlvmTargets, LlvmPasses, LlvmConfig,
 
         -- ** System tool settings and locations
         Settings(..),
@@ -830,6 +830,7 @@ data DynFlags = DynFlags {
   hscTarget             :: HscTarget,
   settings              :: Settings,
   llvmTargets           :: LlvmTargets,
+  llvmPasses            :: LlvmPasses,
   verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]
   optLevel              :: Int,         -- ^ Optimisation level
   debugLevel            :: Int,         -- ^ How much debug information to produce
@@ -1146,6 +1147,8 @@ data LlvmTarget = LlvmTarget
   }
 
 type LlvmTargets = [(String, LlvmTarget)]
+type LlvmPasses = [(Int, String)]
+type LlvmConfig = (LlvmTargets, LlvmPasses)
 
 data Settings = Settings {
   sTargetPlatform        :: Platform,       -- Filled in by SysTools
@@ -1722,8 +1725,8 @@ initDynFlags dflags = do
 
 -- | The normal 'DynFlags'. Note that they are not suitable for use in this form
 -- and must be fully initialized by 'GHC.runGhc' first.
-defaultDynFlags :: Settings -> LlvmTargets -> DynFlags
-defaultDynFlags mySettings myLlvmTargets =
+defaultDynFlags :: Settings -> LlvmConfig -> DynFlags
+defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) =
 -- See Note [Updating flag description in the User's Guide]
      DynFlags {
         ghcMode                 = CompManager,
@@ -1818,6 +1821,7 @@ defaultDynFlags mySettings myLlvmTargets =
         splitInfo               = Nothing,
         settings                = mySettings,
         llvmTargets             = myLlvmTargets,
+        llvmPasses              = myLlvmPasses,
 
         -- ghc -M values
         depMakefile       = "Makefile",
@@ -5473,10 +5477,11 @@ makeDynFlagsConsistent dflags
 -- initialized.
 defaultGlobalDynFlags :: DynFlags
 defaultGlobalDynFlags =
-    (defaultDynFlags settings llvmTargets) { verbosity = 2 }
+    (defaultDynFlags settings (llvmTargets, llvmPasses)) { verbosity = 2 }
   where
     settings = panic "v_unsafeGlobalDynFlags: settings not initialised"
     llvmTargets = panic "v_unsafeGlobalDynFlags: llvmTargets not initialised"
+    llvmPasses = panic "v_unsafeGlobalDynFlags: llvmPasses not initialised"
 
 #if STAGE < 2
 GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags)
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 5f1eba5310..49e6c211eb 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -492,8 +492,8 @@ initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
 initGhcMonad mb_top_dir
   = do { env <- liftIO $
                 do { mySettings <- initSysTools mb_top_dir
-                   ; myLlvmTargets <- initLlvmTargets mb_top_dir
-                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmTargets)
+                   ; myLlvmConfig <- initLlvmConfig mb_top_dir
+                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
                    ; checkBrokenTablesNextToCode dflags
                    ; setUnsafeGlobalDynFlags dflags
                       -- c.f. DynFlags.parseDynamicFlagsFull, which
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 619e0b65e7..2e52ef97da 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -13,7 +13,7 @@
 module SysTools (
         -- * Initialisation
         initSysTools,
-        initLlvmTargets,
+        initLlvmConfig,
 
         -- * Interface to system tools
         module SysTools.Tasks,
@@ -110,16 +110,22 @@ stuff.
 ************************************************************************
 -}
 
-initLlvmTargets :: Maybe String
-                -> IO LlvmTargets
-initLlvmTargets mbMinusB
-  = do top_dir <- findTopDir mbMinusB
-       let llvmTargetsFile = top_dir </> "llvm-targets"
-       llvmTargetsStr <- readFile llvmTargetsFile
-       case maybeReadFuzzy llvmTargetsStr of
-         Just s -> return (fmap mkLlvmTarget <$> s)
-         Nothing -> pgmError ("Can't parse " ++ show llvmTargetsFile)
+initLlvmConfig :: Maybe String
+                -> IO LlvmConfig
+initLlvmConfig mbMinusB
+  = do
+      targets <- readAndParse "llvm-targets" mkLlvmTarget
+      passes <- readAndParse "llvm-passes" id
+      return (targets, passes)
   where
+    readAndParse name builder =
+      do top_dir <- findTopDir mbMinusB
+         let llvmConfigFile = top_dir </> name
+         llvmConfigStr <- readFile llvmConfigFile
+         case maybeReadFuzzy llvmConfigStr of
+           Just s -> return (fmap builder <$> s)
+           Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile)
+
     mkLlvmTarget :: (String, String, String) -> LlvmTarget
     mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs)