[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Escape multiple arguments in the settings file
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Mar 17 03:27:18 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
c8c0732b by Fendor at 2024-03-16T23:27:02-04:00
Escape multiple arguments in the settings file
Uses responseFile syntax.
The issue arises when GHC is installed on windows into a location that
has a space, for example the user name is 'Fake User'.
The $topdir will also contain a space, consequentially.
When we resolve the top dir in the string `-I$topdir/mingw/include`,
then `words` will turn this single argument into `-I/C/Users/Fake` and
`User/.../mingw/include` which trips up our flags.
We avoid this by escaping the $topdir before replacing in GHC.
Add regression test case to count the number of options after variable
expansion took place. Additionally, check escaping works.
- - - - -
effeb877 by Matthew Pickering at 2024-03-16T23:27:03-04:00
Read global package database from settings file
Before this patch, the global package database was always assumed to be
in libdir </> package.conf.d.
This causes issues in GHC's build system because there are sometimes
situations where the package database you need to use is not located in
the same place as the settings file.
* The stage1 compiler needs to use stage1 libraries, so we should set
"Global Package DB" for the stage1 compiler to the stage1 package
database.
* Stage 2 cross compilers need to use stage2 libraries, so likewise, we
should set the package database path to `_build/stage2/lib/`
* The normal situation is where the stage2 compiler uses stage1
libraries. Then everything lines up.
* When installing we have rearranged everything so that the settings
file and package database line up properly, so then everything should
continue to work as before. In this case we set the relative package
db path to `package.conf.d`, so it resolves the same as before.
* ghc-pkg needs to be modified as well to look in the settings file fo
the package database rather than assuming the global package database
location relative to the lib folder.
* Cabal/cabal-install will work correctly because they query the global
package database using `--print-global-package-db`.
A reasonable question is why not generate the "right" settings files in
the right places in GHC's build system. In order to do this you would
need to engineer wrappers for all executables to point to a specific
libdir. There are also situations where the same package db is used by
two different compilers with two different settings files (think stage2
cross compiler and stage3 compiler).
In short, this 10 line patch allows for some reasonable simplifications
in Hadrian at very little cost to anything else.
Fixes #24502
- - - - -
fdcdb69f by Matthew Pickering at 2024-03-16T23:27:03-04:00
hadrian: Remove stage1 testsuite wrappers logic
Now instead of producing wrappers which pass the global package database
argument to ghc and ghc-pkg, we write the location of the correct
package database into the settings file so you can just use the intree
compiler directly.
- - - - -
182a0997 by Fendor at 2024-03-16T23:27:05-04:00
Fix sharing of 'IfaceTyConInfo' during core to iface type translation
During heap analysis, we noticed that during generation of
'mi_extra_decls' we have lots of duplicates for the instances:
* `IfaceTyConInfo NotPromoted IfaceNormalTyCon`
* `IfaceTyConInfo IsPromoted IfaceNormalTyCon`
which should be shared instead of duplicated. This duplication increased
the number of live bytes by around 200MB while loading the agda codebase
into GHCi.
These instances are created during `CoreToIface` translation, in
particular `toIfaceTyCon`.
The generated core looks like:
toIfaceTyCon
= \ tc_sjJw ->
case $wtoIfaceTyCon tc_sjJw of
{ (# ww_sjJz, ww1_sjNL, ww2_sjNM #) ->
IfaceTyCon ww_sjJz (IfaceTyConInfo ww1_sjNL ww2_sjNM)
}
whichs removes causes the sharing to work propery.
Adding explicit sharing, with NOINLINE annotations, changes the core to:
toIfaceTyCon
= \ tc_sjJq ->
case $wtoIfaceTyCon tc_sjJq of { (# ww_sjNB, ww1_sjNC #) ->
IfaceTyCon ww_sjNB ww1_sjNC
}
which looks much more like sharing is happening.
We confirmed via ghc-debug that all duplications were eliminated and the
number of live bytes are noticeably reduced.
- - - - -
15 changed files:
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Settings/IO.hs
- hadrian/bindist/Makefile
- hadrian/src/Oracles/TestSettings.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Test.hs
- libraries/ghc-boot/GHC/Settings/Utils.hs
- + test.hs
- + testsuite/tests/ghc-api/settings-escape/T11938.hs
- + testsuite/tests/ghc-api/settings-escape/T11938.stderr
- + testsuite/tests/ghc-api/settings-escape/all.T
- + testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib/settings
- + testsuite/tests/ghc-api/settings-escape/ghc-install-folder/mingw/.gitkeep
- utils/ghc-pkg/Main.hs
Changes:
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3611,7 +3611,8 @@ compilerInfo dflags
("GHC Profiled", showBool hostIsProfiled),
("Debug on", showBool debugIsOn),
("LibDir", topDir dflags),
- -- The path of the global package database used by GHC
+ -- This is always an absolute path, unlike "Relative Global Package DB" which is
+ -- in the settings file.
("Global Package DB", globalPackageDatabasePath dflags)
]
where
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -361,12 +361,51 @@ data IfaceTyConInfo -- Used only to guide pretty-printing
, ifaceTyConSort :: IfaceTyConSort }
deriving (Eq)
--- This smart constructor allows sharing of the two most common
--- cases. See #19194
+-- | This smart constructor allows sharing of the two most common
+-- cases. See Note [Sharing IfaceTyConInfo]
mkIfaceTyConInfo :: PromotionFlag -> IfaceTyConSort -> IfaceTyConInfo
-mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = IfaceTyConInfo IsPromoted IfaceNormalTyCon
-mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = IfaceTyConInfo NotPromoted IfaceNormalTyCon
-mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort
+mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = promotedNormalTyConInfo
+mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo
+mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort
+
+{-# NOINLINE promotedNormalTyConInfo #-}
+-- | See Note [Sharing IfaceTyConInfo]
+promotedNormalTyConInfo :: IfaceTyConInfo
+promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon
+
+{-# NOINLINE notPromotedNormalTyConInfo #-}
+-- | See Note [Sharing IfaceTyConInfo]
+notPromotedNormalTyConInfo :: IfaceTyConInfo
+notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon
+
+{-
+Note [Sharing IfaceTyConInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'IfaceTyConInfo' occurs an awful lot in 'ModIface', see #19194 for an example.
+But almost all of them are
+
+ IfaceTyConInfo IsPromoted IfaceNormalTyCon
+ IfaceTyConInfo NotPromoted IfaceNormalTyCon.
+
+The smart constructor `mkIfaceTyConInfo` arranges to share these instances,
+thus:
+
+ promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon
+ notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon
+
+ mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = promotedNormalTyConInfo
+ mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo
+ mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort
+
+But ALAS, the (nested) CPR transform can lose this sharing, completely
+negating the effect of `mkIfaceTyConInfo`: see #24530 and #19326.
+
+Sticking-plaster solution: add a NOINLINE pragma to those top-level constants.
+When we fix the CPR bug we can remove the NOINLINE pragmas.
+
+This one change leads to an 15% reduction in residency for GHC when embedding
+'mi_extra_decls': see !12222.
+-}
data IfaceMCoercion
= IfaceMRefl
=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -16,9 +16,11 @@ import GHC.Utils.CliOption
import GHC.Utils.Fingerprint
import GHC.Platform
import GHC.Utils.Panic
+import GHC.ResponseFile
import GHC.Settings
import GHC.SysTools.BaseDir
+import Data.Char
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
import qualified Data.Map as Map
@@ -72,9 +74,13 @@ initSettings top_dir = do
-- 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 $
- getRawFilePathSetting top_dir settingsFile mySettings key
+ -- Escape the 'top_dir', to make sure we don't accidentally introduce an
+ -- unescaped space
+ getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key
getToolSetting :: String -> ExceptT SettingsError m String
- getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key
+ -- Escape the 'mtool_dir', to make sure we don't accidentally introduce
+ -- an unescaped space
+ getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key
targetPlatformString <- getSetting "target platform string"
cc_prog <- getToolSetting "C compiler command"
cxx_prog <- getToolSetting "C++ compiler command"
@@ -91,10 +97,10 @@ initSettings top_dir = do
let unreg_cc_args = if platformUnregisterised platform
then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
else []
- cpp_args = map Option (words cpp_args_str)
- hs_cpp_args = map Option (words hs_cpp_args_str)
- cc_args = words cc_args_str ++ unreg_cc_args
- cxx_args = words cxx_args_str
+ cpp_args = map Option (unescapeArgs cpp_args_str)
+ hs_cpp_args = map Option (unescapeArgs hs_cpp_args_str)
+ cc_args = unescapeArgs cc_args_str ++ unreg_cc_args
+ cxx_args = unescapeArgs cxx_args_str
-- The extra flags we need to pass gcc when we invoke it to compile .hc code.
--
@@ -112,8 +118,14 @@ initSettings top_dir = do
ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
arSupportsDashL <- getBooleanSetting "ar supports -L"
- let globalpkgdb_path = installed "package.conf.d"
- ghc_usage_msg_path = installed "ghc-usage.txt"
+
+ -- The package database is either a relative path to the location of the settings file
+ -- OR an absolute path.
+ -- In case the path is absolute then top_dir </> abs_path == abs_path
+ -- the path is relative then top_dir </> rel_path == top_dir </> rel_path
+ globalpkgdb_path <- installed <$> getSetting "Relative Global Package DB"
+
+ let 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
@@ -135,12 +147,12 @@ initSettings top_dir = do
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)
+ ld_args = map Option (cc_args ++ unescapeArgs cc_link_args_str)
ld_r_prog <- getToolSetting "Merge objects command"
ld_r_args <- getToolSetting "Merge objects flags"
let ld_r
| null ld_r_prog = Nothing
- | otherwise = Just (ld_r_prog, map Option $ words ld_r_args)
+ | otherwise = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args)
llvmTarget <- getSetting "LLVM target"
@@ -261,3 +273,19 @@ getTargetPlatform settingsFile settings = do
, platformHasLibm = targetHasLibm
, platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit
}
+
+-- ----------------------------------------------------------------------------
+-- Escape Args helpers
+-- ----------------------------------------------------------------------------
+
+-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base.
+escapeArg :: String -> String
+escapeArg = reverse . foldl' escape []
+
+escape :: String -> Char -> String
+escape cs c
+ | isSpace c
+ || '\\' == c
+ || '\'' == c
+ || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result
+ | otherwise = c:cs
=====================================
hadrian/bindist/Makefile
=====================================
@@ -141,6 +141,7 @@ lib/settings : config.mk
@echo ',("Leading underscore", "$(LeadingUnderscore)")' >> $@
@echo ',("Use LibFFI", "$(UseLibffiForAdjustors)")' >> $@
@echo ',("RTS expects libdw", "$(GhcRtsWithLibdw)")' >> $@
+ @echo ',("Relative Global Package DB", "package.conf.d")' >> $@
@echo "]" >> $@
# We need to install binaries relative to libraries.
=====================================
hadrian/src/Oracles/TestSettings.hs
=====================================
@@ -13,8 +13,6 @@ import Hadrian.Oracles.TextFile
import Oracles.Setting (topDirectory, setting, Setting(..))
import Packages
import Settings.Program (programContext)
-import Hadrian.Oracles.Path
-import System.Directory (makeAbsolute)
testConfigFile :: Action FilePath
testConfigFile = buildRoot <&> (-/- "test/ghcconfig")
@@ -81,15 +79,12 @@ testRTSSettings = do
file <- testConfigFile
words <$> lookupValueOrError Nothing file "GhcRTSWays"
-absoluteBuildRoot :: Action FilePath
-absoluteBuildRoot = (fixAbsolutePathOnWindows =<< liftIO . makeAbsolute =<< buildRoot)
-
-- | Directory to look for binaries.
-- We assume that required programs are present in the same binary directory
-- in which ghc is stored and that they have their conventional name.
getBinaryDirectory :: String -> Action FilePath
getBinaryDirectory "stage0" = takeDirectory <$> setting SystemGhc
-getBinaryDirectory "stage1" = liftM2 (-/-) absoluteBuildRoot (pure "stage1-test/bin/")
+getBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath stage0InTree)
getBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
getBinaryDirectory "stage3" = liftM2 (-/-) topDirectory (stageBinPath Stage2)
getBinaryDirectory "stage-cabal" = do
@@ -101,7 +96,7 @@ getBinaryDirectory compiler = pure $ takeDirectory compiler
-- | Get the path to the given @--test-compiler at .
getCompilerPath :: String -> Action FilePath
getCompilerPath "stage0" = setting SystemGhc
-getCompilerPath "stage1" = liftM2 (-/-) absoluteBuildRoot (pure ("stage1-test/bin/ghc" <.> exe))
+getCompilerPath "stage1" = liftM2 (-/-) topDirectory (fullPath stage0InTree ghc)
getCompilerPath "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
getCompilerPath "stage3" = liftM2 (-/-) topDirectory (fullPath Stage2 ghc)
getCompilerPath "stage-cabal" = do
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -6,6 +6,7 @@ module Rules.Generate (
) where
import Development.Shake.FilePath
+import Data.Char (isSpace)
import qualified Data.Set as Set
import Base
import qualified Context
@@ -234,8 +235,8 @@ generateRules = do
forM_ allStages $ \stage -> do
let prefix = root -/- stageString stage -/- "lib"
- go gen file = generate file (semiEmptyTarget stage) gen
- (prefix -/- "settings") %> go generateSettings
+ go gen file = generate file (semiEmptyTarget (succStage stage)) gen
+ (prefix -/- "settings") %> \out -> go (generateSettings out) out
where
file <~+ gen = file %> \out -> generate out emptyTarget gen >> makeExecutable out
@@ -355,21 +356,26 @@ templateRules = do
ghcWrapper :: Stage -> Expr String
ghcWrapper (Stage0 {}) = error "Stage0 GHC does not require a wrapper script to run."
ghcWrapper stage = do
- dbPath <- expr $ (</>) <$> topDirectory <*> packageDbPath (PackageDbLoc stage Final)
ghcPath <- expr $ (</>) <$> topDirectory
<*> programPath (vanillaContext (predStage stage) ghc)
return $ unwords $ map show $ [ ghcPath ]
- ++ (if stage == Stage1
- then ["-no-global-package-db"
- , "-package-env=-"
- , "-package-db " ++ dbPath
- ]
- else [])
++ [ "$@" ]
-generateSettings :: Expr String
-generateSettings = do
+generateSettings :: FilePath -> Expr String
+generateSettings settingsFile = do
ctx <- getContext
+ stage <- getStage
+
+ package_db_path <- expr $ do
+ let get_pkg_db stg = packageDbPath (PackageDbLoc stg Final)
+ case stage of
+ Stage0 {} -> error "Unable to generate settings for stage0"
+ Stage1 -> get_pkg_db Stage1
+ Stage2 -> get_pkg_db Stage1
+ Stage3 -> get_pkg_db Stage2
+
+ let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path
+
settings <- traverse sequence $
[ ("C compiler command", queryTarget ccPath)
, ("C compiler flags", queryTarget ccFlags)
@@ -416,11 +422,12 @@ generateSettings = do
, ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter)
, ("Support SMP", expr $ yesNo <$> targetSupportsSMP)
- , ("RTS ways", unwords . map show . Set.toList <$> getRtsWays)
+ , ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays)
, ("Tables next to code", queryTarget (yesNo . tgtTablesNextToCode))
, ("Leading underscore", queryTarget (yesNo . tgtSymbolsHaveLeadingUnderscore))
, ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors)
, ("RTS expects libdw", yesNo <$> getFlag UseLibdw)
+ , ("Relative Global Package DB", pure rel_pkg_db)
]
let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"
pure $ case settings of
@@ -431,23 +438,23 @@ generateSettings = do
++ ["]"]
where
ccPath = prgPath . ccProgram . tgtCCompiler
- ccFlags = unwords . prgFlags . ccProgram . tgtCCompiler
+ ccFlags = escapeArgs . prgFlags . ccProgram . tgtCCompiler
cxxPath = prgPath . cxxProgram . tgtCxxCompiler
- cxxFlags = unwords . prgFlags . cxxProgram . tgtCxxCompiler
- clinkFlags = unwords . prgFlags . ccLinkProgram . tgtCCompilerLink
+ cxxFlags = escapeArgs . prgFlags . cxxProgram . tgtCxxCompiler
+ clinkFlags = escapeArgs . prgFlags . ccLinkProgram . tgtCCompilerLink
linkSupportsNoPie = yesNo . ccLinkSupportsNoPie . tgtCCompilerLink
cppPath = prgPath . cppProgram . tgtCPreprocessor
- cppFlags = unwords . prgFlags . cppProgram . tgtCPreprocessor
+ cppFlags = escapeArgs . prgFlags . cppProgram . tgtCPreprocessor
hsCppPath = prgPath . hsCppProgram . tgtHsCPreprocessor
- hsCppFlags = unwords . prgFlags . hsCppProgram . tgtHsCPreprocessor
+ hsCppFlags = escapeArgs . prgFlags . hsCppProgram . tgtHsCPreprocessor
mergeObjsPath = maybe "" (prgPath . mergeObjsProgram) . tgtMergeObjs
- mergeObjsFlags = maybe "" (unwords . prgFlags . mergeObjsProgram) . tgtMergeObjs
+ mergeObjsFlags = maybe "" (escapeArgs . prgFlags . mergeObjsProgram) . tgtMergeObjs
linkSupportsSingleModule = yesNo . ccLinkSupportsSingleModule . tgtCCompilerLink
linkSupportsFilelist = yesNo . ccLinkSupportsFilelist . tgtCCompilerLink
linkSupportsCompactUnwind = yesNo . ccLinkSupportsCompactUnwind . tgtCCompilerLink
linkIsGnu = yesNo . ccLinkIsGnu . tgtCCompilerLink
arPath = prgPath . arMkArchive . tgtAr
- arFlags = unwords . prgFlags . arMkArchive . tgtAr
+ arFlags = escapeArgs . prgFlags . arMkArchive . tgtAr
arSupportsAtFile' = yesNo . arSupportsAtFile . tgtAr
arSupportsDashL' = yesNo . arSupportsDashL . tgtAr
ranlibPath = maybe "" (prgPath . ranlibProgram) . tgtRanlib
@@ -571,3 +578,19 @@ generatePlatformHostHs = do
, "hostPlatformArchOS :: ArchOS"
, "hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS"
]
+
+-- | Just like 'GHC.ResponseFile.escapeArgs', but use spaces instead of newlines
+-- for splitting elements.
+escapeArgs :: [String] -> String
+escapeArgs = unwords . map escapeArg
+
+escapeArg :: String -> String
+escapeArg = reverse . foldl' escape []
+
+escape :: String -> Char -> String
+escape cs c
+ | isSpace c
+ || '\\' == c
+ || '\'' == c
+ || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result
+ | otherwise = c:cs
=====================================
hadrian/src/Rules/Test.hs
=====================================
@@ -124,28 +124,6 @@ testRules = do
testsuiteDeps
- -- we need to create wrappers to test the stage1 compiler
- -- as the stage1 compiler needs the stage2 libraries
- -- to have any hope of passing tests.
- root -/- "stage1-test/bin/*" %> \path -> do
-
- bin_path <- stageBinPath stage0InTree
- let prog = takeBaseName path
- stage0prog = bin_path -/- prog <.> exe
- need [stage0prog]
- abs_prog_path <- liftIO (IO.canonicalizePath stage0prog)
- -- Use the stage1 package database
- pkgDb <- liftIO . IO.makeAbsolute =<< packageDbPath (PackageDbLoc Stage1 Final)
- if prog `elem` ["ghc","runghc"] then do
- let flags = [ "-no-global-package-db", "-no-user-package-db", "-hide-package", "ghc" , "-package-env","-","-package-db",pkgDb]
- writeFile' path $ unlines ["#!/bin/sh",unwords ((abs_prog_path : flags) ++ ["${1+\"$@\"}"])]
- makeExecutable path
- else if prog == "ghc-pkg" then do
- let flags = ["--no-user-package-db", "--global-package-db", pkgDb]
- writeFile' path $ unlines ["#!/bin/sh",unwords ((abs_prog_path : flags) ++ ["${1+\"$@\"}"])]
- makeExecutable path
- else createFileLink abs_prog_path path
-
-- Rules for building check-ppr, check-exact and
-- check-ppr-annotations with the compiler we are going to test
-- (in-tree or out-of-tree).
@@ -344,18 +322,6 @@ needTestsuitePackages stg = do
need =<< mapM (uncurry pkgFile) pkgs
cross <- flag CrossCompiling
when (not cross) $ needIservBins stg
- root <- buildRoot
- -- require the shims for testing stage1
- when (stg == stage0InTree) $ do
- -- Windows not supported as the wrapper scripts don't work on windows.. we could
- -- support it with a separate .bat or C wrapper code path but seems overkill when no-one will
- -- probably ever try and do this.
- when windowsHost $ do
- putFailure $ unlines [ "Testing stage1 compiler with windows is currently unsupported,"
- , "if you desire to do this then please open a ticket"]
- fail "Testing stage1 is not supported"
-
- need =<< sequence [(\f -> root -/- "stage1-test/bin" -/- takeFileName f) <$> (pkgFile stage0InTree p) | (Stage0 InTreeLibs,p) <- exepkgs]
-- stage 1 ghc lives under stage0/bin,
-- stage 2 ghc lives under stage1/bin, etc
=====================================
libraries/ghc-boot/GHC/Settings/Utils.hs
=====================================
@@ -8,6 +8,7 @@ import qualified Data.Map as Map
import GHC.BaseDir
import GHC.Platform.ArchOS
+import System.FilePath
maybeRead :: Read a => String -> Maybe a
maybeRead str = case reads str of
@@ -42,6 +43,12 @@ getTargetArchOS settingsFile settings =
ArchOS <$> readRawSetting settingsFile settings "target arch"
<*> readRawSetting settingsFile settings "target os"
+getGlobalPackageDb :: FilePath -> RawSettings -> Either String FilePath
+getGlobalPackageDb settingsFile settings = do
+ rel_db <- getRawSetting settingsFile settings "Relative Global Package DB"
+ return (dropFileName settingsFile </> rel_db)
+
+
getRawSetting
:: FilePath -> RawSettings -> String -> Either String String
=====================================
test.hs
=====================================
@@ -0,0 +1,14 @@
+import Data.Char
+import Data.Foldable
+-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base.
+escapeArg :: String -> String
+escapeArg = reverse . foldl' escape []
+
+escape :: String -> Char -> String
+escape cs c
+ | isSpace c
+ || '\\' == c
+ || '\'' == c
+ || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result
+ | otherwise = c:cs
+
=====================================
testsuite/tests/ghc-api/settings-escape/T11938.hs
=====================================
@@ -0,0 +1,73 @@
+
+import GHC.Settings
+import GHC.Settings.IO
+import GHC.Utils.CliOption (Option, showOpt)
+
+import Control.Monad.Trans.Except (runExceptT)
+import Data.Maybe (fromJust)
+import System.Directory (makeAbsolute)
+import System.IO (hPutStrLn, stderr)
+import System.Exit (exitWith, ExitCode(ExitFailure))
+
+-- Precondition: this test case must be executed in a directory with a space.
+main :: IO ()
+main = do
+ topDir <- makeAbsolute "./ghc-install-folder/lib"
+ settingsm <- runExceptT $ initSettings topDir
+
+ case settingsm of
+ Left (SettingsError_MissingData msg) -> do
+ hPutStrLn stderr $ "WARNING: " ++ show msg
+ hPutStrLn stderr $ "dont know target platform"
+ exitWith $ ExitFailure 1
+ Left (SettingsError_BadData msg) -> do
+ hPutStrLn stderr msg
+ exitWith $ ExitFailure 1
+ Right settings -> do
+ let
+ recordSetting :: String -> (Settings -> [String]) -> IO ()
+ recordSetting label selector = do
+ let opts = selector settings
+ -- At least one of the options must contain a space
+ containsSpaces = any (' ' `elem`) opts
+ hPutStrLn stderr $ "=== Number of '" <> label <> "' options: " ++ show (length opts)
+ hPutStrLn stderr $ " Contains spaces: " ++ show containsSpaces
+
+ recordFpSetting :: String -> (Settings -> String) -> IO ()
+ recordFpSetting label selector = do
+ let fp = selector settings
+ containsOnlyEscapedSpaces ('\\':' ':xs) = containsOnlyEscapedSpaces xs
+ containsOnlyEscapedSpaces (' ':_) = False
+ containsOnlyEscapedSpaces [] = True
+ containsOnlyEscapedSpaces (_:xs) = containsOnlyEscapedSpaces xs
+
+ -- Filepath may only contain escaped spaces
+ containsSpaces = containsOnlyEscapedSpaces fp
+ hPutStrLn stderr $ "=== FilePath '" <> label <> "' contains only escaped spaces: " ++ show containsSpaces
+
+ -- Assertions
+ -- Assumption: this test case is executed in a directory with a space.
+
+ -- Setting 'Haskell CPP flags' contains '$topdir' and '$tooldir' references.
+ -- Resolving those while containing spaces, should not introduce more options.
+ -- '$tooldir' will only be expanded in windows, while '$topdir' is always expanded.
+ recordSetting "Haskell CPP flags" (map showOpt . snd . toolSettings_pgm_P . sToolSettings)
+ -- Setting 'C compiler flags' contains strings with spaces.
+ -- GHC should not split these by word.
+ recordSetting "C compiler flags" (toolSettings_opt_c . sToolSettings)
+ -- Setting 'C compiler link flags' contains strings with spaces.
+ -- GHC should not split these by word.
+ recordSetting "C compiler link flags" (map showOpt . snd . toolSettings_pgm_l . sToolSettings)
+ -- Setting 'C++ compiler flags' contains strings with spaces.
+ -- GHC should not split these by word.
+ recordSetting "C++ compiler flags" (toolSettings_opt_cxx . sToolSettings)
+ -- Setting 'CPP Flags' contains strings with spaces.
+ -- GHC should not split these by word.
+ recordSetting "CPP Flags" (map showOpt . snd . toolSettings_pgm_cpp . sToolSettings)
+ -- Setting 'Merge objects flags' contains strings with spaces.
+ -- GHC should not split these by word.
+ -- We know in this case, that 'toolSettings_pgm_lm' is 'Just'
+ recordSetting "Merge objects flags" (map showOpt . snd . fromJust . toolSettings_pgm_lm . sToolSettings)
+ -- Setting 'unlit command' contains '$topdir' reference.
+ -- Resolving those while containing spaces, should be escaped correctly.
+ recordFpSetting "unlit command" (toolSettings_pgm_L . sToolSettings)
=====================================
testsuite/tests/ghc-api/settings-escape/T11938.stderr
=====================================
@@ -0,0 +1,13 @@
+=== Number of 'Haskell CPP flags' options: 5
+ Contains spaces: True
+=== Number of 'C compiler flags' options: 3
+ Contains spaces: True
+=== Number of 'C compiler link flags' options: 7
+ Contains spaces: True
+=== Number of 'C++ compiler flags' options: 2
+ Contains spaces: True
+=== Number of 'CPP Flags' options: 3
+ Contains spaces: True
+=== Number of 'Merge objects flags' options: 3
+ Contains spaces: True
+=== FilePath 'unlit command' contains only escaped spaces: True
=====================================
testsuite/tests/ghc-api/settings-escape/all.T
=====================================
@@ -0,0 +1 @@
+test('T11938', [normal, extra_files(['ghc-install-folder/'])], compile_and_run, ['-package ghc -package directory -package transformers'])
=====================================
testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib/settings
=====================================
@@ -0,0 +1,51 @@
+[("C compiler command", "/nix/store/lcf37pgp3rgww67v9x2990hbfwx96c1w-gcc-wrapper-12.2.0/bin/cc")
+,("C compiler flags", "-O2 \"-some option\" -some\\ other")
+,("C++ compiler command", "/nix/store/lcf37pgp3rgww67v9x2990hbfwx96c1w-gcc-wrapper-12.2.0/bin/g++")
+,("C++ compiler flags", "\"-some option\" -some\\ other")
+,("C compiler link flags", "-fuse-ld=gold -Wl,--no-as-needed \"-some option\" -some\\ other")
+,("C compiler supports -no-pie", "YES")
+,("CPP command", "/nix/store/lcf37pgp3rgww67v9x2990hbfwx96c1w-gcc-wrapper-12.2.0/bin/cc")
+,("CPP flags", "-E \"-some option\" -some\\ other")
+,("Haskell CPP command", "/nix/store/lcf37pgp3rgww67v9x2990hbfwx96c1w-gcc-wrapper-12.2.0/bin/cc")
+,("Haskell CPP flags", "-E -undef -traditional -I$topdir/ -I$tooldir/")
+,("ld supports compact unwind", "NO")
+,("ld supports filelist", "NO")
+,("ld supports single module", "NO")
+,("ld is GNU ld", "YES")
+,("Merge objects command", "/nix/store/lcf37pgp3rgww67v9x2990hbfwx96c1w-gcc-wrapper-12.2.0/bin/ld.gold")
+,("Merge objects flags", "-r \"-some option\" -some\\ other")
+,("Merge objects supports response files", "YES")
+,("ar command", "/nix/store/lcf37pgp3rgww67v9x2990hbfwx96c1w-gcc-wrapper-12.2.0/bin/ar")
+,("ar flags", "q")
+,("ar supports at file", "YES")
+,("ar supports -L", "NO")
+,("ranlib command", "/nix/store/lcf37pgp3rgww67v9x2990hbfwx96c1w-gcc-wrapper-12.2.0/bin/ranlib")
+,("otool command", "otool")
+,("install_name_tool command", "install_name_tool")
+,("touch command", "touch")
+,("windres command", "/bin/false")
+,("unlit command", "$topdir/../bin/unlit")
+,("cross compiling", "NO")
+,("target platform string", "x86_64-unknown-linux")
+,("target os", "OSLinux")
+,("target arch", "ArchX86_64")
+,("target word size", "8")
+,("target word big endian", "NO")
+,("target has GNU nonexec stack", "YES")
+,("target has .ident directive", "YES")
+,("target has subsections via symbols", "NO")
+,("target has libm", "YES")
+,("Unregisterised", "NO")
+,("LLVM target", "x86_64-unknown-linux")
+,("LLVM llc command", "llc")
+,("LLVM opt command", "opt")
+,("LLVM llvm-as command", "clang")
+,("Use inplace MinGW toolchain", "NO")
+,("Use interpreter", "YES")
+,("Support SMP", "YES")
+,("RTS ways", "v thr thr_debug thr_debug_dyn thr_dyn debug debug_dyn dyn")
+,("Tables next to code", "YES")
+,("Leading underscore", "NO")
+,("Use LibFFI", "NO")
+,("RTS expects libdw", "YES")
+]
=====================================
testsuite/tests/ghc-api/settings-escape/ghc-install-folder/mingw/.gitkeep
=====================================
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -28,7 +28,7 @@ import qualified GHC.Unit.Database as GhcPkg
import GHC.Unit.Database hiding (mkMungePathUrl)
import GHC.HandleEncoding
import GHC.BaseDir (getBaseDir)
-import GHC.Settings.Utils (getTargetArchOS, maybeReadFuzzy)
+import GHC.Settings.Utils (getTargetArchOS, maybeReadFuzzy, getGlobalPackageDb, RawSettings)
import GHC.Platform.Host (hostPlatformArchOS)
import GHC.UniqueSubdir (uniqueSubdir)
import qualified GHC.Data.ShortText as ST
@@ -582,6 +582,21 @@ allPackagesInStack = concatMap packages
stackUpTo :: FilePath -> PackageDBStack -> PackageDBStack
stackUpTo to_modify = dropWhile ((/= to_modify) . location)
+readFromSettingsFile :: FilePath
+ -> (FilePath -> RawSettings -> Either String b)
+ -> IO (Either String b)
+readFromSettingsFile settingsFile f = do
+ settingsStr <- readFile settingsFile
+ pure $ do
+ mySettings <- case maybeReadFuzzy settingsStr of
+ Just s -> pure $ Map.fromList s
+ -- It's excusable to not have a settings file (for now at
+ -- least) but completely inexcusable to have a malformed one.
+ Nothing -> Left $ "Can't parse settings file " ++ show settingsFile
+ case f settingsFile mySettings of
+ Right archOS -> Right archOS
+ Left e -> Left e
+
getPkgDatabases :: Verbosity
-> GhcPkg.DbOpenMode mode DbModifySelector
-> Bool -- use the user db
@@ -605,24 +620,38 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
-- location is passed to the binary using the --global-package-db flag by the
-- wrapper script.
let err_msg = "missing --global-package-db option, location of global package database unknown\n"
- global_conf <-
+ (top_dir, global_conf) <-
case [ f | FlagGlobalConfig f <- my_flags ] of
-- See Note [Base Dir] for more information on the base dir / top dir.
[] -> do mb_dir <- getBaseDir
case mb_dir of
Nothing -> die err_msg
Just dir -> do
- r <- lookForPackageDBIn dir
- case r of
- Nothing -> die ("Can't find package database in " ++ dir)
- Just path -> return path
- fs -> return (last fs)
-
- -- The value of the $topdir variable used in some package descriptions
- -- Note that the way we calculate this is slightly different to how it
- -- is done in ghc itself. We rely on the convention that the global
- -- package db lives in ghc's libdir.
- top_dir <- absolutePath (takeDirectory global_conf)
+ -- Look for where it is given in the settings file, if marked there.
+ let settingsFile = dir </> "settings"
+ exists_settings_file <- doesFileExist settingsFile
+ erel_db <-
+ if exists_settings_file
+ then readFromSettingsFile settingsFile getGlobalPackageDb
+ else pure (Left ("Settings file doesn't exist: " ++ settingsFile))
+
+ case erel_db of
+ Right rel_db -> return (dir, dir </> rel_db)
+ -- If the version of GHC doesn't have this field or the settings file
+ -- doesn't exist for some reason, look in the libdir.
+ Left err -> do
+ r <- lookForPackageDBIn dir
+ case r of
+ Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ dir)])
+ Just path -> return (dir, path)
+ fs -> do
+ -- The value of the $topdir variable used in some package descriptions
+ -- Note that the way we calculate this is slightly different to how it
+ -- is done in ghc itself. We rely on the convention that the global
+ -- package db lives in ghc's libdir.
+ let pkg_db = last fs
+ top_dir <- absolutePath (takeDirectory pkg_db)
+ return (top_dir, pkg_db)
let no_user_db = FlagNoUserDb `elem` my_flags
@@ -641,16 +670,11 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
warn $ "WARNING: settings file doesn't exist " ++ show settingsFile
warn "cannot know target platform so guessing target == host (native compiler)."
pure hostPlatformArchOS
- True -> do
- settingsStr <- readFile settingsFile
- mySettings <- case maybeReadFuzzy settingsStr of
- Just s -> pure $ Map.fromList s
- -- It's excusable to not have a settings file (for now at
- -- least) but completely inexcusable to have a malformed one.
- Nothing -> die $ "Can't parse settings file " ++ show settingsFile
- case getTargetArchOS settingsFile mySettings of
- Right archOS -> pure archOS
+ True ->
+ readFromSettingsFile settingsFile getTargetArchOS >>= \case
+ Right v -> pure v
Left e -> die e
+
let subdir = uniqueSubdir targetArchOS
getFirstSuccess :: [IO a] -> IO (Maybe a)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/601e560a187b2902ab43a2a6db424caf423cd31a...182a09975b1d834b0aeead3c277d72e34d2fb1e5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/601e560a187b2902ab43a2a6db424caf423cd31a...182a09975b1d834b0aeead3c277d72e34d2fb1e5
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240316/4e19984e/attachment-0001.html>
More information about the ghc-commits
mailing list