ghc-toolchain library and usage in hadrian flags

9 files changed, 148 insertions, 33 deletions

diff --git a/hadrian/cabal.project b/hadrian/cabal.project
index fed4aa0540..c2853bdf96 100644
--- a/hadrian/cabal.project
+++ b/hadrian/cabal.project
@@ -1,4 +1,5 @@
 packages: ./
+          ../utils/ghc-toolchain/
 
 -- This essentially freezes the build plan for hadrian
 index-state: 2023-03-30T10:00:00Z
diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal
index 2311e9601f..82b1336381 100644
--- a/hadrian/hadrian.cabal
+++ b/hadrian/hadrian.cabal
@@ -166,6 +166,7 @@ executable hadrian
                        , text                 >= 1.2     && < 3
                        , cryptohash-sha256    >= 0.11    && < 0.12
                        , base16-bytestring    >= 0.1.1 && < 1.1.0.0
+                       , ghc-toolchain
     ghc-options:       -Wall
                        -Wincomplete-record-updates
                        -Wredundant-constraints
diff --git a/hadrian/src/Base.hs b/hadrian/src/Base.hs
index 623a5bae8b..b06572b684 100644
--- a/hadrian/src/Base.hs
+++ b/hadrian/src/Base.hs
@@ -31,6 +31,7 @@ module Base (
     -- * Paths
     hadrianPath, configPath, configFile, sourcePath, shakeFilesDir,
     stageBinPath, stageLibPath, templateHscPath,
+    hostTargetFile, targetTargetFile,
     ghcBinDeps, ghcLibDeps, haddockDeps,
     relativePackageDbPath, packageDbPath, packageDbStamp, mingwStamp,
     systemCxxStdLibConf, systemCxxStdLibConfPath
@@ -79,6 +80,16 @@ configPath = hadrianPath -/- "cfg"
 configFile :: FilePath
 configFile = configPath -/- "system.config"
 
+-- | The target configuration file generated by ghc-toolchain for the
+-- compilation host
+hostTargetFile :: FilePath
+hostTargetFile = "default.target" -- ROMES:TODO: Not hardcode this value?
+
+-- | The target configuration file generated by ghc-toolchain for the
+-- compilation target
+targetTargetFile :: FilePath
+targetTargetFile = "default.target" -- ROMES:TODO: Not hardcode this value, depends on target
+
 -- | Path to source files of the build system, e.g. this file is located at
 -- @sourcePath -/- "Base.hs"@. We use this to track some of the source files.
 sourcePath :: FilePath
diff --git a/hadrian/src/Hadrian/Oracles/TextFile.hs b/hadrian/src/Hadrian/Oracles/TextFile.hs
index 560d5d607a..a531fe5041 100644
--- a/hadrian/src/Hadrian/Oracles/TextFile.hs
+++ b/hadrian/src/Hadrian/Oracles/TextFile.hs
@@ -12,7 +12,8 @@
 -----------------------------------------------------------------------------
 module Hadrian.Oracles.TextFile (
     lookupValue, lookupValueOrEmpty, lookupValueOrError, lookupSystemConfig, lookupValues,
-    lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies, textFileOracle
+    lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies, textFileOracle,
+    getHostTargetConfig, getTargetTargetConfig
     ) where
 
 import Control.Monad
@@ -24,6 +25,8 @@ import Development.Shake.Classes
 import Development.Shake.Config
 import Base
 
+import qualified GHC.Toolchain.Target as Toolchain
+
 -- | Lookup a value in a text file, tracking the result. Each line of the file
 -- is expected to have @key = value@ format.
 lookupValue :: FilePath -> String -> Action (Maybe String)
@@ -79,6 +82,21 @@ lookupDependencies depFile file = do
         Just [] -> error $ "No source file found for file " ++ quote file
         Just (source : files) -> return (source, files)
 
+-- | Parse a target from a text file, tracking the result. The file is expected
+-- to contain a parseable Toolchain.Target value generated by ghc-toolchain.
+getTargetConfig :: FilePath -> Action Toolchain.Target
+getTargetConfig file = askOracle $ TargetFile file
+
+-- | Get the host's target configuration through 'getTarget'
+getHostTargetConfig :: Action Toolchain.Target
+getHostTargetConfig = getTargetConfig hostTargetFile
+  -- where
+  --   msg = "The host's target configuration file " ++ quote hostTargetFile ++ " does not exist! ghc-toolchain might have failed to generate it."
+
+-- | Get the target's target configuration through 'getTarget'
+getTargetTargetConfig :: Action Toolchain.Target
+getTargetTargetConfig = getTargetConfig targetTargetFile
+
 newtype KeyValue = KeyValue (FilePath, String)
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
 type instance RuleResult KeyValue = Maybe String
@@ -87,6 +105,10 @@ newtype KeyValues = KeyValues (FilePath, String)
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
 type instance RuleResult KeyValues = Maybe [String]
 
+newtype TargetFile = TargetFile FilePath
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult TargetFile = Toolchain.Target
+
 -- | These oracle rules are used to cache and track answers to the following
 -- queries, which are implemented by parsing text files:
 --
@@ -97,6 +119,10 @@ type instance RuleResult KeyValues = Maybe [String]
 --
 -- 2) Parsing Makefile dependency files generated by commands like @gcc -MM@:
 --    see 'lookupDependencies'.
+--
+-- 3) Parsing target files as generated by ghc-toolchain. See functions
+--    'lookupTarget' and lookupTargetConfig'
+--
 textFileOracle :: Rules ()
 textFileOracle = do
     kv <- newCache $ \file -> do
@@ -111,3 +137,27 @@ textFileOracle = do
         contents <- map words <$> readFileLines file
         return $ Map.fromList [ (key, values) | (key:values) <- contents ]
     void $ addOracleCache $ \(KeyValues (file, key)) -> Map.lookup key <$> kvs file
+
+    tf <- newCache $ \file -> do
+        need [file]
+        putVerbose $ "| TargetFile oracle: reading " ++ quote file ++ "..."
+        target <- read <$> readFile' file
+        return (target :: Toolchain.Target)
+    void $ addOracle $ \(TargetFile file) -> tf file
+
+-- ROMES:TODO: get back to this!!!!!!
+instance Eq Toolchain.Target where
+  (==) _ _ = True
+
+instance Ord Toolchain.Target where
+  (<=) _ _ = False
+instance Hashable Toolchain.Target where
+  hashWithSalt _ _ = 0
+instance Binary Toolchain.Target where
+  put _ = undefined
+  get   = undefined
+
+instance NFData Toolchain.Target where
+  rnf _ = ()
+
+
diff --git a/hadrian/src/Oracles/Flag.hs b/hadrian/src/Oracles/Flag.hs
index f10f8e0c4f..1e4ff59fc2 100644
--- a/hadrian/src/Oracles/Flag.hs
+++ b/hadrian/src/Oracles/Flag.hs
@@ -17,6 +17,9 @@ import Hadrian.Expression
 import Base
 import Oracles.Setting
 
+import GHC.Toolchain.Target (Target(..))
+import qualified GHC.Toolchain as Toolchain
+
 data Flag = ArSupportsAtFile
           | ArSupportsDashL
           | SystemArSupportsAtFile
@@ -44,38 +47,50 @@ data Flag = ArSupportsAtFile
           | UseLibpthread
           | NeedLibatomic
 
+data FlagKey = SystemConfigKey String
+              | HostTargetKey (Toolchain.Target -> Bool)
+              | TargetTargetKey (Toolchain.Target -> Bool)
+
 -- Note, if a flag is set to empty string we treat it as set to NO. This seems
 -- fragile, but some flags do behave like this.
 flag :: Flag -> Action Bool
 flag f = do
-    let key = case f of
-            ArSupportsAtFile     -> "ar-supports-at-file"
-            ArSupportsDashL      -> "ar-supports-dash-l"
-            SystemArSupportsAtFile-> "system-ar-supports-at-file"
-            SystemArSupportsDashL-> "system-ar-supports-dash-l"
-            CrossCompiling       -> "cross-compiling"
-            CcLlvmBackend        -> "cc-llvm-backend"
-            GhcUnregisterised    -> "ghc-unregisterised"
-            TablesNextToCode     -> "tables-next-to-code"
-            GmpInTree            -> "intree-gmp"
-            GmpFrameworkPref     -> "gmp-framework-preferred"
-            LeadingUnderscore    -> "leading-underscore"
-            UseSystemFfi         -> "use-system-ffi"
-            BootstrapThreadedRts -> "bootstrap-threaded-rts"
-            BootstrapEventLoggingRts -> "bootstrap-event-logging-rts"
-            UseLibffiForAdjustors -> "use-libffi-for-adjustors"
-            UseLibdw             -> "use-lib-dw"
-            UseLibnuma           -> "use-lib-numa"
-            UseLibm              -> "use-lib-m"
-            UseLibrt             -> "use-lib-rt"
-            UseLibdl             -> "use-lib-dl"
-            UseLibbfd            -> "use-lib-bfd"
-            UseLibpthread        -> "use-lib-pthread"
-            NeedLibatomic        -> "need-libatomic"
-    value <- lookupSystemConfig key
-    when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag "
-        ++ quote (key ++ " = " ++ value) ++ " cannot be parsed."
-    return $ value == "YES"
+    let flagkey :: FlagKey = case f of
+            ArSupportsAtFile     -> TargetTargetKey (Toolchain.arSupportsAtFile . tgtAr)
+            ArSupportsDashL      -> TargetTargetKey (Toolchain.arSupportsDashL  . tgtAr)
+            SystemArSupportsAtFile-> HostTargetKey  (Toolchain.arSupportsAtFile . tgtAr)
+            SystemArSupportsDashL-> HostTargetKey   (Toolchain.arSupportsDashL  . tgtAr)
+            CrossCompiling       -> SystemConfigKey "cross-compiling"
+            CcLlvmBackend        -> SystemConfigKey "cc-llvm-backend"
+            GhcUnregisterised    -> TargetTargetKey tgtUnregisterised
+            TablesNextToCode     -> TargetTargetKey tgtTablesNextToCode
+            GmpInTree            -> SystemConfigKey "intree-gmp"
+            GmpFrameworkPref     -> SystemConfigKey "gmp-framework-preferred"
+            LeadingUnderscore    -> TargetTargetKey tgtSymbolsHaveLeadingUnderscore
+            UseSystemFfi         -> SystemConfigKey "use-system-ffi"
+            BootstrapThreadedRts -> SystemConfigKey "bootstrap-threaded-rts"
+            BootstrapEventLoggingRts -> SystemConfigKey "bootstrap-event-logging-rts"
+            UseLibffiForAdjustors -> SystemConfigKey "use-libffi-for-adjustors"
+            UseLibdw             -> SystemConfigKey "use-lib-dw"
+            UseLibnuma           -> SystemConfigKey "use-lib-numa"
+            UseLibm              -> SystemConfigKey "use-lib-m"
+            UseLibrt             -> SystemConfigKey "use-lib-rt"
+            UseLibdl             -> SystemConfigKey "use-lib-dl"
+            UseLibbfd            -> SystemConfigKey "use-lib-bfd"
+            UseLibpthread        -> SystemConfigKey "use-lib-pthread"
+            NeedLibatomic        -> SystemConfigKey "need-libatomic"
+    case flagkey of
+      SystemConfigKey key -> do
+        value <- lookupSystemConfig key
+        when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag "
+            ++ quote (key ++ " = " ++ value) ++ " cannot be parsed."
+        return $ value == "YES"
+      HostTargetKey key -> do
+        value <- key <$> getHostTargetConfig
+        return value
+      TargetTargetKey key -> do
+        value <- key <$> getTargetTargetConfig
+        return value
 
 -- | Get a configuration setting.
 getFlag :: Flag -> Expr c b Bool
diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs
index 354ad68b3f..f20a664be5 100644
--- a/hadrian/src/Settings/Packages.hs
+++ b/hadrian/src/Settings/Packages.hs
@@ -281,7 +281,7 @@ rtsPackageArgs = package rts ? do
     way            <- getWay
     path           <- getBuildPath
     top            <- expr topDirectory
-    useSystemFfi   <- expr $ flag UseSystemFfi
+    useSystemFfi   <- getFlag UseSystemFfi
     ffiIncludeDir  <- getSetting FfiIncludeDir
     ffiLibraryDir  <- getSetting FfiLibDir
     libdwIncludeDir   <- getSetting LibdwIncludeDir
diff --git a/utils/ghc-toolchain/src/Main.hs b/utils/ghc-toolchain/Main.hs
index db8f3ec03c..db8f3ec03c 100644
--- a/utils/ghc-toolchain/src/Main.hs
+++ b/utils/ghc-toolchain/Main.hs
diff --git a/utils/ghc-toolchain/ghc-toolchain.cabal b/utils/ghc-toolchain/ghc-toolchain.cabal
index 85666432cf..25f841638c 100644
--- a/utils/ghc-toolchain/ghc-toolchain.cabal
+++ b/utils/ghc-toolchain/ghc-toolchain.cabal
@@ -8,9 +8,9 @@ author:             Ben Gamari
 maintainer:         ben@well-typed.com
 copyright:          (c) The GHC Developers
 
-executable ghc-toolchain
-    main-is:          Main.hs
-    other-modules:    
+library
+    exposed-modules:
+                      GHC.Toolchain,
                       GHC.Toolchain.Lens,
                       GHC.Toolchain.Monad,
                       GHC.Toolchain.PlatformDetails,
@@ -40,3 +40,17 @@ executable ghc-toolchain
                       ghc-boot
     hs-source-dirs:   src
     default-language: Haskell2010
+
+executable ghc-toolchain
+    main-is:          Main.hs
+    ghc-options:      -Wall
+    default-extensions: NoImplicitPrelude
+    build-depends:    base,
+                      directory,
+                      exceptions,
+                      filepath,
+                      process,
+                      transformers,
+                      ghc-boot,
+                      ghc-toolchain
+    default-language: Haskell2010
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain.hs b/utils/ghc-toolchain/src/GHC/Toolchain.hs
new file mode 100644
index 0000000000..be9e0ac917
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain.hs
@@ -0,0 +1,23 @@
+module GHC.Toolchain
+  ( module GHC.Toolchain.Target
+  , module GHC.Toolchain.Tools.Ar
+  , module GHC.Toolchain.Tools.Cc
+  , module GHC.Toolchain.Tools.Cpp
+  , module GHC.Toolchain.Tools.Cxx
+  , module GHC.Toolchain.Tools.Link
+  , module GHC.Toolchain.Tools.MergeObjs
+  , module GHC.Toolchain.Tools.Nm
+  , module GHC.Toolchain.Tools.Ranlib
+  ) where
+
+import GHC.Toolchain.Target
+
+import GHC.Toolchain.Tools.Ar
+import GHC.Toolchain.Tools.Cc
+import GHC.Toolchain.Tools.Cpp
+import GHC.Toolchain.Tools.Cxx
+import GHC.Toolchain.Tools.Link
+import GHC.Toolchain.Tools.MergeObjs
+import GHC.Toolchain.Tools.Nm
+import GHC.Toolchain.Tools.Ranlib
+