From d15b44d699ad12e74106baa43b99b94d80778e7f Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 12 Jul 2019 17:55:56 -0400 Subject: Pull out the settings file parsing code into it's own module. This has two benefits: 1. One less hunk of code dependent on DynFlags 2. Add a little bit of error granularity to distrinugish between missing data and bad data. This could someday be shared with ghc-pkg which aims to work even with a missing file. I also am about to to make --supported-extensions use this too. --- compiler/ghc.cabal.in | 1 + compiler/main/SysTools.hs | 222 ++------------------------------ compiler/main/SysTools/Settings.hs | 253 +++++++++++++++++++++++++++++++++++++ 3 files changed, 262 insertions(+), 214 deletions(-) create mode 100644 compiler/main/SysTools/Settings.hs diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 7e21924c34..f191370071 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -416,6 +416,7 @@ Library SysTools.Info SysTools.Process SysTools.Tasks + SysTools.Settings Elf TidyPgm Ctype diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index bfaa6562cc..fa339bbb87 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -44,22 +44,19 @@ import GHC.Settings import Module import Packages -import Config import Outputable import ErrUtils import GHC.Platform import DynFlags -import Fingerprint -import ToolSettings -import qualified Data.Map as Map +import Control.Monad.Trans.Except (runExceptT) import System.FilePath import System.IO -import System.Directory import SysTools.ExtraObj import SysTools.Info import SysTools.Tasks import SysTools.BaseDir +import SysTools.Settings {- Note [How GHC finds toolchain utilities] @@ -137,215 +134,12 @@ initSysTools :: String -- TopDir path -- (a) the system programs -- (b) the package-config file -- (c) the GHC usage message -initSysTools top_dir - = do -- see Note [topdir: How GHC finds its files] - -- NB: top_dir is assumed to be in standard Unix - -- format, '/' separated - mtool_dir <- findToolDir top_dir - -- see Note [tooldir: How GHC finds mingw on Windows] - - let installed :: FilePath -> FilePath - installed file = top_dir file - libexec :: FilePath -> FilePath - libexec file = top_dir "bin" file - settingsFile = installed "settings" - platformConstantsFile = installed "platformConstants" - - settingsStr <- readFile settingsFile - platformConstantsStr <- readFile platformConstantsFile - settingsList <- case maybeReadFuzzy settingsStr of - Just s -> - return s - Nothing -> - pgmError ("Can't parse " ++ show settingsFile) - let mySettings = Map.fromList settingsList - platformConstants <- case maybeReadFuzzy platformConstantsStr of - Just s -> - return s - Nothing -> - pgmError ("Can't parse " ++ - show platformConstantsFile) - -- See Note [Settings file] for a little more about this file. We're - -- just partially applying those functions and throwing 'Left's; they're - -- written in a very portable style to keep ghc-boot light. - let getSetting key = either pgmError pure $ - getFilePathSetting0 top_dir settingsFile mySettings key - getToolSetting :: String -> IO String - getToolSetting key = expandToolDir mtool_dir <$> getSetting key - getBooleanSetting :: String -> IO Bool - getBooleanSetting key = either pgmError pure $ - getBooleanSetting0 settingsFile mySettings key - targetPlatformString <- getSetting "target platform string" - tablesNextToCode <- getBooleanSetting "Tables next to code" - myExtraGccViaCFlags <- getSetting "GCC extra via C opts" - -- On Windows, mingw is distributed with GHC, - -- so we look in TopDir/../mingw/bin, - -- as well as TopDir/../../mingw/bin for hadrian. - -- It would perhaps be nice to be able to override this - -- with the settings file, but it would be a little fiddly - -- to make that possible, so for now you can't. - cc_prog <- getToolSetting "C compiler command" - cc_args_str <- getSetting "C compiler flags" - cxx_args_str <- getSetting "C++ compiler flags" - gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" - cpp_prog <- getToolSetting "Haskell CPP command" - cpp_args_str <- getSetting "Haskell CPP flags" - - platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings - - let unreg_cc_args = if platformUnregisterised platform - then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] - else [] - cpp_args = map Option (words cpp_args_str) - cc_args = words cc_args_str ++ unreg_cc_args - cxx_args = words cxx_args_str - ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" - ldSupportsBuildId <- getBooleanSetting "ld supports build-id" - ldSupportsFilelist <- getBooleanSetting "ld supports filelist" - ldIsGnuLd <- getBooleanSetting "ld is GNU ld" - - let pkgconfig_path = installed "package.conf.d" - ghc_usage_msg_path = installed "ghc-usage.txt" - ghci_usage_msg_path = installed "ghci-usage.txt" - - -- For all systems, unlit, split, mangle are GHC utilities - -- architecture-specific stuff is done when building Config.hs - unlit_path <- getToolSetting "unlit command" - - windres_path <- getToolSetting "windres command" - libtool_path <- getToolSetting "libtool command" - ar_path <- getToolSetting "ar command" - ranlib_path <- getToolSetting "ranlib command" - - tmpdir <- getTemporaryDirectory - - touch_path <- getToolSetting "touch command" - - mkdll_prog <- getToolSetting "dllwrap command" - let mkdll_args = [] - - -- cpp is derived from gcc on all platforms - -- HACK, see setPgmP below. We keep 'words' here to remember to fix - -- Config.hs one day. - - - -- Other things being equal, as and ld are simply gcc - cc_link_args_str <- getSetting "C compiler link flags" - let as_prog = cc_prog - as_args = map Option cc_args - ld_prog = cc_prog - ld_args = map Option (cc_args ++ words cc_link_args_str) - - llvmTarget <- getSetting "LLVM target" - - -- We just assume on command line - lc_prog <- getSetting "LLVM llc command" - lo_prog <- getSetting "LLVM opt command" - lcc_prog <- getSetting "LLVM clang command" - - let iserv_prog = libexec "ghc-iserv" - - integerLibrary <- getSetting "integer library" - integerLibraryType <- case integerLibrary of - "integer-gmp" -> pure IntegerGMP - "integer-simple" -> pure IntegerSimple - _ -> pgmError $ unwords - [ "Entry for" - , show "integer library" - , "must be one of" - , show "integer-gmp" - , "or" - , show "integer-simple" - ] - - ghcWithInterpreter <- getBooleanSetting "Use interpreter" - ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator" - ghcWithSMP <- getBooleanSetting "Support SMP" - ghcRTSWays <- getSetting "RTS ways" - leadingUnderscore <- getBooleanSetting "Leading underscore" - useLibFFI <- getBooleanSetting "Use LibFFI" - ghcThreaded <- getBooleanSetting "Use Threads" - ghcDebugged <- getBooleanSetting "Use Debugging" - ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" - - return $ Settings - { sGhcNameVersion = GhcNameVersion - { ghcNameVersion_programName = "ghc" - , ghcNameVersion_projectVersion = cProjectVersion - } - - , sFileSettings = FileSettings - { fileSettings_tmpDir = normalise tmpdir - , fileSettings_ghcUsagePath = ghc_usage_msg_path - , fileSettings_ghciUsagePath = ghci_usage_msg_path - , fileSettings_toolDir = mtool_dir - , fileSettings_topDir = top_dir - , fileSettings_systemPackageConfig = pkgconfig_path - } - - , sToolSettings = ToolSettings - { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind - , toolSettings_ldSupportsBuildId = ldSupportsBuildId - , toolSettings_ldSupportsFilelist = ldSupportsFilelist - , toolSettings_ldIsGnuLd = ldIsGnuLd - , toolSettings_ccSupportsNoPie = gccSupportsNoPie - - , toolSettings_pgm_L = unlit_path - , toolSettings_pgm_P = (cpp_prog, cpp_args) - , toolSettings_pgm_F = "" - , toolSettings_pgm_c = cc_prog - , toolSettings_pgm_a = (as_prog, as_args) - , toolSettings_pgm_l = (ld_prog, ld_args) - , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) - , toolSettings_pgm_T = touch_path - , toolSettings_pgm_windres = windres_path - , toolSettings_pgm_libtool = libtool_path - , toolSettings_pgm_ar = ar_path - , toolSettings_pgm_ranlib = ranlib_path - , toolSettings_pgm_lo = (lo_prog,[]) - , toolSettings_pgm_lc = (lc_prog,[]) - , toolSettings_pgm_lcc = (lcc_prog,[]) - , toolSettings_pgm_i = iserv_prog - , toolSettings_opt_L = [] - , toolSettings_opt_P = [] - , toolSettings_opt_P_fingerprint = fingerprint0 - , toolSettings_opt_F = [] - , toolSettings_opt_c = cc_args - , toolSettings_opt_cxx = cxx_args - , toolSettings_opt_a = [] - , toolSettings_opt_l = [] - , toolSettings_opt_windres = [] - , toolSettings_opt_lcc = [] - , toolSettings_opt_lo = [] - , toolSettings_opt_lc = [] - , toolSettings_opt_i = [] - - , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags - } - - , sTargetPlatform = platform - , sPlatformMisc = PlatformMisc - { platformMisc_targetPlatformString = targetPlatformString - , platformMisc_integerLibrary = integerLibrary - , platformMisc_integerLibraryType = integerLibraryType - , platformMisc_ghcWithInterpreter = ghcWithInterpreter - , platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen - , platformMisc_ghcWithSMP = ghcWithSMP - , platformMisc_ghcRTSWays = ghcRTSWays - , platformMisc_tablesNextToCode = tablesNextToCode - , platformMisc_leadingUnderscore = leadingUnderscore - , platformMisc_libFFI = useLibFFI - , platformMisc_ghcThreaded = ghcThreaded - , platformMisc_ghcDebugged = ghcDebugged - , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw - , platformMisc_llvmTarget = llvmTarget - } - - , sPlatformConstants = platformConstants - - , sRawSettings = settingsList - } - +initSysTools top_dir = do + res <- runExceptT $ initSettings top_dir + case res of + Right a -> pure a + Left (SettingsError_MissingData msg) -> pgmError msg + Left (SettingsError_BadData msg) -> pgmError msg {- Note [Windows stack usage] diff --git a/compiler/main/SysTools/Settings.hs b/compiler/main/SysTools/Settings.hs new file mode 100644 index 0000000000..43682850fd --- /dev/null +++ b/compiler/main/SysTools/Settings.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module SysTools.Settings + ( SettingsError (..) + , initSettings + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Settings + +import Config +import CliOption +import FileSettings +import Fingerprint +import GHC.Platform +import GhcNameVersion +import Outputable +import Settings +import SysTools.BaseDir +import ToolSettings + +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import qualified Data.Map as Map +import System.FilePath +import System.Directory + +data SettingsError + = SettingsError_MissingData String + | SettingsError_BadData String + +initSettings + :: forall m + . MonadIO m + => String -- ^ TopDir path + -> ExceptT SettingsError m Settings +initSettings top_dir = do + -- see Note [topdir: How GHC finds its files] + -- NB: top_dir is assumed to be in standard Unix + -- format, '/' separated + mtool_dir <- liftIO $ findToolDir top_dir + -- see Note [tooldir: How GHC finds mingw on Windows] + + let installed :: FilePath -> FilePath + installed file = top_dir file + libexec :: FilePath -> FilePath + libexec file = top_dir "bin" file + settingsFile = installed "settings" + platformConstantsFile = installed "platformConstants" + + readFileSafe :: FilePath -> ExceptT SettingsError m String + readFileSafe path = liftIO (doesFileExist path) >>= \case + True -> liftIO $ readFile path + False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path + + settingsStr <- readFileSafe settingsFile + platformConstantsStr <- readFileSafe platformConstantsFile + settingsList <- case maybeReadFuzzy settingsStr of + Just s -> pure s + Nothing -> throwE $ SettingsError_BadData $ + "Can't parse " ++ show settingsFile + let mySettings = Map.fromList settingsList + platformConstants <- case maybeReadFuzzy platformConstantsStr of + Just s -> pure s + Nothing -> throwE $ SettingsError_BadData $ + "Can't parse " ++ show platformConstantsFile + -- See Note [Settings file] for a little more about this file. We're + -- just partially applying those functions and throwing 'Left's; they're + -- written in a very portable style to keep ghc-boot light. + let getSetting key = either pgmError pure $ + getFilePathSetting0 top_dir settingsFile mySettings key + getToolSetting :: String -> ExceptT SettingsError m String + getToolSetting key = expandToolDir mtool_dir <$> getSetting key + getBooleanSetting :: String -> ExceptT SettingsError m Bool + getBooleanSetting key = either pgmError pure $ + getBooleanSetting0 settingsFile mySettings key + targetPlatformString <- getSetting "target platform string" + tablesNextToCode <- getBooleanSetting "Tables next to code" + myExtraGccViaCFlags <- getSetting "GCC extra via C opts" + -- On Windows, mingw is distributed with GHC, + -- so we look in TopDir/../mingw/bin, + -- as well as TopDir/../../mingw/bin for hadrian. + -- It would perhaps be nice to be able to override this + -- with the settings file, but it would be a little fiddly + -- to make that possible, so for now you can't. + cc_prog <- getToolSetting "C compiler command" + cc_args_str <- getSetting "C compiler flags" + cxx_args_str <- getSetting "C++ compiler flags" + gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" + cpp_prog <- getToolSetting "Haskell CPP command" + cpp_args_str <- getSetting "Haskell CPP flags" + + platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings + + let unreg_cc_args = if platformUnregisterised platform + then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] + else [] + cpp_args = map Option (words cpp_args_str) + cc_args = words cc_args_str ++ unreg_cc_args + cxx_args = words cxx_args_str + ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" + ldSupportsBuildId <- getBooleanSetting "ld supports build-id" + ldSupportsFilelist <- getBooleanSetting "ld supports filelist" + ldIsGnuLd <- getBooleanSetting "ld is GNU ld" + + let pkgconfig_path = installed "package.conf.d" + ghc_usage_msg_path = installed "ghc-usage.txt" + ghci_usage_msg_path = installed "ghci-usage.txt" + + -- For all systems, unlit, split, mangle are GHC utilities + -- architecture-specific stuff is done when building Config.hs + unlit_path <- getToolSetting "unlit command" + + windres_path <- getToolSetting "windres command" + libtool_path <- getToolSetting "libtool command" + ar_path <- getToolSetting "ar command" + ranlib_path <- getToolSetting "ranlib command" + + -- TODO this side-effect doesn't belong here. Reading and parsing the settings + -- should be idempotent and accumulate no resources. + tmpdir <- liftIO $ getTemporaryDirectory + + touch_path <- getToolSetting "touch command" + + mkdll_prog <- getToolSetting "dllwrap command" + let mkdll_args = [] + + -- cpp is derived from gcc on all platforms + -- HACK, see setPgmP below. We keep 'words' here to remember to fix + -- Config.hs one day. + + + -- Other things being equal, as and ld are simply gcc + cc_link_args_str <- getSetting "C compiler link flags" + let as_prog = cc_prog + as_args = map Option cc_args + ld_prog = cc_prog + ld_args = map Option (cc_args ++ words cc_link_args_str) + + llvmTarget <- getSetting "LLVM target" + + -- We just assume on command line + lc_prog <- getSetting "LLVM llc command" + lo_prog <- getSetting "LLVM opt command" + lcc_prog <- getSetting "LLVM clang command" + + let iserv_prog = libexec "ghc-iserv" + + integerLibrary <- getSetting "integer library" + integerLibraryType <- case integerLibrary of + "integer-gmp" -> pure IntegerGMP + "integer-simple" -> pure IntegerSimple + _ -> pgmError $ unwords + [ "Entry for" + , show "integer library" + , "must be one of" + , show "integer-gmp" + , "or" + , show "integer-simple" + ] + + ghcWithInterpreter <- getBooleanSetting "Use interpreter" + ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator" + ghcWithSMP <- getBooleanSetting "Support SMP" + ghcRTSWays <- getSetting "RTS ways" + leadingUnderscore <- getBooleanSetting "Leading underscore" + useLibFFI <- getBooleanSetting "Use LibFFI" + ghcThreaded <- getBooleanSetting "Use Threads" + ghcDebugged <- getBooleanSetting "Use Debugging" + ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" + + return $ Settings + { sGhcNameVersion = GhcNameVersion + { ghcNameVersion_programName = "ghc" + , ghcNameVersion_projectVersion = cProjectVersion + } + + , sFileSettings = FileSettings + { fileSettings_tmpDir = normalise tmpdir + , fileSettings_ghcUsagePath = ghc_usage_msg_path + , fileSettings_ghciUsagePath = ghci_usage_msg_path + , fileSettings_toolDir = mtool_dir + , fileSettings_topDir = top_dir + , fileSettings_systemPackageConfig = pkgconfig_path + } + + , sToolSettings = ToolSettings + { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind + , toolSettings_ldSupportsBuildId = ldSupportsBuildId + , toolSettings_ldSupportsFilelist = ldSupportsFilelist + , toolSettings_ldIsGnuLd = ldIsGnuLd + , toolSettings_ccSupportsNoPie = gccSupportsNoPie + + , toolSettings_pgm_L = unlit_path + , toolSettings_pgm_P = (cpp_prog, cpp_args) + , toolSettings_pgm_F = "" + , toolSettings_pgm_c = cc_prog + , toolSettings_pgm_a = (as_prog, as_args) + , toolSettings_pgm_l = (ld_prog, ld_args) + , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) + , toolSettings_pgm_T = touch_path + , toolSettings_pgm_windres = windres_path + , toolSettings_pgm_libtool = libtool_path + , toolSettings_pgm_ar = ar_path + , toolSettings_pgm_ranlib = ranlib_path + , toolSettings_pgm_lo = (lo_prog,[]) + , toolSettings_pgm_lc = (lc_prog,[]) + , toolSettings_pgm_lcc = (lcc_prog,[]) + , toolSettings_pgm_i = iserv_prog + , toolSettings_opt_L = [] + , toolSettings_opt_P = [] + , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_F = [] + , toolSettings_opt_c = cc_args + , toolSettings_opt_cxx = cxx_args + , toolSettings_opt_a = [] + , toolSettings_opt_l = [] + , toolSettings_opt_windres = [] + , toolSettings_opt_lcc = [] + , toolSettings_opt_lo = [] + , toolSettings_opt_lc = [] + , toolSettings_opt_i = [] + + , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags + } + + , sTargetPlatform = platform + , sPlatformMisc = PlatformMisc + { platformMisc_targetPlatformString = targetPlatformString + , platformMisc_integerLibrary = integerLibrary + , platformMisc_integerLibraryType = integerLibraryType + , platformMisc_ghcWithInterpreter = ghcWithInterpreter + , platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen + , platformMisc_ghcWithSMP = ghcWithSMP + , platformMisc_ghcRTSWays = ghcRTSWays + , platformMisc_tablesNextToCode = tablesNextToCode + , platformMisc_leadingUnderscore = leadingUnderscore + , platformMisc_libFFI = useLibFFI + , platformMisc_ghcThreaded = ghcThreaded + , platformMisc_ghcDebugged = ghcDebugged + , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw + , platformMisc_llvmTarget = llvmTarget + } + + , sPlatformConstants = platformConstants + + , sRawSettings = settingsList + } -- cgit v1.2.1