Factor out a smaller part of Platform for host fallback

13 files changed, 115 insertions, 39 deletions

diff --git a/aclocal.m4 b/aclocal.m4
index 6b96a7c084..e3abb07202 100644
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -372,12 +372,14 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
 
     checkArch "$HostArch" "HaskellHostArch"
     checkVendor "$HostVendor"
-    checkOS "$HostOS" ""
+    checkOS "$HostOS" "HaskellHostOs"
 
     checkArch "$TargetArch" "HaskellTargetArch"
     checkVendor "$TargetVendor"
     checkOS "$TargetOS" "HaskellTargetOs"
 
+    AC_SUBST(HaskellHostArch)
+    AC_SUBST(HaskellHostOs)
     AC_SUBST(HaskellTargetArch)
     AC_SUBST(HaskellTargetOs)
     AC_SUBST(TargetHasSubsectionsViaSymbols)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 18eb1a93b9..9e9e70ad28 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1512,7 +1512,7 @@ versionedAppDir dflags = do
   return $ appdir </> versionedFilePath dflags
 
 versionedFilePath :: DynFlags -> FilePath
-versionedFilePath dflags = uniqueSubdir $ targetPlatform dflags
+versionedFilePath dflags = uniqueSubdir $ platformMini $ targetPlatform dflags
 
 -- | The target code type of the compilation (if any).
 --
diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs
index 9c57a0292f..7ea68e1105 100644
--- a/compiler/nativeGen/PIC.hs
+++ b/compiler/nativeGen/PIC.hs
@@ -565,7 +565,7 @@ pprGotDeclaration _ _ _
 --
 
 pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc
-pprImportedSymbol dflags (Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl
+pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_arch = ArchX86, platformMini_os = OSDarwin } }) importedLbl
         | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
         = case positionIndependent dflags of
            False ->
@@ -618,7 +618,7 @@ pprImportedSymbol dflags (Platform { platformArch = ArchX86, platformOS = OSDarw
         = empty
 
 
-pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _
+pprImportedSymbol _ (Platform { platformMini = PlatformMini { platformMini_os = OSDarwin } }) _
         = empty
 
 -- XCOFF / AIX
@@ -632,7 +632,7 @@ pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _
 --
 -- NB: No DSO-support yet
 
-pprImportedSymbol dflags (Platform { platformOS = OSAIX }) importedLbl
+pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_os = OSAIX } }) importedLbl
         = case dynamicLinkerLabelInfo importedLbl of
             Just (SymbolPtr, lbl)
               -> vcat [
@@ -669,7 +669,7 @@ pprImportedSymbol dflags (Platform { platformOS = OSAIX }) importedLbl
 -- the NCG will keep track of all DynamicLinkerLabels it uses
 -- and output each of them using pprImportedSymbol.
 
-pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC_64 _ })
+pprImportedSymbol dflags platform@(Platform { platformMini = PlatformMini { platformMini_arch = ArchPPC_64 _ } })
                   importedLbl
         | osElfTarget (platformOS platform)
         = case dynamicLinkerLabelInfo importedLbl of
diff --git a/hadrian/cfg/system.config.in b/hadrian/cfg/system.config.in
index 35ba2c4052..5d6d28d5f4 100644
--- a/hadrian/cfg/system.config.in
+++ b/hadrian/cfg/system.config.in
@@ -60,12 +60,16 @@ host-platform         = @HostPlatform@
 host-arch             = @HostArch_CPP@
 host-os               = @HostOS_CPP@
 host-vendor           = @HostVendor_CPP@
+host-os-haskell       = @HaskellHostOs@
+host-arch-haskell     = @HaskellHostArch@
 
 target-platform       = @TargetPlatform@
 target-platform-full  = @TargetPlatformFull@
 target-arch           = @TargetArch_CPP@
 target-os             = @TargetOS_CPP@
 target-vendor         = @TargetVendor_CPP@
+target-os-haskell     = @HaskellTargetOs@
+target-arch-haskell   = @HaskellTargetArch@
 llvm-target           = @LLVMTarget_CPP@
 
 cross-compiling       = @CrossCompiling@
@@ -143,8 +147,6 @@ settings-clang-command = @SettingsClangCommand@
 settings-llc-command = @SettingsLlcCommand@
 settings-opt-command = @SettingsOptCommand@
 
-haskell-target-os = @HaskellTargetOs@
-haskell-target-arch = @HaskellTargetArch@
 target-word-size = @TargetWordSize@
 target-has-gnu-nonexec-stack = @TargetHasGnuNonexecStack@
 target-has-ident-directive = @TargetHasIdentDirective@
diff --git a/hadrian/src/Oracles/Setting.hs b/hadrian/src/Oracles/Setting.hs
index 51ccc729a3..2a4f5d0572 100644
--- a/hadrian/src/Oracles/Setting.hs
+++ b/hadrian/src/Oracles/Setting.hs
@@ -42,6 +42,8 @@ data Setting = BuildArch
              | HostOs
              | HostPlatform
              | HostVendor
+             | HostArchHaskell
+             | HostOsHaskell
              | IconvIncludeDir
              | IconvLibDir
              | LlvmTarget
@@ -58,6 +60,8 @@ data Setting = BuildArch
              | TargetPlatform
              | TargetPlatformFull
              | TargetVendor
+             | TargetArchHaskell
+             | TargetOsHaskell
 
 -- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions).
 -- | Each 'SettingList' comes from the file @hadrian/cfg/system.config@,
@@ -126,6 +130,8 @@ setting key = lookupValueOrError configFile $ case key of
     HostOs             -> "host-os"
     HostPlatform       -> "host-platform"
     HostVendor         -> "host-vendor"
+    HostArchHaskell    -> "host-arch-haskell"
+    HostOsHaskell      -> "host-os-haskell"
     IconvIncludeDir    -> "iconv-include-dir"
     IconvLibDir        -> "iconv-lib-dir"
     LlvmTarget         -> "llvm-target"
@@ -142,6 +148,8 @@ setting key = lookupValueOrError configFile $ case key of
     TargetPlatform     -> "target-platform"
     TargetPlatformFull -> "target-platform-full"
     TargetVendor       -> "target-vendor"
+    TargetArchHaskell  -> "target-arch-haskell"
+    TargetOsHaskell    -> "target-os-haskell"
 
 -- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the
 -- result.
diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs
index f20f815da4..4afdc0cdae 100644
--- a/hadrian/src/Rules/Generate.hs
+++ b/hadrian/src/Rules/Generate.hs
@@ -119,8 +119,9 @@ generatePackageCode context@(Context stage pkg _) = do
         when (pkg == ghcPrim) $ do
             root -/- "**" -/- dir -/- "GHC/Prim.hs" %> genPrimopCode context
             root -/- "**" -/- dir -/- "GHC/PrimopWrappers.hs" %> genPrimopCode context
-        when (pkg == ghcBoot) $
+        when (pkg == ghcBoot) $ do
             root -/- "**" -/- dir -/- "GHC/Version.hs" %> go generateVersionHs
+            root -/- "**" -/- dir -/- "GHC/Platform/Host.hs" %> go generatePlatformHostHs
 
     when (pkg == compiler) $ do
         root -/- primopsTxt stage %> \file -> do
@@ -296,8 +297,8 @@ generateSettings = do
         , ("unlit command", ("$topdir/bin/" <>) <$> expr (programName (ctx { Context.package = unlit })))
         , ("cross compiling", expr $ yesNo <$> flag CrossCompiling)
         , ("target platform string", getSetting TargetPlatform)
-        , ("target os", expr $ lookupValueOrError configFile "haskell-target-os")
-        , ("target arch", expr $ lookupValueOrError configFile "haskell-target-arch")
+        , ("target os", getSetting TargetOsHaskell)
+        , ("target arch", getSetting TargetArchHaskell)
         , ("target word size", expr $ lookupValueOrError configFile "target-word-size")
         , ("target has GNU nonexec stack", expr $ lookupValueOrError configFile "target-has-gnu-nonexec-stack")
         , ("target has .ident directive", expr $ lookupValueOrError configFile "target-has-ident-directive")
@@ -461,3 +462,27 @@ generateVersionHs = do
         , "cProjectPatchLevel2   :: String"
         , "cProjectPatchLevel2   = " ++ show cProjectPatchLevel2
         ]
+
+-- | Generate @Platform/Host.hs@ files.
+generatePlatformHostHs :: Expr String
+generatePlatformHostHs = do
+    trackGenerateHs
+    cHostPlatformArch <- getSetting HostArchHaskell
+    cHostPlatformOS   <- getSetting HostOsHaskell
+    return $ unlines
+        [ "module GHC.Platform.Host where"
+        , ""
+        , "import GHC.Platform"
+        , ""
+        , "cHostPlatformArch :: Arch"
+        , "cHostPlatformArch = " ++ cHostPlatformArch
+        , ""
+        , "cHostPlatformOS   :: OS"
+        , "cHostPlatformOS   = " ++ cHostPlatformOS
+        , ""
+        , "cHostPlatformMini :: PlatformMini"
+        , "cHostPlatformMini = PlatformMini"
+        , "  { platformMini_arch = cHostPlatformArch"
+        , "  , platformMini_os = cHostPlatformOS"
+        , "  }"
+        ]
diff --git a/libraries/ghc-boot/GHC/Platform.hs b/libraries/ghc-boot/GHC/Platform.hs
index 7eec31a9fe..8e4ae5f4b9 100644
--- a/libraries/ghc-boot/GHC/Platform.hs
+++ b/libraries/ghc-boot/GHC/Platform.hs
@@ -3,8 +3,9 @@
 -- | A description of the platform we're compiling for.
 --
 module GHC.Platform (
-        Platform(..),
+        PlatformMini(..),
         PlatformWordSize(..),
+        Platform(..), platformArch, platformOS,
         Arch(..),
         OS(..),
         ArmISA(..),
@@ -33,12 +34,21 @@ where
 import Prelude -- See Note [Why do we import Prelude here?]
 import GHC.Read
 
+-- | Contains the bare-bones arch and os information. This isn't enough for
+-- code gen, but useful for tasks where we can fall back upon the host
+-- platform, as this is all we know about the host platform.
+data PlatformMini
+  = PlatformMini
+    { platformMini_arch :: Arch
+    , platformMini_os :: OS
+    }
+    deriving (Read, Show, Eq)
+
 -- | Contains enough information for the native code generator to emit
 --      code for this platform.
 data Platform
         = Platform {
-              platformArch                     :: Arch,
-              platformOS                       :: OS,
+              platformMini                     :: PlatformMini,
               -- Word size in bytes (i.e. normally 4 or 8,
               -- for 32bit and 64bit platforms respectively)
               platformWordSize                 :: PlatformWordSize,
@@ -76,6 +86,14 @@ platformWordSizeInBytes p =
 platformWordSizeInBits :: Platform -> Int
 platformWordSizeInBits p = platformWordSizeInBytes p * 8
 
+-- | Legacy accessor
+platformArch :: Platform -> Arch
+platformArch = platformMini_arch . platformMini
+
+-- | Legacy accessor
+platformOS :: Platform -> OS
+platformOS = platformMini_os . platformMini
+
 -- | Architectures that the native code generator knows about.
 --      TODO: It might be nice to extend these constructors with information
 --      about what instruction set extensions an architecture might support.
diff --git a/libraries/ghc-boot/GHC/Settings.hs b/libraries/ghc-boot/GHC/Settings.hs
index a112c5d739..96680dc58e 100644
--- a/libraries/ghc-boot/GHC/Settings.hs
+++ b/libraries/ghc-boot/GHC/Settings.hs
@@ -43,8 +43,10 @@ getTargetPlatform settingsFile mySettings = do
   crossCompiling <- getBooleanSetting "cross compiling"
 
   pure $ Platform
-    { platformArch = targetArch
-    , platformOS   = targetOS
+    { platformMini = PlatformMini
+      { platformMini_arch = targetArch
+      , platformMini_os = targetOS
+      }
     , platformWordSize = targetWordSize
     , platformUnregisterised = targetUnregisterised
     , platformHasGnuNonexecStack = targetHasGnuNonexecStack
diff --git a/libraries/ghc-boot/GHC/UniqueSubdir.hs b/libraries/ghc-boot/GHC/UniqueSubdir.hs
index 49ae05e526..b59fdc43ce 100644
--- a/libraries/ghc-boot/GHC/UniqueSubdir.hs
+++ b/libraries/ghc-boot/GHC/UniqueSubdir.hs
@@ -1,6 +1,5 @@
 module GHC.UniqueSubdir
   ( uniqueSubdir
-  , uniqueSubdir0
   ) where
 
 import Prelude -- See Note [Why do we import Prelude here?]
@@ -13,18 +12,13 @@ import GHC.Version (cProjectVersion)
 -- | A filepath like @x86_64-linux-7.6.3@ with the platform string to use when
 -- constructing platform-version-dependent files that need to co-exist.
 --
-uniqueSubdir :: Platform -> FilePath
-uniqueSubdir platform = uniqueSubdir0
-  (stringEncodeArch $ platformArch platform)
-  (stringEncodeOS $ platformOS platform)
-
--- | 'ghc-pkg' falls back on the host platform if the settings file is missing,
+-- 'ghc-pkg' falls back on the host platform if the settings file is missing,
 -- and so needs this since we don't have information about the host platform in
--- as much detail as 'Platform'.
-uniqueSubdir0 :: String -> String -> FilePath
-uniqueSubdir0 arch os = intercalate "-"
-  [ arch
-  , os
+-- as much detail as 'Platform', so we use 'PlatformMini' instead.
+uniqueSubdir :: PlatformMini -> FilePath
+uniqueSubdir archOs = intercalate "-"
+  [ stringEncodeArch $ platformMini_arch archOs
+  , stringEncodeOS $ platformMini_os archOs
   , cProjectVersion
   ]
   -- NB: This functionality is reimplemented in Cabal, so if you
diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in
index aed75b0c8a..f986810b6b 100644
--- a/libraries/ghc-boot/ghc-boot.cabal.in
+++ b/libraries/ghc-boot/ghc-boot.cabal.in
@@ -44,6 +44,7 @@ Library
             GHC.ForeignSrcLang
             GHC.HandleEncoding
             GHC.Platform
+            GHC.Platform.Host
             GHC.Settings
             GHC.UniqueSubdir
             GHC.Version
@@ -51,6 +52,7 @@ Library
     -- but done by Hadrian
     -- autogen-modules:
     --         GHC.Version
+    --         GHC.Platform.Host
 
     build-depends: base       >= 4.7 && < 4.14,
                    binary     == 0.8.*,
diff --git a/libraries/ghc-boot/ghc.mk b/libraries/ghc-boot/ghc.mk
index 29c5376560..9c5d695d8c 100644
--- a/libraries/ghc-boot/ghc.mk
+++ b/libraries/ghc-boot/ghc.mk
@@ -34,3 +34,28 @@ libraries/ghc-boot/dist-boot/package-data.mk: \
 	libraries/ghc-boot/dist-boot/build/GHC/Version.hs
 libraries/ghc-boot/dist-install/package-data.mk: \
 	libraries/ghc-boot/dist-install/build/GHC/Version.hs
+
+libraries/ghc-boot/dist-boot/build/GHC/Platform/Host.hs \
+libraries/ghc-boot/dist-install/build/GHC/Platform/Host.hs: mk/project.mk | $$(dir $$@)/.
+	$(call removeFiles,$@)
+	@echo "module GHC.Platform.Host where"                              >> $@
+	@echo                                                               >> $@
+	@echo 'import GHC.Platform'                                         >> $@
+	@echo                                                               >> $@
+	@echo 'cHostPlatformArch   :: Arch'                                 >> $@
+	@echo 'cHostPlatformArch   = $(HaskellHostArch)'                    >> $@
+	@echo                                                               >> $@
+	@echo 'cHostPlatformOS     :: OS'                                   >> $@
+	@echo 'cHostPlatformOS     = $(HaskellHostOs)'                      >> $@
+	@echo                                                               >> $@
+	@echo 'cHostPlatformMini :: PlatformMini'                           >> $@
+	@echo 'cHostPlatformMini = PlatformMini'                            >> $@
+	@echo '  { platformMini_arch = cHostPlatformArch'                   >> $@
+	@echo '  , platformMini_os = cHostPlatformOS'                       >> $@
+	@echo '  }'                                                         >> $@
+	@echo done.
+
+libraries/ghc-boot/dist-boot/package-data.mk: \
+	libraries/ghc-boot/dist-boot/build/GHC/Platform/Host.hs
+libraries/ghc-boot/dist-install/package-data.mk: \
+	libraries/ghc-boot/dist-install/build/GHC/Platform/Host.hs
diff --git a/mk/config.mk.in b/mk/config.mk.in
index 0f4208efc0..3bfc17f4b2 100644
--- a/mk/config.mk.in
+++ b/mk/config.mk.in
@@ -486,6 +486,8 @@ GHC_PACKAGE_DB_FLAG = @GHC_PACKAGE_DB_FLAG@
 GccExtraViaCOpts = @GccExtraViaCOpts@
 LdHasFilelist = @LdHasFilelist@
 ArArgs = @ArArgs@
+HaskellHostOs = @HaskellHostOs@
+HaskellHostArch = @HaskellHostArch@
 HaskellTargetOs = @HaskellTargetOs@
 HaskellTargetArch = @HaskellTargetArch@
 TargetWordSize = @TargetWordSize@
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 3f6c5bea3f..946ae72007 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -35,13 +35,9 @@ import GHC.PackageDb (BinaryStringRep(..))
 import GHC.HandleEncoding
 import GHC.BaseDir (getBaseDir)
 import GHC.Settings (getTargetPlatform, maybeReadFuzzy)
-import GHC.Platform
-  ( platformArch, platformOS
-  , stringEncodeArch, stringEncodeOS
-  )
-import GHC.UniqueSubdir
-  ( uniqueSubdir0
-  )
+import GHC.Platform (platformMini)
+import GHC.Platform.Host (cHostPlatformMini)
+import GHC.UniqueSubdir (uniqueSubdir)
 import GHC.Version ( cProjectVersion )
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 import qualified Data.Graph as Graph
@@ -642,11 +638,11 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
           -- 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
+          targetPlatformMini <- 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)
+              pure cHostPlatformMini
             True -> do
               settingsStr <- readFile settingsFile
               mySettings <- case maybeReadFuzzy settingsStr of
@@ -655,9 +651,9 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
                 -- 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)
+                Right platform -> pure $ platformMini platform
                 Left e -> die e
-          let subdir = uniqueSubdir0 arch os
+          let subdir = uniqueSubdir targetPlatformMini
               dir = appdir </> subdir
           r <- lookForPackageDBIn dir
           case r of