From d406a16ac22e6ad02da0d2c75212614eda09d2cb Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 31 May 2019 19:33:33 -0400
Subject: [PATCH] ghc-pkg needs settings file to un-hardcode target platform
This matches GHC itself getting the target platform from there.
---
compiler/hieFile/HieBin.hs | 3 +-
compiler/main/SysTools.hs | 56 +++++---------
compiler/main/SysTools/BaseDir.hs | 16 ----
compiler/utils/Util.hs | 22 ------
libraries/ghc-boot/GHC/BaseDir.hs | 18 ++++-
libraries/ghc-boot/GHC/Settings.hs | 104 ++++++++++++++++++++++++++
libraries/ghc-boot/ghc-boot.cabal.in | 2 +
testsuite/tests/driver/T3007/Makefile | 6 +-
utils/ghc-pkg/Main.hs | 34 ++++++++-
utils/ghc-pkg/ghc.mk | 5 +-
10 files changed, 182 insertions(+), 84 deletions(-)
create mode 100644 libraries/ghc-boot/GHC/Settings.hs
diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs
index 6c72dca03483..61e3d01d0ea8 100644
--- a/compiler/hieFile/HieBin.hs
+++ b/compiler/hieFile/HieBin.hs
@@ -4,6 +4,8 @@ Binary serialization for .hie files.
{-# LANGUAGE ScopedTypeVariables #-}
module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where
+import GHC.Settings ( maybeRead )
+
import Config ( cProjectVersion )
import GhcPrelude
import Binary
@@ -17,7 +19,6 @@ import Outputable
import PrelInfo
import SrcLoc
import UniqSupply ( takeUniqFromSupply )
-import Util ( maybeRead )
import Unique
import UniqFM
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 5ab880513295..518d9fdb2f4f 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -40,17 +40,19 @@ module SysTools (
import GhcPrelude
+import GHC.Settings
+
import Module
import Packages
import Config
import Outputable
import ErrUtils
import GHC.Platform
-import Util
import DynFlags
import Fingerprint
import ToolSettings
+import qualified Data.Map as Map
import System.FilePath
import System.IO
import System.Directory
@@ -151,41 +153,29 @@ initSysTools top_dir
settingsStr <- readFile settingsFile
platformConstantsStr <- readFile platformConstantsFile
- mySettings <- case maybeReadFuzzy settingsStr of
+ 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)
- let getSetting key = case lookup key mySettings of
- Just xs -> return $ expandTopDir top_dir xs
- Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+ -- 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 key = case lookup key mySettings of
- Just "YES" -> return True
- Just "NO" -> return False
- Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)
- Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
- readSetting key = case lookup key mySettings of
- Just xs ->
- case maybeRead xs of
- Just v -> return v
- Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
- Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
- crossCompiling <- getBooleanSetting "cross compiling"
+ getBooleanSetting :: String -> IO Bool
+ getBooleanSetting key = either pgmError pure $
+ getBooleanSetting0 settingsFile mySettings key
targetPlatformString <- getSetting "target platform string"
- targetArch <- readSetting "target arch"
- targetOS <- readSetting "target os"
- targetWordSize <- readSetting "target word size"
- targetUnregisterised <- getBooleanSetting "Unregisterised"
- targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
- targetHasIdentDirective <- readSetting "target has .ident directive"
- targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
tablesNextToCode <- getBooleanSetting "Tables next to code"
myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
-- On Windows, mingw is distributed with GHC,
@@ -200,7 +190,10 @@ initSysTools top_dir
gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
cpp_prog <- getToolSetting "Haskell CPP command"
cpp_args_str <- getSetting "Haskell CPP flags"
- let unreg_cc_args = if targetUnregisterised
+
+ 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)
@@ -250,17 +243,6 @@ initSysTools top_dir
let iserv_prog = libexec "ghc-iserv"
- let platform = Platform {
- platformArch = targetArch,
- platformOS = targetOS,
- platformWordSize = targetWordSize,
- platformUnregisterised = targetUnregisterised,
- platformHasGnuNonexecStack = targetHasGnuNonexecStack,
- platformHasIdentDirective = targetHasIdentDirective,
- platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,
- platformIsCrossCompiling = crossCompiling
- }
-
integerLibrary <- getSetting "integer library"
integerLibraryType <- case integerLibrary of
"integer-gmp" -> pure IntegerGMP
@@ -358,7 +340,7 @@ initSysTools top_dir
, sPlatformConstants = platformConstants
- , sRawSettings = mySettings
+ , sRawSettings = settingsList
}
diff --git a/compiler/main/SysTools/BaseDir.hs b/compiler/main/SysTools/BaseDir.hs
index 1293d1898a2a..f67d2def6d7d 100644
--- a/compiler/main/SysTools/BaseDir.hs
+++ b/compiler/main/SysTools/BaseDir.hs
@@ -27,7 +27,6 @@ import Panic
import System.Environment (lookupEnv)
import System.FilePath
-import Data.List
-- Windows
#if defined(mingw32_HOST_OS)
@@ -76,10 +75,6 @@ $topdir/../../{mingw, perl}/.
-}
--- | Expand occurrences of the @$topdir@ interpolation in a string.
-expandTopDir :: FilePath -> String -> String
-expandTopDir = expandPathVar "topdir"
-
-- | Expand occurrences of the @$tooldir@ interpolation in a string
-- on Windows, leave the string untouched otherwise.
expandToolDir :: Maybe FilePath -> String -> String
@@ -90,17 +85,6 @@ expandToolDir Nothing _ = panic "Could not determine $tooldir"
expandToolDir _ s = s
#endif
--- | @expandPathVar var value str@
---
--- replaces occurences of variable @$var@ with @value@ in str.
-expandPathVar :: String -> FilePath -> String -> String
-expandPathVar var value str
- | Just str' <- stripPrefix ('$':var) str
- , null str' || isPathSeparator (head str')
- = value ++ expandPathVar var value str'
-expandPathVar var value (x:xs) = x : expandPathVar var value xs
-expandPathVar _ _ [] = []
-
-- | Returns a Unix-format path pointing to TopDir.
findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
-> IO String -- TopDir (in Unix format '/' separated)
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index 5770f2ffdcc2..aa4afa54513f 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -92,9 +92,6 @@ module Util (
readRational,
readHexRational,
- -- * read helpers
- maybeRead, maybeReadFuzzy,
-
-- * IO-ish utilities
doesDirNameExist,
getModificationUTCTime,
@@ -1254,25 +1251,6 @@ readHexRational__ ('0' : x : rest)
readHexRational__ _ = Nothing
-
-
-
------------------------------------------------------------------------------
--- read helpers
-
-maybeRead :: Read a => String -> Maybe a
-maybeRead str = case reads str of
- [(x, "")] -> Just x
- _ -> Nothing
-
-maybeReadFuzzy :: Read a => String -> Maybe a
-maybeReadFuzzy str = case reads str of
- [(x, s)]
- | all isSpace s ->
- Just x
- _ ->
- Nothing
-
-----------------------------------------------------------------------------
-- Verify that the 'dirname' portion of a FilePath exists.
--
diff --git a/libraries/ghc-boot/GHC/BaseDir.hs b/libraries/ghc-boot/GHC/BaseDir.hs
index cc8335514489..196ab2eb7205 100644
--- a/libraries/ghc-boot/GHC/BaseDir.hs
+++ b/libraries/ghc-boot/GHC/BaseDir.hs
@@ -14,8 +14,9 @@
-- and so needs the top dir location to do that too.
module GHC.BaseDir where
-import Prelude -- See note [Why do we import Prelude here?]
+import Prelude -- See Note [Why do we import Prelude here?]
+import Data.List
import System.FilePath
-- Windows
@@ -26,6 +27,21 @@ import System.Environment (getExecutablePath)
import System.Environment (getExecutablePath)
#endif
+-- | Expand occurrences of the @$topdir@ interpolation in a string.
+expandTopDir :: FilePath -> String -> String
+expandTopDir = expandPathVar "topdir"
+
+-- | @expandPathVar var value str@
+--
+-- replaces occurences of variable @$var@ with @value@ in str.
+expandPathVar :: String -> FilePath -> String -> String
+expandPathVar var value str
+ | Just str' <- stripPrefix ('$':var) str
+ , null str' || isPathSeparator (head str')
+ = value ++ expandPathVar var value str'
+expandPathVar var value (x:xs) = x : expandPathVar var value xs
+expandPathVar _ _ [] = []
+
-- | Calculate the location of the base dir
getBaseDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
diff --git a/libraries/ghc-boot/GHC/Settings.hs b/libraries/ghc-boot/GHC/Settings.hs
new file mode 100644
index 000000000000..fc9f95a58647
--- /dev/null
+++ b/libraries/ghc-boot/GHC/Settings.hs
@@ -0,0 +1,104 @@
+-- Note [Settings file]
+-- ~~~~~~~~~~~~~~~~~~~~
+--
+-- GHC has a file, `${top_dir}/settings`, which is the main source of run-time
+-- configuration. ghc-pkg needs just a little bit of it: the target platform CPU
+-- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is
+-- associated with the current version/target.
+--
+-- This module has just enough code to read key value pairs from the settings
+-- file, and read the target platform from those pairs.
+--
+-- The "0" suffix is because the caller will partially apply it, and that will
+-- in turn be used a few more times.
+module GHC.Settings where
+
+import Prelude -- See Note [Why do we import Prelude here?]
+
+import GHC.BaseDir
+import GHC.Platform
+
+import Data.Char (isSpace)
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+-----------------------------------------------------------------------------
+-- parts of settings file
+
+getTargetPlatform
+ :: FilePath -> RawSettings -> Either String Platform
+getTargetPlatform settingsFile mySettings = do
+ let
+ getBooleanSetting = getBooleanSetting0 settingsFile mySettings
+ readSetting :: (Show a, Read a) => String -> Either String a
+ readSetting = readSetting0 settingsFile mySettings
+
+ targetArch <- readSetting "target arch"
+ targetOS <- readSetting "target os"
+ targetWordSize <- readSetting "target word size"
+ targetUnregisterised <- getBooleanSetting "Unregisterised"
+ targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
+ targetHasIdentDirective <- readSetting "target has .ident directive"
+ targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
+ crossCompiling <- getBooleanSetting "cross compiling"
+
+ pure $ Platform
+ { platformArch = targetArch
+ , platformOS = targetOS
+ , platformWordSize = targetWordSize
+ , platformUnregisterised = targetUnregisterised
+ , platformHasGnuNonexecStack = targetHasGnuNonexecStack
+ , platformHasIdentDirective = targetHasIdentDirective
+ , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
+ , platformIsCrossCompiling = crossCompiling
+ }
+
+-----------------------------------------------------------------------------
+-- settings file helpers
+
+type RawSettings = Map String String
+
+-- | See Note [Settings file] for "0" suffix
+getSetting0
+ :: FilePath -> RawSettings -> String -> Either String String
+getSetting0 settingsFile mySettings key = case Map.lookup key mySettings of
+ Just xs -> Right xs
+ Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile
+
+-- | See Note [Settings file] for "0" suffix
+getFilePathSetting0
+ :: FilePath -> FilePath -> RawSettings -> String -> Either String String
+getFilePathSetting0 top_dir settingsFile mySettings key =
+ expandTopDir top_dir <$> getSetting0 settingsFile mySettings key
+
+-- | See Note [Settings file] for "0" suffix
+getBooleanSetting0
+ :: FilePath -> RawSettings -> String -> Either String Bool
+getBooleanSetting0 settingsFile mySettings key = do
+ rawValue <- getSetting0 settingsFile mySettings key
+ case rawValue of
+ "YES" -> Right True
+ "NO" -> Right False
+ xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs
+
+-- | See Note [Settings file] for "0" suffix
+readSetting0
+ :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a
+readSetting0 settingsFile mySettings key = case Map.lookup key mySettings of
+ Just xs -> case maybeRead xs of
+ Just v -> Right v
+ Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs
+ Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile
+
+-----------------------------------------------------------------------------
+-- read helpers
+
+maybeRead :: Read a => String -> Maybe a
+maybeRead str = case reads str of
+ [(x, "")] -> Just x
+ _ -> Nothing
+
+maybeReadFuzzy :: Read a => String -> Maybe a
+maybeReadFuzzy str = case reads str of
+ [(x, s)] | all isSpace s -> Just x
+ _ -> Nothing
diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in
index 15721b1489a9..650f7518dc42 100644
--- a/libraries/ghc-boot/ghc-boot.cabal.in
+++ b/libraries/ghc-boot/ghc-boot.cabal.in
@@ -44,10 +44,12 @@ Library
GHC.ForeignSrcLang
GHC.HandleEncoding
GHC.Platform
+ GHC.Settings
build-depends: base >= 4.7 && < 4.14,
binary == 0.8.*,
bytestring == 0.10.*,
+ containers >= 0.5 && < 0.7,
directory >= 1.2 && < 1.4,
filepath >= 1.3 && < 1.5,
ghc-boot-th == @ProjectVersionMunged@
diff --git a/testsuite/tests/driver/T3007/Makefile b/testsuite/tests/driver/T3007/Makefile
index 52b3331af1eb..e946350d45cd 100644
--- a/testsuite/tests/driver/T3007/Makefile
+++ b/testsuite/tests/driver/T3007/Makefile
@@ -8,14 +8,16 @@ clean:
rm -rf A/dist B/dist
rm -rf package.conf
+# --no-user-package-db to avoid warning about missing settings file
+
T3007:
$(MAKE) -s --no-print-directory clean
'$(GHC_PKG)' init package.conf
cd A && '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup
- cd A && ./Setup configure -v0 --with-compiler='$(TEST_HC)' --ghc-pkg-option=--global-package-db=../package.conf --ghc-option=-package-db../package.conf
+ cd A && ./Setup configure -v0 --with-compiler='$(TEST_HC)' --ghc-pkg-option=--global-package-db=../package.conf --ghc-pkg-option=--no-user-package-db --ghc-option=-package-db../package.conf
cd A && ./Setup build -v0
cd A && ./Setup register --inplace -v0
cd B && '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup
- cd B && ./Setup configure -v0 --with-compiler='$(TEST_HC)' --ghc-pkg-option=--global-package-db=../package.conf --ghc-option=-package-db../package.conf
+ cd B && ./Setup configure -v0 --with-compiler='$(TEST_HC)' --ghc-pkg-option=--global-package-db=../package.conf --ghc-pkg-option=--no-user-package-db --ghc-option=-package-db../package.conf
cd B && ./Setup build -v0
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 02ac7d22d90c..0e28ce93533a 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -17,6 +17,9 @@
#endif
#endif
+-- Fine if this comes from make/Hadrian or the pre-built base.
+#include <ghcplatform.h>
+
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2009.
@@ -27,11 +30,16 @@
module Main (main) where
-import Version ( version, targetOS, targetARCH )
+import Version ( version )
import qualified GHC.PackageDb as GhcPkg
import GHC.PackageDb (BinaryStringRep(..))
import GHC.HandleEncoding
import GHC.BaseDir (getBaseDir)
+import GHC.Settings (getTargetPlatform, maybeReadFuzzy)
+import GHC.Platform
+ ( platformArch, platformOS
+ , stringEncodeArch, stringEncodeOS
+ )
import qualified Distribution.Simple.PackageIndex as PackageIndex
import qualified Data.Graph as Graph
import qualified Distribution.ModuleName as ModuleName
@@ -592,14 +600,14 @@ getPkgDatabases :: Verbosity
-- commands that just read the DB, such as 'list'.
getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
- -- first we determine the location of the global package config. On Windows,
+ -- Second we determine the location of the global package config. On Windows,
-- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
-- 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 <-
case [ f | FlagGlobalConfig f <- my_flags ] of
- -- See note [Base Dir] for more information on the base dir / top dir.
+ -- 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
@@ -628,7 +636,25 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
[] -> case e_appdir of
Left _ -> return Nothing
Right appdir -> do
- let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
+ -- See Note [Settings File] about this file, and why we need GHC to share it with us.
+ let settingsFile = top_dir </> "settings"
+ exists_settings_file <- doesFileExist settingsFile
+ (arch, os) <- case exists_settings_file of
+ False -> do
+ warn $ "WARNING: settings file doesn't exist " ++ show settingsFile
+ warn "cannot know target platform so guessing target == host (native compiler)."
+ pure (HOST_ARCH, HOST_OS)
+ 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 getTargetPlatform settingsFile mySettings of
+ Right platform -> pure (stringEncodeArch $ platformArch platform, stringEncodeOS $ platformOS platform)
+ Left e -> die e
+ let subdir = arch ++ '-':os ++ '-':Version.version
dir = appdir </> subdir
r <- lookForPackageDBIn dir
case r of
diff --git a/utils/ghc-pkg/ghc.mk b/utils/ghc-pkg/ghc.mk
index a063e0b78737..37ce0a7c5bb5 100644
--- a/utils/ghc-pkg/ghc.mk
+++ b/utils/ghc-pkg/ghc.mk
@@ -69,7 +69,10 @@ endif
$(eval $(call build-prog,utils/ghc-pkg,dist,0))
-$(ghc-pkg_INPLACE) : | $(INPLACE_PACKAGE_CONF)/.
+# ghc-pkg uses `settings` to figure out the target platform to figure out a
+# subdirectory for the user pkg db. So make sure `settings` exists (alterative
+# is to specify global package db only.
+$(ghc-pkg_INPLACE) : | $(INPLACE_PACKAGE_CONF)/. $(INPLACE_LIB)/settings
utils/ghc-pkg/dist/package-data.mk: \
utils/ghc-pkg/dist/build/Version.hs
--
GitLab