ghc-pkg needs settings file to un-hardcode target platform

This matches GHC itself getting the target platform from there.

10 files changed, 182 insertions, 84 deletions

diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs
index 6c72dca034..61e3d01d0e 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 5ab8805132..518d9fdb2f 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 1293d1898a..f67d2def6d 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 5770f2ffdc..aa4afa5451 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 cc83355144..196ab2eb72 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 0000000000..fc9f95a586
--- /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 15721b1489..650f7518dc 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 52b3331af1..e946350d45 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 02ac7d22d9..0e28ce9353 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 a063e0b787..37ce0a7c5b 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