diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index b8eaf91f37b795dc17d4438e3b7dad76fed10fa0..c98ff74531de822f351b5d2b3e6ccbeee113ac29 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/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
diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs
index 1807b8e7eeb12723ac27156196a03e4221ba9209..b48fca86e778069b493c0df26d9bdde3fec5ccf3 100644
--- a/compiler/GHC/Settings/IO.hs
+++ b/compiler/GHC/Settings/IO.hs
@@ -118,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
diff --git a/hadrian/bindist/Makefile b/hadrian/bindist/Makefile
index 32f9952c8ca11205610608fcd88fdf085ad194e3..d58235464c80910231416130b29e426e1f73b620 100644
--- a/hadrian/bindist/Makefile
+++ b/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.
diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs
index 764d7b7990d87ff2aadccb07866126d6594d1311..3bcd1d8a6096babbaee829dc7d508234f228c8f4 100644
--- a/hadrian/src/Rules/Generate.hs
+++ b/hadrian/src/Rules/Generate.hs
@@ -422,6 +422,7 @@ generateSettings = do
, ("Leading underscore", queryTarget (yesNo . tgtSymbolsHaveLeadingUnderscore))
, ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors)
, ("RTS expects libdw", yesNo <$> getFlag UseLibdw)
+ , ("Relative Global Package DB", return "package.conf.d" )
]
let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"
pure $ case settings of
diff --git a/libraries/ghc-boot/GHC/Settings/Utils.hs b/libraries/ghc-boot/GHC/Settings/Utils.hs
index 4ccbbf23b628eedfe1d123ba17d04dc0cf294c16..35706fbc9a6ae0e232eb90a75456d5dc142a010f 100644
--- a/libraries/ghc-boot/GHC/Settings/Utils.hs
+++ b/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
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 236e73928cf9b91e76b51aeae401ad8055fd2e88..767fa69129f9f2126ad5849de44142382540f51b 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/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)