From 6f9127b3a48638a1230935d94046084db567699e Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Fri, 22 Apr 2011 00:10:06 +0100 Subject: [PATCH] Split off a Settings type from DynFlags --- compiler/main/DynFlags.hs | 148 ++++++++++++++++++++++++++++---------------- compiler/main/GHC.hs | 3 +- compiler/main/Packages.lhs | 2 +- compiler/main/SysTools.lhs | 53 ++++++++-------- 4 files changed, 121 insertions(+), 85 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ed4f5ff..9b1b060 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -35,6 +35,13 @@ module DynFlags ( DPHBackend(..), dphPackageMaybe, wayNames, + Settings(..), + ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, + extraGccViaCFlags, systemPackageConfig, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, + pgm_sysman, pgm_windres, pgm_lo, pgm_lc, + + -- ** Manipulating DynFlags defaultDynFlags, -- DynFlags initDynFlags, -- DynFlags -> IO DynFlags @@ -439,10 +446,7 @@ data DynFlags = DynFlags { libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only cmdlineFrameworks :: [String], -- ditto - tmpDir :: String, -- no trailing '/' - ghcUsagePath :: FilePath, -- Filled in by SysTools - ghciUsagePath :: FilePath, -- ditto rtsOpts :: Maybe String, rtsOptsEnabled :: RtsOptsEnabled, @@ -460,20 +464,7 @@ data DynFlags = DynFlags { opt_lo :: [String], -- LLVM: llvm optimiser opt_lc :: [String], -- LLVM: llc static compiler - -- commands for particular phases - pgm_L :: String, - pgm_P :: (String,[Option]), - pgm_F :: String, - pgm_c :: (String,[Option]), - pgm_s :: (String,[Option]), - pgm_a :: (String,[Option]), - pgm_l :: (String,[Option]), - pgm_dll :: (String,[Option]), - pgm_T :: String, - pgm_sysman :: String, - pgm_windres :: String, - pgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser - pgm_lc :: (String,[Option]), -- LLVM: llc static compiler + settings :: Settings, -- For ghc -M depMakefile :: FilePath, @@ -485,10 +476,6 @@ data DynFlags = DynFlags { extraPkgConfs :: [FilePath], -- ^ The @-package-conf@ flags given on the command line, in the order -- they appeared. - topDir :: FilePath, -- filled in by SysTools - settings :: [(String, String)], -- filled in by SysTools - extraGccViaCFlags :: [String], -- filled in by SysTools - systemPackageConfig :: FilePath, -- filled in by SysTools packageFlags :: [PackageFlag], -- ^ The @-package@ and @-hide-package@ flags from the command-line @@ -521,6 +508,73 @@ data DynFlags = DynFlags { haddockOptions :: Maybe String } +data Settings = Settings { + sGhcUsagePath :: FilePath, -- Filled in by SysTools + sGhciUsagePath :: FilePath, -- ditto + sTopDir :: FilePath, + sTmpDir :: String, -- no trailing '/' + -- You shouldn't need to look things up in rawSettings directly. + -- They should have their own fields instead. + sRawSettings :: [(String, String)], + sExtraGccViaCFlags :: [String], + sSystemPackageConfig :: FilePath, + -- commands for particular phases + sPgm_L :: String, + sPgm_P :: (String,[Option]), + sPgm_F :: String, + sPgm_c :: (String,[Option]), + sPgm_s :: (String,[Option]), + sPgm_a :: (String,[Option]), + sPgm_l :: (String,[Option]), + sPgm_dll :: (String,[Option]), + sPgm_T :: String, + sPgm_sysman :: String, + sPgm_windres :: String, + sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser + sPgm_lc :: (String,[Option]) -- LLVM: llc static compiler + } + +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = sGhcUsagePath (settings dflags) +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = sGhciUsagePath (settings dflags) +topDir :: DynFlags -> FilePath +topDir dflags = sTopDir (settings dflags) +tmpDir :: DynFlags -> String +tmpDir dflags = sTmpDir (settings dflags) +rawSettings :: DynFlags -> [(String, String)] +rawSettings dflags = sRawSettings (settings dflags) +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags) +systemPackageConfig :: DynFlags -> FilePath +systemPackageConfig dflags = sSystemPackageConfig (settings dflags) +pgm_L :: DynFlags -> String +pgm_L dflags = sPgm_L (settings dflags) +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = sPgm_P (settings dflags) +pgm_F :: DynFlags -> String +pgm_F dflags = sPgm_F (settings dflags) +pgm_c :: DynFlags -> (String,[Option]) +pgm_c dflags = sPgm_c (settings dflags) +pgm_s :: DynFlags -> (String,[Option]) +pgm_s dflags = sPgm_s (settings dflags) +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = sPgm_a (settings dflags) +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = sPgm_l (settings dflags) +pgm_dll :: DynFlags -> (String,[Option]) +pgm_dll dflags = sPgm_dll (settings dflags) +pgm_T :: DynFlags -> String +pgm_T dflags = sPgm_T (settings dflags) +pgm_sysman :: DynFlags -> String +pgm_sysman dflags = sPgm_sysman (settings dflags) +pgm_windres :: DynFlags -> String +pgm_windres dflags = sPgm_windres (settings dflags) +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = sPgm_lo (settings dflags) +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = sPgm_lc (settings dflags) + wayNames :: DynFlags -> [WayName] wayNames = map wayName . ways @@ -694,7 +748,6 @@ defaultDynFlags = libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [], - tmpDir = cDEFAULT_TMPDIR, rtsOpts = Nothing, rtsOptsEnabled = RtsOptsSafeOnly, @@ -721,27 +774,8 @@ defaultDynFlags = buildTag = panic "defaultDynFlags: No buildTag", rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", splitInfo = Nothing, - -- initSysTools fills all these in - ghcUsagePath = panic "defaultDynFlags: No ghciUsagePath", - ghciUsagePath = panic "defaultDynFlags: No ghciUsagePath", - topDir = panic "defaultDynFlags: No topDir", + -- initSysTools fills this in: settings = panic "defaultDynFlags: No settings", - extraGccViaCFlags = panic "defaultDynFlags: No extraGccViaCFlags", - systemPackageConfig = panic "no systemPackageConfig: call GHC.setSessionDynFlags", - pgm_L = panic "defaultDynFlags: No pgm_L", - pgm_P = panic "defaultDynFlags: No pgm_P", - pgm_F = panic "defaultDynFlags: No pgm_F", - pgm_c = panic "defaultDynFlags: No pgm_c", - pgm_s = panic "defaultDynFlags: No pgm_s", - pgm_a = panic "defaultDynFlags: No pgm_a", - pgm_l = panic "defaultDynFlags: No pgm_l", - pgm_dll = panic "defaultDynFlags: No pgm_dll", - pgm_T = panic "defaultDynFlags: No pgm_T", - pgm_sysman = panic "defaultDynFlags: No pgm_sysman", - pgm_windres = panic "defaultDynFlags: No pgm_windres", - pgm_lo = panic "defaultDynFlags: No pgm_lo", - pgm_lc = panic "defaultDynFlags: No pgm_lc", - -- end of initSysTools values -- ghc -M values depMakefile = "Makefile", depIncludePkgDeps = False, @@ -915,7 +949,7 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f} -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. -setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)} +setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) addOptl f d = d{ opt_l = f : opt_l d} addOptP f d = d{ opt_P = f : opt_P d} @@ -1098,18 +1132,18 @@ dynamic_flags = [ ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. - , Flag "pgmlo" (hasArg (\f d -> d{ pgm_lo = (f,[])})) - , Flag "pgmlc" (hasArg (\f d -> d{ pgm_lc = (f,[])})) - , Flag "pgmL" (hasArg (\f d -> d{ pgm_L = f})) + , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , Flag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , Flag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) , Flag "pgmP" (hasArg setPgmP) - , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f})) - , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])})) + , Flag "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , Flag "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) - , Flag "pgms" (hasArg (\f d -> d{ pgm_s = (f,[])})) - , Flag "pgma" (hasArg (\f d -> d{ pgm_a = (f,[])})) - , Flag "pgml" (hasArg (\f d -> d{ pgm_l = (f,[])})) - , Flag "pgmdll" (hasArg (\f d -> d{ pgm_dll = (f,[])})) - , Flag "pgmwindres" (hasArg (\f d -> d{ pgm_windres = f})) + , Flag "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) + , Flag "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , Flag "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , Flag "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) -- need to appear before -optl/-opta to be parsed as LLVM flags. , Flag "optlo" (hasArg (\f d -> d{ opt_lo = f : opt_lo d})) @@ -1904,6 +1938,10 @@ unSetExtensionFlag f = upd (\dfs -> xopt_unset dfs f) -- (except for -fno-glasgow-exts, which is treated specially) -------------------------- +alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags +alterSettings f dflags = dflags { settings = f (settings dflags) } + +-------------------------- setDumpFlag' :: DynFlag -> DynP () setDumpFlag' dump_flag = do { setDynFlag dump_flag @@ -2118,7 +2156,7 @@ splitPathList s = filter notNull (splitUp s) -- tmpDir, where we store temporary files. setTmpDir :: FilePath -> DynFlags -> DynFlags -setTmpDir dir dflags = dflags{ tmpDir = normalise dir } +setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir }) -- we used to fix /cygdrive/c/.. on Windows, but this doesn't -- seem necessary now --SDM 7/2/2008 @@ -2233,7 +2271,7 @@ compilerInfo dflags -- Next come the settings, so anything else can be overridden -- in the settings file (as "lookup" uses the first match for the -- key) - : settings dflags + : rawSettings dflags ++ [("Project version", cProjectVersion), ("Booter version", cBooterVersion), ("Stage", cStage), diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index ca2e14c..2480e28 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -432,7 +432,8 @@ initGhcMonad mb_top_dir = do liftIO $ StaticFlags.initStaticOpts dflags0 <- liftIO $ initDynFlags defaultDynFlags - dflags <- liftIO $ initSysTools mb_top_dir dflags0 + mySettings <- liftIO $ initSysTools mb_top_dir + let dflags = dflags0 { settings = mySettings } env <- liftIO $ newHscEnv dflags setSession env diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 5e265e8..451f78d 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -36,7 +36,7 @@ where #include "HsVersions.h" import PackageConfig -import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..), DPHBackend(..) ) +import DynFlags import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 9bc26cf..8bbe227 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -147,15 +147,11 @@ stuff. \begin{code} initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) - - -> DynFlags - -> IO DynFlags -- Set all the mutable variables above, holding + -> IO Settings -- Set all the mutable variables above, holding -- (a) the system programs -- (b) the package-config file -- (c) the GHC usage message - - -initSysTools mbMinusB dflags0 +initSysTools mbMinusB = do { top_dir <- findTopDir mbMinusB -- see [Note topdir] -- NB: top_dir is assumed to be in standard Unix @@ -193,7 +189,6 @@ initSysTools mbMinusB dflags0 windres_path = installed_mingw_bin "windres" ; tmpdir <- getTemporaryDirectory - ; let dflags1 = setTmpDir tmpdir dflags0 -- On Windows, mingw is distributed with GHC, -- so we look in TopDir/../mingw/bin @@ -237,26 +232,27 @@ initSysTools mbMinusB dflags0 ; let lc_prog = "llc" lo_prog = "opt" - ; return dflags1{ - ghcUsagePath = ghc_usage_msg_path, - ghciUsagePath = ghci_usage_msg_path, - topDir = top_dir, - settings = mySettings, - extraGccViaCFlags = words myExtraGccViaCFlags, - systemPackageConfig = pkgconfig_path, - pgm_L = unlit_path, - pgm_P = cpp_path, - pgm_F = "", - pgm_c = (gcc_prog,[]), - pgm_s = (split_prog,split_args), - pgm_a = (as_prog,[]), - pgm_l = (ld_prog,[]), - pgm_dll = (mkdll_prog,mkdll_args), - pgm_T = touch_path, - pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", - pgm_windres = windres_path, - pgm_lo = (lo_prog,[]), - pgm_lc = (lc_prog,[]) + ; return $ Settings { + sTmpDir = normalise tmpdir, + sGhcUsagePath = ghc_usage_msg_path, + sGhciUsagePath = ghci_usage_msg_path, + sTopDir = top_dir, + sRawSettings = mySettings, + sExtraGccViaCFlags = words myExtraGccViaCFlags, + sSystemPackageConfig = pkgconfig_path, + sPgm_L = unlit_path, + sPgm_P = cpp_path, + sPgm_F = "", + sPgm_c = (gcc_prog,[]), + sPgm_s = (split_prog,split_args), + sPgm_a = (as_prog,[]), + sPgm_l = (ld_prog,[]), + sPgm_dll = (mkdll_prog,mkdll_args), + sPgm_T = touch_path, + sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", + sPgm_windres = windres_path, + sPgm_lo = (lo_prog,[]), + sPgm_lc = (lc_prog,[]) -- Hans: this isn't right in general, but you can -- elaborate it in the same way as the others } @@ -536,8 +532,9 @@ newTempName dflags extn -- return our temporary directory within tmp_dir, creating one if we -- don't have one yet getTempDir :: DynFlags -> IO FilePath -getTempDir dflags@(DynFlags{tmpDir=tmp_dir}) +getTempDir dflags = do let ref = dirsToClean dflags + tmp_dir = tmpDir dflags mapping <- readIORef ref case Map.lookup tmp_dir mapping of Nothing -> -- 1.7.10.4