ghc-toolchain: Initial commit

21 files changed, 1709 insertions, 0 deletions

diff --git a/utils/ghc-toolchain/.gitignore b/utils/ghc-toolchain/.gitignore
new file mode 100644
index 0000000000..3bb6399c15
--- /dev/null
+++ b/utils/ghc-toolchain/.gitignore
@@ -0,0 +1,3 @@
+dist-newstyle
+cabal.project
+cabal.project.local
diff --git a/utils/ghc-toolchain/ghc-toolchain.cabal b/utils/ghc-toolchain/ghc-toolchain.cabal
new file mode 100644
index 0000000000..85666432cf
--- /dev/null
+++ b/utils/ghc-toolchain/ghc-toolchain.cabal
@@ -0,0 +1,42 @@
+cabal-version:      2.4
+name:               ghc-toolchain
+version:            0.1.0.0
+synopsis:           Utility for managing GHC target toolchains
+description:
+bug-reports:        https://gitlab.haskell.org/ghc/ghc/-/issues
+author:             Ben Gamari
+maintainer:         ben@well-typed.com
+copyright:          (c) The GHC Developers
+
+executable ghc-toolchain
+    main-is:          Main.hs
+    other-modules:    
+                      GHC.Toolchain.Lens,
+                      GHC.Toolchain.Monad,
+                      GHC.Toolchain.PlatformDetails,
+                      GHC.Toolchain.Prelude,
+                      GHC.Toolchain.Program,
+                      GHC.Toolchain.ParseTriple,
+                      GHC.Toolchain.CheckArm,
+                      GHC.Toolchain.Target,
+                      GHC.Toolchain.Tools.Ar,
+                      GHC.Toolchain.Tools.Cc,
+                      GHC.Toolchain.Tools.Cxx,
+                      GHC.Toolchain.Tools.Cpp,
+                      GHC.Toolchain.Tools.Link,
+                      GHC.Toolchain.Tools.Nm,
+                      GHC.Toolchain.Tools.Ranlib,
+                      GHC.Toolchain.Tools.Readelf,
+                      GHC.Toolchain.Tools.MergeObjs,
+                      GHC.Toolchain.Utils
+    ghc-options:      -Wall
+    default-extensions: NoImplicitPrelude
+    build-depends:    base,
+                      directory,
+                      exceptions,
+                      filepath,
+                      process,
+                      transformers,
+                      ghc-boot
+    hs-source-dirs:   src
+    default-language: Haskell2010
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs b/utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
new file mode 100644
index 0000000000..054ef51dc7
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
@@ -0,0 +1,131 @@
+module GHC.Toolchain.CheckArm ( findArmIsa ) where
+
+import Data.List
+import Data.Maybe (catMaybes)
+import Control.Monad.IO.Class
+import System.Process
+
+import GHC.Platform.ArchOS
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Tools.Cc
+
+-- | Awkwardly, ARM triples sometimes contain insufficient information about
+-- the platform. Consequently we instead extract this information from the
+-- toolchain.
+findArmIsa :: Cc -> M Arch
+findArmIsa cc = do
+    isa <- checkIsa
+    abi <- checkAbi
+    exts <- catMaybes <$> mapM checkExtension extensions
+    let arch = ArchARM isa exts abi
+    raspbianHack arch
+  where
+    checkIsa = checking "ARM ISA" $ do
+        arch <- lastLine <$> preprocess cc archTestProgram
+        case arch of
+          _ | arch < "6" -> throwE "pre-ARMv6 is not supported"
+          '6':_ -> return ARMv6
+          '7':_ -> return ARMv7
+          _ -> throwE "unknown ARM platform"
+
+    checkAbi = checking "ARM ABI" $ do
+        out <- fmap lastLine $ preprocess cc $ unlines
+            [ "#if defined(__ARM_PCS_VFP)"
+            , "HARD"
+            , "#elif defined(__SOFTFP__)"
+            , "SOFTFP"
+            , "#else"
+            , "SOFT"
+            , "#endif"
+            ]
+        case out of
+          "HARD" -> return HARD
+          "SOFTFP" -> return SOFTFP
+          "SOFT" -> return SOFT
+          _ -> throwE $ "unexpected output from test program: " ++ out
+
+    extensions :: [(ArmISAExt, String)]
+    extensions = 
+        [ (NEON, "__ARM_NEON")
+        , (VFPv2, "__VFP_FP__")
+        , (VFPv2, "__ARM_VFPV2")
+        , (VFPv3, "__ARM_VFPV3")
+        ]
+
+    checkExtension :: (ArmISAExt, String) -> M (Maybe ArmISAExt)
+    checkExtension (ext, macro) = do
+        supported <- checking ("for " ++ show ext ++ " support") $ testMacro macro
+        return $
+            if supported
+              then Just ext
+              else Nothing
+
+    testMacro :: String -> M Bool
+    testMacro macro = do
+        out <- fmap lastLine $ preprocess cc $ unlines
+            [ "#if defined(" ++ macro ++ ")"
+            , "True"
+            , "#else"
+            , "False"
+            , "#endif"
+            ]
+        case out of
+          "True" -> return True
+          "False" -> return False
+          _ -> throwE $ "unexpected output from test program: " ++ out
+
+lastLine :: String -> String
+lastLine "" = ""
+lastLine s  = last $ lines s
+
+-- | Raspbian unfortunately makes some extremely questionable packaging
+-- decisions, configuring gcc to compile for ARMv6 despite the fact that the
+-- Raspberry Pi 4 is ARMv8. As ARMv8 doesn't support all instructions supported
+-- by ARMv6 this can break. Work around this by checking uname to verify that
+-- we aren't running on armv7.
+-- See #17856.
+--
+raspbianHack :: Arch -> M Arch
+raspbianHack arch@(ArchARM ARMv6 _ abi) = do
+    raspbian <- isRaspbian
+    armv7 <- isARMv7Host
+    if raspbian && armv7
+      then do logInfo $ unlines [ "Found compiler which claims to target ARMv6 running in Raspbian on ARMv7."
+                                , "Assuming we should actually target ARMv7 (see GHC #17856)"
+                                ]
+              return $ ArchARM ARMv7 [VFPv2] abi
+      else return arch
+  where
+    isRaspbian = checking "whether this is Raspbian" $ do
+        issue <- readFile "/etc/issue" <|> return ""
+        return $ "Raspbian" `isInfixOf` issue
+
+    isARMv7Host = checking "whether the host is ARMv7" $ do
+        uname <- liftIO $ readProcess "uname" ["-m"] ""
+        return $ "armv7" `isInfixOf` uname
+
+raspbianHack arch = return arch
+
+archTestProgram :: String
+archTestProgram = unlines $
+    [ "#if defined(__ARM_ARCH)"
+    , "__ARM_ARCH"
+    ] ++
+    [ "#elif defined(__ARM_ARCH_"++arch++"__)\n"++arch
+    | arch <- armArchs
+    ] ++
+    [ "#else"
+    , "#error \"unknown ARM platform\""
+    , "#endif"
+    ]
+
+armArchs :: [String]
+armArchs =
+  [ "2"
+  , "3", "3M"
+  , "4", "4T"
+  , "5", "5T", "5E", "5TE"
+  , "6", "6J", "6T2", "6Z", "6ZK", "6K", "6KZ", "6M"
+  , "7"
+  ]
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Lens.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Lens.hs
new file mode 100644
index 0000000000..4934bf6096
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Lens.hs
@@ -0,0 +1,19 @@
+-- | A very simple Lens implementation
+module GHC.Toolchain.Lens
+    ( Lens(..)
+    , (%)
+    , over
+    ) where
+
+import Prelude ((.), ($))
+
+data Lens a b = Lens { view :: (a -> b), set :: (b -> a -> a) }
+
+(%) :: Lens a b -> Lens b c -> Lens a c
+a % b = Lens { view = view b . view a
+             , set = \y x -> set a (set b y (view a x)) x
+             }
+
+over :: Lens a b -> (b -> b) -> a -> a
+over l f x = set l (f $ view l x) x
+
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Monad.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Monad.hs
new file mode 100644
index 0000000000..cbd7417515
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Monad.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DerivingVia #-}
+
+module GHC.Toolchain.Monad
+    ( Env(..)
+    , M
+    , runM
+    , getEnv
+    , throwE
+    , ifCrossCompiling
+
+      -- * File I/O
+    , readFile
+    , writeFile
+    , createFile
+
+      -- * Logging
+    , logInfo
+    , logDebug
+    , checking
+    , withLogContext
+    ) where
+
+import Prelude hiding (readFile, writeFile)
+import qualified Prelude
+
+import Control.Applicative
+import Control.Monad
+import qualified Control.Monad.Catch as MC
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.Reader as Reader
+import qualified Control.Monad.Trans.Except as Except
+import System.IO hiding (readFile, writeFile)
+
+data Env = Env { verbosity    :: Int
+               , targetPrefix :: Maybe String
+               , keepTemp     :: Bool
+               , logContexts  :: [String]
+               }
+
+newtype M a = M (Except.ExceptT [Error] (Reader.ReaderT Env IO) a)
+    deriving (Functor, Applicative, Monad, MonadIO, Alternative,
+              -- TODO: Eliminate these instances
+              MC.MonadThrow, MC.MonadCatch, MC.MonadMask)
+
+runM :: Env -> M a -> IO (Either [Error] a)
+runM env (M k) =
+    Reader.runReaderT (Except.runExceptT k) env
+
+getEnv :: M Env
+getEnv = M $ lift Reader.ask
+
+data Error = Error { errorMessage :: String
+                   , errorLogContexts :: [String]
+                   }
+    deriving (Show)
+
+throwE :: String -> M a
+throwE msg = do
+    e <- getEnv
+    let err = Error { errorMessage = msg
+                    , errorLogContexts = logContexts e
+                    }
+    M (Except.throwE [err])
+
+withLogContext :: String -> M a -> M a
+withLogContext ctxt k = do
+    env <- getEnv
+    let env' = env { logContexts = ctxt : logContexts env }
+    logDebug $ "Entering: " ++ ctxt
+    r <- liftIO $ runM env' k
+    either (M . Except.throwE) return r
+
+checking :: Show a => String -> M a -> M a
+checking what k = do
+    logInfo $ "checking " ++ what ++ "..."
+    r <- withLogContext ("checking " ++ what) k
+    logInfo $ "found " ++ what ++ ": " ++ show r
+    return r
+
+logDebug :: String -> M ()
+logDebug = logMsg 2
+
+logInfo :: String -> M ()
+logInfo = logMsg 1
+
+logMsg :: Int -> String -> M ()
+logMsg v msg = do
+    e <- getEnv
+    let n = length $ logContexts e
+        indent = concat $ replicate n "  "
+    when (verbosity e >= v) (liftIO $ hPutStrLn stderr $ indent ++ msg)
+
+readFile :: FilePath -> M String
+readFile path = liftIO $ Prelude.readFile path
+
+writeFile :: FilePath -> String -> M ()
+writeFile path s = liftIO $ Prelude.writeFile path s
+
+-- | Create an empty file.
+createFile :: FilePath -> M ()
+createFile path = writeFile path ""
+
+ifCrossCompiling
+    :: M a  -- ^ what to do when cross-compiling
+    -> M a  -- ^ what to do otherwise
+    -> M a
+ifCrossCompiling cross other = other -- TODO
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/ParseTriple.hs b/utils/ghc-toolchain/src/GHC/Toolchain/ParseTriple.hs
new file mode 100644
index 0000000000..02bf73349a
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/ParseTriple.hs
@@ -0,0 +1,77 @@
+module GHC.Toolchain.ParseTriple ( parseTriple ) where
+
+import Data.List (isPrefixOf)
+
+import GHC.Platform.ArchOS
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.CheckArm
+import GHC.Toolchain.Tools.Cc
+
+parseTriple :: Cc -> String -> M ArchOS
+parseTriple cc triple
+  | [archName, vendorName, osName] <- parts
+  = do arch <- parseArch cc archName
+       os <- parseOs vendorName osName
+       return $ ArchOS arch os
+
+  | [archName, vendorName, osName, _abi] <- parts
+  = do arch <- parseArch cc archName
+       os <- parseOs vendorName osName
+       return $ ArchOS arch os
+
+  | otherwise
+  = throwE $ "malformed triple " ++ triple
+  where
+    parts = splitOn '-' triple
+
+parseArch :: Cc -> String -> M Arch
+parseArch cc arch =
+    case arch of
+      "i386" -> pure ArchX86
+      "x86_64" -> pure ArchX86_64
+      "amd64" -> pure ArchX86_64
+      "powerpc" -> pure ArchPPC
+      "powerpc64" -> pure (ArchPPC_64 ELF_V1)
+      "powerpc64le" -> pure (ArchPPC_64 ELF_V2)
+      "s390x" -> pure ArchS390X
+      "arm" -> findArmIsa cc
+      _ | "armv" `isPrefixOf` arch -> findArmIsa cc
+      "aarch64" -> pure ArchAArch64
+      "alpha" -> pure ArchAlpha
+      "mips" -> pure ArchMipseb
+      "mipseb" -> pure ArchMipseb
+      "mipsel" -> pure ArchMipsel
+      "riscv64" -> pure ArchRISCV64
+      "hppa" -> pure ArchUnknown
+      _ -> throwE $ "Unknown architecture " ++ arch
+
+parseOs :: String -> String -> M OS
+parseOs vendor os =
+    case os of
+      "linux" -> pure OSLinux
+      "linux-android" -> pure OSLinux
+      "darwin" -> pure OSDarwin
+      "ios" -> pure OSDarwin
+      "watchos" -> pure OSDarwin
+      "tvos" -> pure OSDarwin
+      "solaris2" -> pure OSSolaris2
+      "mingw32" -> pure OSMinGW32
+      "freebsd" -> pure OSFreeBSD
+      "dragonfly" -> pure OSDragonFly
+      "kfreebsdgnu" -> pure OSKFreeBSD
+      "openbsd" -> pure OSOpenBSD
+      "netbsd" -> pure OSNetBSD
+      "haiku" -> pure OSHaiku
+      "nto-qnc" -> pure OSQNXNTO
+      "aix" -> pure OSAIX
+      "gnu" -> pure OSHurd
+      _ -> throwE $ "Unknown vendor/operating system " ++ vendor ++ "-" ++ os
+
+splitOn :: Char -> String -> [String]
+splitOn sep = go
+  where
+    go "" = []
+    go s  = a : go (drop 1 b)
+      where
+        (a,b) = break (== sep) s
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs b/utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs
new file mode 100644
index 0000000000..fad4167695
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs
@@ -0,0 +1,141 @@
+module GHC.Toolchain.PlatformDetails
+    ( checkWordSize
+    , checkEndianness
+    , checkLeadingUnderscore
+    , checkSubsectionsViaSymbols
+    , checkIdentDirective
+    , checkGnuNonexecStack
+    ) where
+
+import Data.List (isInfixOf)
+import System.FilePath
+
+import GHC.Platform.ArchOS
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Utils
+import GHC.Toolchain.Target
+import GHC.Toolchain.Program
+import GHC.Toolchain.Tools.Cc
+import GHC.Toolchain.Tools.Nm
+
+checkWordSize :: Cc -> M WordSize
+checkWordSize cc = checking "word size" $ do
+    -- N.B. this is a surprisingly hard thing to check when cross-compiling.
+    -- See https://stackoverflow.com/questions/4374379.
+    -- To side-step this, we assume that the __SIZEOF_POINTER__ macro is
+    -- available. It's technically not standard although should be available in
+    -- any sane C implementation.
+    output <- preprocess cc program
+    case reverse $ lines output of
+      []            -> throwE "test program produced no output"
+      "undefined":_ -> throwE "__SIZEOF_POINTER__ is undefined"
+      "8":_         -> return WS8
+      "4":_         -> return WS8
+      _             -> throwE $ "unexpected output:\n" ++ output
+  where
+    program = unlines
+        [ "#include <stddef.h>"
+        , "#include <inttypes.h>"
+        , "#if !defined(__SIZEOF_POINTER__)"
+        , "undefined"
+        , "#else"
+        , "__SIZEOF_POINTER__"
+        , "#endif"
+        ]
+
+checkEndianness :: Cc -> M Endianness
+checkEndianness cc = do
+    checkEndiannessParamH cc <|> checkEndiannessLimitsH cc
+
+checkEndiannessParamH :: Cc -> M Endianness
+checkEndiannessParamH cc = checking "endianness (param.h)" $ do
+    output <- preprocess cc prog
+    case reverse $ lines output of
+      "big":_ -> return BigEndian
+      "little":_ -> return LittleEndian
+      "unknown":_ -> throwE "unknown endianness"
+      _ -> throwE "unrecognized output"
+  where
+    prog = unlines
+        [ "#include <sys/param.h>"
+        , "#if ! (defined BYTE_ORDER && defined BIG_ENDIAN \\"
+        , "   && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \\"
+        , "   && LITTLE_ENDIAN)"
+        , "bogus"
+        , "#elif BYTE_ORDER == BIG_ENDIAN"
+        , "big"
+        , "#elif BYTE_ORDER == LITTLE_ENDIAN"
+        , "little"
+        , "#else"
+        , "unknown"
+        , "#endif"
+        ]
+
+checkEndiannessLimitsH :: Cc -> M Endianness
+checkEndiannessLimitsH cc = checking "endianness (limits.h)" $ do
+    out <- preprocess cc prog
+    case reverse $ lines out of
+      "big":_ -> return BigEndian
+      "little":_ -> return LittleEndian
+      "unknown":_ -> throwE "unknown endianness"
+      _ -> throwE "unrecognized output"
+  where
+    prog = unlines
+        [ "#include <limits.h>"
+        , "#if defined(_LITTLE_ENDIAN)"
+        , "little"
+        , "#elif defined(_BIG_ENDIAN)"
+        , "big"
+        , "#else"
+        , "unknown"
+        , "#endif"
+        ]
+
+checkLeadingUnderscore :: Cc -> Nm -> M Bool
+checkLeadingUnderscore cc nm = checking ctxt $ withTempDir $ \dir -> do
+    let test_o = dir </> "test.o"
+    compileC cc test_o prog
+    out <- readProgram (nmProgram nm) [test_o]
+    return $ "_func" `isInfixOf` out
+  where
+    prog = "int func(void) { return 0; }"
+    ctxt = "whether symbols have leading underscores"
+
+checkSubsectionsViaSymbols :: Cc -> M Bool
+checkSubsectionsViaSymbols =
+    testCompile
+      "whether .subsections-via-symbols directive is supported"
+      (asmStmt ".subsections_via_symbols")
+
+checkIdentDirective :: Cc -> M Bool
+checkIdentDirective =
+    testCompile
+      "whether the .ident directive is supported"
+      (asmStmt ".ident \"GHC x.y.z\"")
+
+checkGnuNonexecStack :: ArchOS -> Cc -> M Bool
+checkGnuNonexecStack archOs =
+    testCompile
+      "whether GNU non-executable stack directives are supported"
+      prog
+  where
+    progbits = case archOS_arch archOs of
+                 ArchARM{} -> "%progbits" -- See #13937
+                 _         -> "@progbits"
+
+    prog = unlines [ asmStmt ".section .note.GNU-stack,\"\","++progbits
+                   , asmStmt ".section .text"
+                   ]
+
+asmStmt :: String -> String
+asmStmt s = "__asm__(\"" ++ foldMap escape s ++ "\");"
+  where
+    escape '"' = "\\\""
+    escape c   = [c]
+
+-- | Try compiling a program, returning 'True' if successful.
+testCompile :: String -> String -> Cc -> M Bool
+testCompile what program cc = checking what $ withTempDir $ \dir -> do
+    let test_o = dir </> "test.o"
+    (True <$ compileC cc test_o program) <|> return False
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Prelude.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Prelude.hs
new file mode 100644
index 0000000000..1749abb074
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Prelude.hs
@@ -0,0 +1,11 @@
+module GHC.Toolchain.Prelude
+    ( module GHC.Toolchain.Monad
+    , module GHC.Toolchain.Lens
+    , module Prelude
+    , (<|>)
+    ) where
+
+import GHC.Toolchain.Monad
+import GHC.Toolchain.Lens
+import Control.Applicative
+import Prelude hiding (writeFile, readFile)
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Program.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Program.hs
new file mode 100644
index 0000000000..54b2da7e87
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Program.hs
@@ -0,0 +1,115 @@
+module GHC.Toolchain.Program
+    ( Program(..)
+    , _prgPath
+    , _prgFlags
+      -- * Running programs
+    , runProgram
+    , callProgram
+    , readProgram
+      -- * Finding 'Program's
+    , ProgOpt(..)
+    , emptyProgOpt
+    , _poPath
+    , _poFlags
+    , findProgram
+    ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.List (intercalate)
+import System.Directory
+import System.Exit
+import System.Process hiding (env)
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Utils
+
+data Program = Program { prgPath :: FilePath
+                       , prgFlags :: [String]
+                       }
+    deriving (Show, Read)
+
+_prgPath :: Lens Program FilePath
+_prgPath = Lens prgPath (\x o -> o {prgPath = x})
+
+_prgFlags :: Lens Program [String]
+_prgFlags = Lens prgFlags (\x o -> o {prgFlags = x})
+
+runProgram :: Program -> [String] -> M ExitCode
+runProgram prog args = do
+    logExecute prog args
+    let cp = (proc (prgPath prog) (prgFlags prog ++ args))
+            { std_out = CreatePipe
+            -- , std_err = CreatePipe
+            }
+    (code, _stdout, _stderr) <- liftIO $ readCreateProcessWithExitCode cp ""
+    return code
+
+callProgram :: Program -> [String] -> M ()
+callProgram prog args = do
+    code <- runProgram prog args
+    case code of
+      ExitSuccess -> return ()
+      ExitFailure n -> throwE (err n)
+  where
+    cmdline = [prgPath prog] ++ prgFlags prog ++ args
+    err n = unlines
+        [ "Command failed: " ++ unwords cmdline
+        , "Exited with code " ++ show n
+        ]
+
+readProgram :: Program -> [String] -> M String
+readProgram prog args = do
+    logExecute prog args
+    liftIO $ readProcess (prgPath prog) (prgFlags prog ++ args) ""
+
+logExecute :: Program -> [String] -> M ()
+logExecute prog args =
+    logDebug $ "Execute: " ++ intercalate " " ([prgPath prog] ++ prgFlags prog ++ args)
+
+-- | Program specifier from the command-line.
+data ProgOpt = ProgOpt { poPath :: Maybe FilePath
+                       , poFlags :: [String]
+                       }
+
+_poPath :: Lens ProgOpt (Maybe FilePath)
+_poPath = Lens poPath (\x o -> o {poPath=x})
+
+_poFlags :: Lens ProgOpt [String]
+_poFlags = Lens poFlags (\x o -> o {poFlags=x})
+
+emptyProgOpt :: ProgOpt
+emptyProgOpt = ProgOpt Nothing []
+
+findProgram :: String
+            -> ProgOpt     -- ^ path provided by user
+            -> [FilePath]  -- ^ candidate names
+            -> M Program
+findProgram description userSpec candidates
+  | Just path <- poPath userSpec = do
+      let err = unlines
+            [ "Failed to find " ++ description ++ "."
+            , "Looked for user-specified program '" ++ path ++ "' in the system search path."
+            ]
+      toProgram <$> find_it path <|> throwE err
+
+  | otherwise = do
+      env <- getEnv
+      let prefixedCandidates =
+              case targetPrefix env of
+                Just prefix -> map (prefix++) candidates
+                Nothing     -> []
+          candidates' = prefixedCandidates ++ candidates
+          err = unlines
+            [ "Failed to find " ++ description ++ "."
+            , "Looked for one of " ++ show candidates' ++ " in the system search path."
+            ]
+      toProgram <$> oneOf err (map find_it candidates') <|> throwE err
+  where
+      toProgram path = Program { prgPath = path, prgFlags = poFlags userSpec }
+
+      find_it name = do
+          r <- liftIO $ findExecutable name
+          case r of
+            Nothing -> throwE $ name ++ " not found in search path"
+            Just x -> return x
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Target.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
new file mode 100644
index 0000000000..2c79d4cb3a
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Target.hs
@@ -0,0 +1,66 @@
+module GHC.Toolchain.Target where
+
+import GHC.Platform.ArchOS
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Program
+
+import GHC.Toolchain.Tools.Cc
+import GHC.Toolchain.Tools.Cxx
+import GHC.Toolchain.Tools.Cpp
+import GHC.Toolchain.Tools.Ar
+import GHC.Toolchain.Tools.Ranlib
+import GHC.Toolchain.Tools.Link
+import GHC.Toolchain.Tools.Nm
+import GHC.Toolchain.Tools.MergeObjs
+
+data WordSize = WS4 | WS8
+    deriving (Show, Read)
+
+data Endianness = LittleEndian | BigEndian
+    deriving (Show, Read)
+
+-- | A 'Target' consists of:
+--
+-- * a target architecture and operating system
+-- * various bits of information about the platform
+-- * various toolchain components targetting that platform
+--
+data Target = Target
+    { -- Platform
+      tgtArchOs :: ArchOS
+    -- , tgtCrossCompiling :: Bool -- TODO: Rename hostCanExecute?
+    , tgtSupportsGnuNonexecStack :: Bool
+    , tgtSupportsSubsectionsViaSymbols :: Bool
+    , tgtSupportsIdentDirective :: Bool
+    , tgtWordSize :: WordSize
+    , tgtEndianness :: Endianness
+    , tgtSymbolsHaveLeadingUnderscore :: Bool
+    , tgtLlvmTarget :: String
+
+      -- GHC capabilities
+    , tgtUnregisterised :: Bool
+    , tgtTablesNextToCode :: Bool
+    -- , tgtHasRtsLinker :: Bool -- Hmm?
+    -- , tgtHasThreadedRts :: Bool
+    -- , tgtUseLibffi :: Bool
+
+      -- C toolchain
+    , tgtCCompiler :: Cc
+    , tgtCxxCompiler :: Cxx
+    , tgtCPreprocessor :: Cpp
+    , tgtCCompilerLink :: CcLink
+    -- , tgtLd :: Program -- needed?
+    -- , tgtLdSupportsCompactUnwind :: Bool
+    -- , tgtLdSupportsFilelist :: Bool
+    -- , tgtLdIsGnuLd :: Bool -- needed?
+    , tgtAr :: Ar
+    , tgtRanlib :: Maybe Ranlib
+    , tgtNm :: Nm
+    , tgtMergeObjs :: Maybe MergeObjs
+
+      -- Windows-specific tools
+    , tgtDllwrap :: Maybe Program
+    , tgtWindres :: Maybe Program
+    }
+    deriving (Show, Read)
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs
new file mode 100644
index 0000000000..46df5d7141
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module GHC.Toolchain.Tools.Ar (Ar(..), findAr) where
+
+import Control.Monad
+import System.FilePath
+import Data.List
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Utils
+import GHC.Toolchain.Program
+
+data Ar = Ar { arMkArchive :: Program
+             , arIsGnu :: Bool
+             , arSupportsAtFile :: Bool
+             , arSupportsDashL :: Bool
+             , arNeedsRanlib :: Bool
+             }
+    deriving (Show, Read)
+
+findAr :: ProgOpt -> M Ar
+findAr progOpt = checking "for 'ar'" $ do
+    bareAr <- findProgram "ar archiver" progOpt ["ar"]
+    arIsGnu <- ("GNU" `isInfixOf`) <$> readProgram bareAr ["--version"]
+
+    -- Figure out how to invoke ar to create archives...
+    mkArchive <- checking "for how to make archives"
+        $ makeArchiveProgram arIsGnu bareAr
+
+    arSupportsAtFile <- checkArSupportsAtFile bareAr mkArchive <|> return False
+    arSupportsDashL <- checkArSupportsDashL bareAr <|> return False
+    let arNeedsRanlib
+          | arIsGnu = False
+          -- TODO: Autoconf handles Apple specifically here
+          | mode:_ <- prgFlags mkArchive
+          , 's' `elem` mode = False
+          | otherwise = True
+
+    return $ Ar { arMkArchive = mkArchive
+                , arIsGnu
+                , arSupportsAtFile
+                , arSupportsDashL
+                , arNeedsRanlib
+                }
+
+makeArchiveProgram :: Bool  -- ^ is GNU ar?
+                   -> Program -> M Program
+makeArchiveProgram isGnuAr ar
+  | isGnuAr = 
+    -- GNU ar needs special treatment: it appears to have problems with
+    -- object files with the same name if you use the 's' modifier, but
+    -- simple 'ar q' works fine, and doesn't need a separate ranlib.
+    check (set _prgFlags ["q"] ar)
+  | otherwise =
+    oneOf err
+      (map (\flag -> check $ set _prgFlags [flag] ar)
+           ["qclsZ", "qcls", "qcs", "qcl", "qc"])
+  where
+    check ar' = ar' <$ checkArWorks ar'
+    err = "Failed to figure out how to make archives"
+
+checkArWorks :: Program -> M ()
+checkArWorks prog = checking "that ar works" $ withTempDir $ \dir -> do
+    let dummy = dir </> "conftest.dummy"
+        archive = dir </> "conftest.a"
+    createFile dummy
+    callProgram prog [archive, dummy]
+    -- Check that result was created as some llvm-ar versions exit with code
+    -- zero even if they fail to parse the command-line.
+    expectFileExists archive "ar didn't create an archive"
+
+checkArSupportsDashL :: Program -> M Bool
+checkArSupportsDashL bareAr = checking "that ar supports -L" $ withTempDir $ \dir -> do
+    let file ext = dir </> "conftest" <.> ext
+        archive1 = dir </> "conttest-a.a"
+        archive2 = dir </> "conttest-b.a"
+        merged   = dir </> "conttest.a"
+    mapM_ (createFile . file) ["file", "a0", "a1", "b0", "b1"]
+    -- Build two archives, merge them, and check that the
+    -- result contains the original files rather than the two
+    -- archives.
+    callProgram bareAr ["qc", archive1, file "a0", file "a1"]
+    callProgram bareAr ["qc", archive2, file "b0", file "b1"]
+    oneOf "trying -L"
+        [ do callProgram bareAr ["qcL", merged, archive1, archive2]
+             contents <- readProgram bareAr ["t", merged]
+             return $ not $ "conftest.a1" `isInfixOf` contents
+        , return False
+        ]
+
+checkArSupportsAtFile :: Program -> Program -> M Bool
+checkArSupportsAtFile bareAr mkArchive = checking "that ar supports @-files" $ withTempDir $ \dir -> do
+    let f = dir </> "conftest.file"
+        atfile = dir </> "conftest.atfile"
+        archive = dir </> "conftest.a"
+        objs = replicate 2 f
+    createFile f
+    writeFile atfile (unlines objs)
+    callProgram mkArchive [archive, "@" ++ dir </> "conftest.atfile"]
+    contents <- readProgram bareAr ["t", archive]
+    if lines contents == objs
+      then return True
+      else logDebug "Contents didn't match" >> return False
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs
new file mode 100644
index 0000000000..d4d01f11a4
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module GHC.Toolchain.Tools.Cc
+    ( Cc(..)
+    , _ccProgram
+    , findCc
+      -- * Helpful utilities
+    , preprocess
+    , compileC
+    , compileAsm
+    , addPlatformDepCcFlags
+    ) where
+
+import System.FilePath
+
+import GHC.Platform.ArchOS
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Utils
+import GHC.Toolchain.Program
+
+data Cc = Cc { ccProgram :: Program
+             }
+    deriving (Show, Read)
+
+_ccProgram :: Lens Cc Program
+_ccProgram = Lens ccProgram (\x o -> o{ccProgram=x})
+
+findCc :: ProgOpt -> M Cc
+findCc progOpt = checking "for C compiler" $ do
+    ccProgram <- findProgram "C compiler" progOpt ["cc", "clang", "gcc"] 
+    cc <- ignoreUnusedArgs $ Cc {ccProgram}
+    checkCcWorks cc
+    checkC99Support cc
+    return cc
+
+checkCcWorks :: Cc -> M ()
+checkCcWorks cc = withTempDir $ \dir -> do
+    let test_o = dir </> "test.o"
+    compileC cc test_o $ unlines 
+        [ "#include <stdio.h>"
+        , "int main(int argc, char **argv) {"
+        , "  printf(\"hello world!\");"
+        , "  return 0;"
+        , "}"
+        ]
+
+-- | GHC tends to produce command-lines with unused arguments that elicit
+-- warnings from Clang. Clang offers the @-Qunused-arguments@ flag to silence
+-- these. See #11684.
+ignoreUnusedArgs :: Cc -> M Cc
+ignoreUnusedArgs cc = checking "for -Qunused-arguments support" $ do
+    let cc' = over (_ccProgram % _prgFlags) (++["-Qunused-arguments"]) cc
+    (cc' <$ checkCcWorks cc') <|> return cc
+
+checkC99Support :: Cc -> M ()
+checkC99Support cc = checking "for C99 support" $ withTempDir $ \dir -> do
+    let test_o = dir </> "test.o"
+    compileC cc test_o $ unlines
+        [ "#include <stdio.h>"
+        , "#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L"
+        , "# error \"Compiler does not advertise C99 conformance\""
+        , "#endif"
+        ]
+
+-- | Preprocess the given program.
+preprocess
+    :: Cc
+    -> String   -- ^ program
+    -> M String -- ^ preprocessed output
+preprocess cc prog = withTempDir $ \dir -> do
+    let out = dir </> "test.c"
+    compile "c" ["-E"] cc out prog
+    readFile out
+
+-- | Compile a C source file to object code.
+compileC
+    :: Cc       -- ^ cc
+    -> FilePath -- ^ output path
+    -> String   -- ^ C source
+    -> M ()
+compileC = compile "c" ["-c"]
+
+-- | Compile an assembler source file to object code.
+compileAsm
+    :: Cc       -- ^ cc
+    -> FilePath -- ^ output path
+    -> String   -- ^ Assembler source
+    -> M ()
+compileAsm = compile "S" ["-c"]
+
+compile
+    :: FilePath  -- ^ input extension
+    -> [String]  -- ^ extra flags
+    -> Cc
+    -> FilePath  -- ^ output path
+    -> String    -- ^ source
+    -> M ()
+compile ext extraFlags cc outPath program = do
+    let srcPath = outPath <.> ext
+    writeFile srcPath program
+    callProgram (ccProgram cc) $ extraFlags ++ ["-o", outPath, srcPath]
+    expectFileExists outPath "compiler produced no output"
+
+-- | Add various platform-dependent compiler flags needed by GHC. We can't do
+-- this in `findCc` since we need a 'Cc` to determine the 'ArchOS'.
+addPlatformDepCcFlags :: ArchOS -> Cc -> M Cc
+addPlatformDepCcFlags archOs cc
+  | OSMinGW32 <- archOS_OS archOs = do
+      checkFStackCheck cc <|> throwE "Windows requires -fstack-check support yet the C compiler appears not to support it"
+  | otherwise = return cc
+
+-- | Check that @cc@ supports @-fstack-check@.
+-- See Note [Windows stack allocations].
+checkFStackCheck :: Cc -> M Cc
+checkFStackCheck cc = withTempDir $ \dir -> checking "that -fstack-check works" $ do
+      let cc' = over (_ccProgram % _prgFlags) (++["-Wl,-fstack-checkzz"]) cc
+      compileC cc' (dir </> "test.o") "int main(int argc, char **argv) { return 0; }"
+      return cc'
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs
new file mode 100644
index 0000000000..51c5972c7d
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module GHC.Toolchain.Tools.Cpp (Cpp(..), findCpp) where
+
+import Control.Monad
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Program
+
+import GHC.Toolchain.Tools.Cc
+
+data Cpp = Cpp { cppProgram :: Program
+               }
+    deriving (Show, Read)
+
+findCpp :: ProgOpt -> Cc -> M Cpp
+findCpp progOpt cc
+  | Just _ <- poPath progOpt = checking "for C preprocessor" $ do
+    -- If the user specified a linker don't second-guess them
+    cppProgram <- findProgram "C preprocessor" progOpt []
+    return Cpp{cppProgram}
+  | otherwise = checking "for C preprocessor" $ do
+    let rawCppProgram = over _prgFlags (["-E"]++) (ccProgram cc)
+    hppArgs <- findHsCppArgs rawCppProgram
+    let cppProgram = over _prgFlags (++hppArgs) rawCppProgram
+    return Cpp{cppProgram}
+
+-- | Given a C preprocessor, figure out how it should be invoked to preprocess
+-- Haskell source.
+findHsCppArgs :: Program -> M [String]
+findHsCppArgs cpp =
+    concat <$> sequence
+        [ ["-traditional"] <$ checkFlag "-traditional"
+        , tryFlag "-undef"
+        , tryFlag "-Wno-invalid-pp-token"
+        , tryFlag "-Wno-unicode"
+        , tryFlag "-Wno-trigraphs"
+        ]
+  where
+    -- Werror to ensure that unrecognized warnings result in an error
+    checkFlag flag =
+        checking ("for "++flag++" support") $ callProgram cpp ["-E", "-Werror", flag, "/dev/null"]
+
+    tryFlag flag =
+        ([flag] <$ checkFlag flag) <|> return []
+
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs
new file mode 100644
index 0000000000..f4820f2a28
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module GHC.Toolchain.Tools.Cxx
+    ( Cxx(..)
+    , findCxx
+    ) where
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Program
+
+data Cxx = Cxx { cxxProgram :: Program
+               }
+    deriving (Show, Read)
+
+findCxx :: ProgOpt -> M Cxx
+findCxx progOpt = checking "for C++ compiler" $ do
+    cxxProgram <- findProgram "C++ compiler" progOpt ["c++", "clang++", "g++"]
+    return $ Cxx {cxxProgram}
+
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs
new file mode 100644
index 0000000000..aef1da35b8
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs
@@ -0,0 +1,172 @@
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE CPP #-}
+
+module GHC.Toolchain.Tools.Link ( CcLink(..), findCcLink ) where
+
+import Control.Monad (when)
+import Data.List
+import System.FilePath
+
+import GHC.Platform.ArchOS
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Utils
+import GHC.Toolchain.Program
+import GHC.Toolchain.Tools.Cc
+import GHC.Toolchain.Tools.Readelf
+
+-- | Configuration on how the C compiler can be used to link
+data CcLink = CcLink { ccLinkProgram :: Program
+                     , ccLinkSupportsNoPie :: Bool
+                     }
+    deriving (Show, Read)
+
+findCcLink :: ProgOpt -> ArchOS -> Cc -> Maybe Readelf -> M CcLink
+findCcLink progOpt archOs cc readelf = checking "for C compiler for linking command" $ do
+    ccLinkProgram <- case poPath progOpt of
+        Just _ ->
+            -- If the user specified a linker don't second-guess them
+            findProgram "C compiler for linking" progOpt []
+        Nothing -> do
+            -- If not then try to find a decent linker on our own
+            rawCcLink <- findProgram "C compiler for linking" progOpt [prgPath $ ccProgram cc]
+            findLinkFlags cc rawCcLink <|> pure rawCcLink
+    ccLinkSupportsNoPie <- checkSupportsNoPie ccLinkProgram
+    checkBfdCopyBug archOs cc readelf ccLinkProgram
+    ccLinkProgram <- addPlatformDepLinkFlags archOs cc ccLinkProgram
+    return $ CcLink {ccLinkProgram, ccLinkSupportsNoPie}
+
+-- | Try to convince @cc@ to use a more efficient linker than @bfd.ld@
+findLinkFlags :: Cc -> Program -> M Program
+findLinkFlags cc ccLink
+  | doLinkerSearch =
+    oneOf "this can't happen"
+        [ -- Annoyingly, gcc silently falls back to vanilla ld (typically bfd
+          -- ld) if @-fuse-ld@ is given with a non-existent linker.
+          -- Consequently, we must first check that the desired ld
+          -- executable exists before trying cc.
+          do _ <- findProgram (linker ++ " linker") emptyProgOpt ["ld."++linker]
+             prog <$ checkLinkWorks cc prog
+        | linker <- ["lld", "gold"]
+        , let prog = over _prgFlags (++["-fuse-ld="++linker]) ccLink
+        ]
+        <|> (ccLink <$ checkLinkWorks cc ccLink)
+  | otherwise =
+    return ccLink
+
+-- | Should we attempt to find a more efficient linker on this platform?
+--
+-- N.B. On Darwin it is quite important that we use the system linker
+-- unchanged as it is very easy to run into broken setups (e.g. unholy mixtures
+-- of Homebrew and the Apple toolchain).
+--
+-- See #21712.
+doLinkerSearch :: Bool
+#if defined(linux_HOST_OS)
+doLinkerSearch = True
+#else
+doLinkerSearch = False
+#endif
+
+checkSupportsNoPie :: Program -> M Bool
+checkSupportsNoPie ccLink = withTempDir $ \dir -> do
+    let test_c = dir </> "test.o"
+    writeFile test_c "int main() { return 0; }"
+
+    let test = dir </> "test"
+    -- Check output as some GCC versions only warn and don't respect -Werror
+    -- when passed an unrecognized flag.
+    out <- readProgram ccLink ["-no-pie", "-Werror", "-x", "c", test_c, "-o", test]
+    if "unrecognized" `isInfixOf` out
+      then return False
+      else return True
+
+-- | Check whether linking works.
+checkLinkWorks :: Cc -> Program -> M ()
+checkLinkWorks cc ccLink = withTempDir $ \dir -> do
+    let test_o = dir </> "test.o"
+        main_o = dir </> "main.o"
+    compileC cc test_o "int f(int a) { return 2*a; }"
+    compileC cc main_o "int f(int a); int main(int argc, char **argv) { return f(0); }"
+
+    let out = dir </> "test"
+    callProgram ccLink ["-o", out, test_o, main_o]
+    expectFileExists out "linker didn't produce any output"
+
+-- | Check for binutils bug #16177 present in some versions of the bfd ld
+-- implementation affecting ARM relocations.
+-- https://sourceware.org/bugzilla/show_bug.cgi?id=16177
+checkBfdCopyBug :: ArchOS -> Cc -> Maybe Readelf -> Program -> M ()
+checkBfdCopyBug archOs cc mb_readelf ccLink
+  | ArchARM{} <- archOS_arch archOs =
+    checking "whether linker is affected by binutils #16177" $ withTempDir $ \dir -> do
+    readelf <- case mb_readelf of
+      Just x -> return x
+      Nothing -> throwE "readelf needed to check for binutils #16177 but not found. Please set --readelf (and --readelf-opts as necessary)."
+
+    let test_o = dir </> "test.o"
+        lib_o = dir </> "lib.o"
+        lib_so = dir </> "lib.so"
+        main_o = dir </> "main.o"
+        exe = dir </> "exe"
+
+    compileAsm cc lib_o progLib
+    callProgram ccLink ["-shared", lib_o, "-o", lib_so]
+
+    compileC cc main_o progMain
+    compileAsm cc test_o progTest
+
+    callProgram ccLink ["-o", exe, test_o, main_o, lib_so]
+
+    out <- readProgram (readelfProgram readelf) ["-r", exe]
+    when ("R_ARM_COPY" `isInfixOf` out) $
+        throwE "Your linker is affected by binutils #16177. Please choose a different linker."
+
+  | otherwise = return ()
+
+  where
+    progTest = unlines
+        [ ".data"
+        , "  .globl data_object"
+        , "object_reference:"
+        , "  .long data_object"
+        , "  .size object_reference, 4"
+        ]
+
+    progLib = unlines
+        [ "  .data"
+        , "  .globl data_object"
+        , "  .type data_object, %object"
+        , "  .size data_object, 4"
+        , "data_object:"
+        , "    .long 123"
+        ]
+
+    progMain =
+        "int main(int argc, char **argv) { return 0; }"
+
+{- Note [ELF needed shared libs]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some distributions change the link editor's default handling of
+ELF DT_NEEDED tags to include only those shared objects that are
+needed to resolve undefined symbols. For Template Haskell we need
+the last temporary shared library also if it is not needed for the
+currently linked temporary shared library. We specify --no-as-needed
+to override the default. This flag exists in GNU ld and GNU gold.
+See #10110.
+
+The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
+(Mach-O) the flag is not needed.
+-}
+
+-- | Add various platform-dependent flags needed for reliable linking.
+addPlatformDepLinkFlags :: ArchOS -> Cc -> Program -> M Program
+addPlatformDepLinkFlags archOs cc ccLink
+  | OSLinux <- archOS_OS archOs = checking "that --no-as-needed works" $ do
+      -- | See Note [ELF needed shared libs]
+      let ccLink' = over _prgFlags (++["-Wl,--no-as-needed"]) ccLink
+      checkLinkWorks cc ccLink'
+      return ccLink'
+
+  | otherwise = return ccLink
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs
new file mode 100644
index 0000000000..cc3b029855
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE CPP #-}
+
+module GHC.Toolchain.Tools.MergeObjs ( MergeObjs(..), findMergeObjs ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.List
+import System.FilePath
+import System.Process
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Utils
+import GHC.Toolchain.Program
+import GHC.Toolchain.Tools.Cc
+import GHC.Toolchain.Tools.Link
+import GHC.Toolchain.Tools.Nm
+
+-- | Configuration on how the C compiler can be used to link
+data MergeObjs = MergeObjs { mergeObjsProgram :: Program
+                           }
+    deriving (Show, Read)
+
+findMergeObjs :: ProgOpt -> Cc -> CcLink -> Nm -> M MergeObjs
+findMergeObjs progOpt cc ccLink nm = checking "for linker for merging objects" $ do
+    prog <- findProgram "linker for merging objects" progOpt ["ld"]
+    let mo = MergeObjs $ over _prgFlags (++["-r"]) prog
+    checkMergingWorks cc nm mo
+    checkForGoldT22266 cc ccLink mo
+    return mo
+
+checkMergingWorks :: Cc -> Nm -> MergeObjs -> M ()
+checkMergingWorks cc nm mergeObjs =
+    checking "whether object merging works" $ withTempDir $ \dir -> do
+        let fo s = dir </> s <.> "o"
+        compileC cc (fo "a") "void funA(int x) { return x; }"
+        compileC cc (fo "b") "void funB(int x) { return x; }"
+        callProgram (mergeObjsProgram mergeObjs) [fo "a", fo "b", "-o", fo "out"]
+        out <- readProgram (nmProgram nm) [fo "out"]
+        let ok = all (`isInfixOf` out) ["funA", "funB"]
+        unless ok $ throwE "merged objects is missing symbols"
+
+checkForGoldT22266 :: Cc -> CcLink -> MergeObjs -> M ()
+checkForGoldT22266 cc ccLink mergeObjs = do
+    version <- checking "for ld.gold object merging bug (binutils #22266)" $
+        readProgram (mergeObjsProgram mergeObjs) ["--version"]
+    when ("gold" `isInfixOf` version) check_it
+  where
+    check_it =
+        checking "for ld.gold object merging bug (binutils #22266)" $
+        ifCrossCompiling (logInfo "Cross-compiling, assuming linker is unaffected") $
+        withTempDir $ \dir -> do
+            let f s = dir </> s
+                link_script = f "link.t"
+                a_o = f "a.o"
+                merged_o = f "merged.o"
+                main_o = f "main.o"
+                exe = f "main"
+            compileC cc a_o progA
+            writeFile link_script ldScript
+            callProgram (mergeObjsProgram mergeObjs)
+                ["-T", link_script, "-o", merged_o]
+            compileC cc main_o progMain
+            callProgram (ccLinkProgram ccLink)
+                ["-o", exe, merged_o, main_o]
+            liftIO $ callProcess exe []
+
+    progA = unlines
+        [ "__attribute__((section(\".data.a\")))"
+        , "static int int_from_a_1 = 0x11223344;"
+        , ""
+        , "__attribute__((section(\".data.rel.ro.a\")))"
+        , "int *p_int_from_a_2 = &int_from_a_1;"
+        , ""
+        , "const char *hello (void);"
+        , ""
+        , "const char * hello (void)"
+        , "{ return \"XXXHello, world!\" + 3; }"
+        ]
+
+    progMain = unlines
+        [ "#include <stdlib.h>"
+        , "#include <string.h>"
+        , ""
+        , "extern int *p_int_from_a_2;"
+        , "extern const char *hello (void);"
+        , ""
+        , "int main (void) {"
+        , "  if (*p_int_from_a_2 != 0x11223344)"
+        , "    abort ();"
+        , "  if (strcmp(hello(), \"Hello, world!\") != 0)"
+        , "    abort ();"
+        , "  return 0;"
+        , "}"
+        ]
+
+    ldScript = unlines
+        [ "SECTIONS {"
+        , "  .text : { *(.text*) }"
+        , "  .rodata : { *(.rodata .rodata.* .gnu.linkonce.r.*) }"
+        , "  .data.rel.ro : { *(.data.rel.ro*) }"
+        , "  .data : { *(.data*) }"
+        , "  .bss : { *(.bss*) }"
+        , "}"
+        ]
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Nm.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Nm.hs
new file mode 100644
index 0000000000..88f5ae1356
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Nm.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module GHC.Toolchain.Tools.Nm (Nm(..), findNm) where
+
+import Control.Monad
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Program
+
+data Nm = Nm { nmProgram :: Program
+             }
+    deriving (Show, Read)
+
+findNm :: ProgOpt -> M Nm
+findNm progOpt = checking "for 'nm'" $ do
+    nmProgram <- findProgram "nm utility" progOpt ["nm"]
+    return Nm {..}
+
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ranlib.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ranlib.hs
new file mode 100644
index 0000000000..0ea16175f6
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ranlib.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module GHC.Toolchain.Tools.Ranlib
+    ( Ranlib(..)
+    , findRanlib
+    ) where
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Program
+
+data Ranlib = Ranlib { ranlibProgram :: Program
+                     }
+    deriving (Show, Read)
+
+findRanlib :: ProgOpt -> M Ranlib
+findRanlib progOpt = checking "for 'ranlib'" $ do
+    ranlibProgram <- findProgram "ranlib archiver" progOpt ["ranlib"]
+    return $ Ranlib {ranlibProgram}
+
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Readelf.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Readelf.hs
new file mode 100644
index 0000000000..c42fe01818
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Tools/Readelf.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module GHC.Toolchain.Tools.Readelf (Readelf(..), findReadelf) where
+
+import Control.Monad
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Program
+
+data Readelf = Readelf { readelfProgram :: Program
+                       }
+    deriving (Show, Read)
+
+-- | Readelf is only needed by 'GHC.Toolchain.Tools.Link.checkBfdCopyBug'.
+findReadelf :: ProgOpt -> M Readelf
+findReadelf progOpt = checking "for 'readelf'" $ do
+    readelfProgram <- findProgram "readelf utility" progOpt ["readelf"]
+    return Readelf {..}
+
diff --git a/utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs b/utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
new file mode 100644
index 0000000000..19d47601af
--- /dev/null
+++ b/utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module GHC.Toolchain.Utils
+    ( expectJust
+    , expectFileExists
+    , withTempDir
+    , oneOf
+    ) where
+
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.IO.Class
+import System.Directory
+import System.FilePath
+import System.IO.Error
+
+import GHC.Toolchain.Prelude
+
+createTempDirectory
+    :: forall m. (MonadIO m, MonadCatch m)
+    => m FilePath
+createTempDirectory = do
+    root <- liftIO $ getTemporaryDirectory
+    go root 0
+  where
+    go :: FilePath -> Int -> m FilePath
+    go root n = do
+        let path = root </> "tmp"++show n
+        res <- try $ liftIO $ createDirectory path
+        case res of
+          Right () -> return path
+          Left err
+            | isAlreadyExistsError err -> go root (n+1)
+            | otherwise -> throwM err
+
+withTempDir :: (FilePath -> M a) -> M a
+withTempDir f = do
+    env <- getEnv
+    let close dir
+          | keepTemp env = return ()
+          | otherwise    = liftIO $ removeDirectoryRecursive dir
+    bracket createTempDirectory close f
+
+expectJust :: String -> Maybe a -> M a
+expectJust err Nothing = throwE err
+expectJust _   (Just x) = return x
+
+expectFileExists :: FilePath -> String -> M ()
+expectFileExists path err = do
+    exists <- liftIO $ doesFileExist path
+    unless exists $ throwE err
+
+oneOf :: String -> [M b] -> M b
+oneOf err = foldr (<|>) (throwE err)
diff --git a/utils/ghc-toolchain/src/Main.hs b/utils/ghc-toolchain/src/Main.hs
new file mode 100644
index 0000000000..729687ca1a
--- /dev/null
+++ b/utils/ghc-toolchain/src/Main.hs
@@ -0,0 +1,318 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Main where
+
+import Control.Monad
+import Data.Char (toUpper)
+import System.Exit
+import System.Console.GetOpt
+import System.Environment
+import System.FilePath ((</>))
+
+import GHC.Platform.ArchOS
+
+import GHC.Toolchain.Prelude
+import GHC.Toolchain.Program
+import GHC.Toolchain.Target
+import GHC.Toolchain.PlatformDetails
+import GHC.Toolchain.ParseTriple
+import GHC.Toolchain.Utils
+
+import GHC.Toolchain.Tools.Cc
+import GHC.Toolchain.Tools.Cxx
+import GHC.Toolchain.Tools.Cpp
+import GHC.Toolchain.Tools.Link
+import GHC.Toolchain.Tools.Ar
+import GHC.Toolchain.Tools.Ranlib
+import GHC.Toolchain.Tools.Nm
+import GHC.Toolchain.Tools.MergeObjs
+import GHC.Toolchain.Tools.Readelf
+
+data Opts = Opts
+    { optTriple    :: String
+    , optTargetPrefix :: Maybe String
+    , optCc        :: ProgOpt
+    , optCxx       :: ProgOpt
+    , optCpp       :: ProgOpt
+    , optCcLink    :: ProgOpt
+    , optAr        :: ProgOpt
+    , optRanlib    :: ProgOpt
+    , optNm        :: ProgOpt
+    , optReadelf   :: ProgOpt
+    , optMergeObjs :: ProgOpt
+    , optWindres   :: ProgOpt
+    , optDllwrap   :: ProgOpt
+    , optUnregisterised :: Maybe Bool
+    , optTablesNextToCode :: Maybe Bool
+    , optVerbosity :: Int
+    , optKeepTemp  :: Bool
+    }
+
+emptyOpts :: Opts
+emptyOpts = Opts
+    { optTriple    = ""
+    , optTargetPrefix = Nothing
+    , optCc        = po0
+    , optCxx       = po0
+    , optCpp       = po0
+    , optCcLink    = po0
+    , optAr        = po0
+    , optRanlib    = po0
+    , optNm        = po0
+    , optReadelf   = po0
+    , optMergeObjs = po0
+    , optDllwrap   = po0
+    , optWindres   = po0
+    , optUnregisterised = Nothing
+    , optTablesNextToCode = Nothing
+    , optVerbosity = 0
+    , optKeepTemp  = False
+    }
+  where
+    po0 = emptyProgOpt
+
+_optCc, _optCxx, _optCpp, _optCcLink, _optAr, _optRanlib, _optNm,
+    _optReadelf, _optMergeObjs, _optDllwrap, _optWindres
+    :: Lens Opts ProgOpt
+_optCc      = Lens optCc      (\x o -> o {optCc=x})
+_optCxx     = Lens optCxx     (\x o -> o {optCxx=x})
+_optCpp     = Lens optCpp     (\x o -> o {optCpp=x})
+_optCcLink  = Lens optCcLink  (\x o -> o {optCcLink=x})
+_optAr      = Lens optAr      (\x o -> o {optAr=x})
+_optRanlib  = Lens optRanlib  (\x o -> o {optRanlib=x})
+_optNm      = Lens optNm      (\x o -> o {optNm=x})
+_optReadelf = Lens optReadelf (\x o -> o {optReadelf=x})
+_optMergeObjs = Lens optMergeObjs (\x o -> o {optMergeObjs=x})
+_optDllwrap = Lens optDllwrap (\x o -> o {optDllwrap=x})
+_optWindres = Lens optWindres (\x o -> o {optWindres=x})
+
+_optTriple :: Lens Opts String
+_optTriple = Lens optTriple (\x o -> o {optTriple=x})
+
+_optTargetPrefix :: Lens Opts (Maybe String)
+_optTargetPrefix = Lens optTargetPrefix (\x o -> o {optTargetPrefix=x})
+
+_optUnregisterised :: Lens Opts (Maybe Bool)
+_optUnregisterised = Lens optUnregisterised (\x o -> o {optUnregisterised=x})
+
+_optTablesNextToCode :: Lens Opts (Maybe Bool)
+_optTablesNextToCode = Lens optTablesNextToCode (\x o -> o {optTablesNextToCode=x})
+
+_optVerbosity :: Lens Opts Int
+_optVerbosity = Lens optVerbosity (\x o -> o {optVerbosity=x})
+
+_optKeepTemp :: Lens Opts Bool
+_optKeepTemp = Lens optKeepTemp (\x o -> o {optKeepTemp=x})
+
+options :: [OptDescr (Opts -> Opts)]
+options = 
+    [ tripleOpt
+    , targetPrefixOpt
+    , verbosityOpt
+    , keepTempOpt
+    ] ++
+    concat
+    [ enableDisable "unregisterised" "unregisterised backend" _optUnregisterised
+    , enableDisable "tables-next-to-code" "Tables-next-to-code optimisation" _optTablesNextToCode
+    ] ++
+    concat
+    [ progOpts "cc" "C compiler" _optCc
+    , progOpts "cpp" "C preprocessor" _optCpp
+    , progOpts "cxx" "C++ compiler" _optCxx
+    , progOpts "cc-link" "C compiler for linking" _optCcLink
+    , progOpts "ar" "ar archiver" _optAr
+    , progOpts "ranlib" "ranlib utility" _optAr
+    , progOpts "nm" "nm archiver" _optNm
+    , progOpts "readelf" "readelf utility" _optReadelf
+    , progOpts "merge-objs" "linker for merging objects" _optMergeObjs
+    , progOpts "dllwrap" "dllwrap utility" _optDllwrap
+    , progOpts "windres" "windres utility" _optWindres
+    ]
+  where
+    progOpts :: String -> String -> Lens Opts ProgOpt -> [OptDescr (Opts -> Opts)]
+    progOpts progName description lens =
+        [ Option [] [progName] (ReqArg (set (lens % _poPath) . Just) metavar) ("Path of " ++ description)
+        , Option [] [progName++"-opt"] (ReqArg (\x -> over (lens % _poFlags) (++[x])) "OPTS") ("Flags to pass to " ++ progName)
+        ]
+      where
+        metavar = map toUpper progName
+
+    enableDisable :: String -> String -> Lens Opts (Maybe Bool) -> [OptDescr (Opts -> Opts)]
+    enableDisable optName description lens =
+        [ Option [] ["enable-" ++ optName] (NoArg (set lens (Just True))) ("Enable " ++ description)
+        , Option [] ["disable-" ++ optName] (NoArg (set lens (Just False))) ("Disable " ++ description)
+        ]
+
+    tripleOpt = Option ['t'] ["triple"] (ReqArg (set _optTriple) "TRIPLE") "Target triple"
+
+    targetPrefixOpt = Option ['T'] ["target-prefix"] (ReqArg (set _optTargetPrefix . Just) "PREFIX")
+        "A target prefix which will be added to all tool names when searching for toolchain components"
+
+    verbosityOpt = Option ['v'] ["verbose"] (OptArg f "N") "set output verbosity"
+      where
+        f mb = set _optVerbosity (parseVerbosity mb)
+        parseVerbosity :: Maybe String -> Int
+        parseVerbosity mb
+          | Nothing <- mb        = 1
+          | Just s <- mb
+          , (n, ""):_ <- reads s = n
+          | otherwise            = error "unparseable verbosity level"
+
+    keepTempOpt = Option [] ["keep-temp"] (NoArg (set _optKeepTemp True))
+        "do not remove temporary files"
+
+main :: IO ()
+main = do
+    argv <- getArgs
+    let (opts0, _nonopts, errs) = getOpt RequireOrder options argv
+    let opts = foldr (.) id opts0 emptyOpts
+    case errs of
+      [] -> do
+          let env = Env { verbosity = optVerbosity opts
+                        , targetPrefix = case optTargetPrefix opts of
+                                           Just prefix -> Just $ prefix
+                                           Nothing -> Just $ optTriple opts ++ "-"
+                        , keepTemp = optKeepTemp opts
+                        , logContexts = []
+                        }
+          r <- runM env (run opts)
+          case r of
+            Left err -> print err >> exitWith (ExitFailure 2)
+            Right () -> return ()
+      _  -> do
+        mapM_ putStrLn errs
+        putStrLn $ usageInfo "ghc-toolchain" options
+        exitWith (ExitFailure 1)
+
+run :: Opts -> M ()
+run opts = do
+    tgt <- mkTarget opts
+    logDebug $ "Final Target: " ++ show tgt
+    writeFile "default.target" (show tgt)
+
+optional :: M a -> M (Maybe a)
+optional k = fmap Just k <|> pure Nothing
+
+registerisedSupported :: ArchOS -> Bool
+registerisedSupported archOs =
+    case archOS_arch archOs of
+      ArchX86       -> True
+      ArchX86_64    -> True
+      ArchPPC       -> True
+      ArchPPC_64 _  -> True
+      ArchS390X     -> True
+      ArchARM _ _ _ -> True
+      ArchAArch64   -> True
+      ArchRISCV64   -> True
+      _             -> False
+
+determineUnregisterised :: ArchOS -> Maybe Bool -> M Bool
+determineUnregisterised archOs userReq =
+    case userReq of
+      Just False
+        | not regSupported -> throwE "GHC doesn't support registerised compilation on this architecture"
+        | otherwise        -> return False
+      Just True            -> return True
+      Nothing
+        | regSupported     -> return False
+        | otherwise        -> return True
+  where
+    regSupported = registerisedSupported archOs
+
+tablesNextToCodeSupported :: ArchOS -> Bool
+tablesNextToCodeSupported archOs =
+    case archOS_arch archOs of
+      ArchPPC      -> False
+      ArchPPC_64 _ -> False
+      ArchS390X    -> False
+      _            -> True
+
+determineTablesNextToCode
+    :: ArchOS
+    -> Bool       -- ^ unregisterised
+    -> Maybe Bool -- ^ user flag
+    -> M Bool
+determineTablesNextToCode archOs unreg userReq =
+    case userReq of
+      Just True
+        | unreg         -> throwE "Tables-next-to-code cannot be used with unregisterised code generator"
+        | tntcSupported -> throwE "Tables-next-to-code not supported by this platform"
+        | otherwise     -> return True
+      Just False        -> return False
+      Nothing
+        | tntcSupported -> return True
+        | otherwise     -> return False
+  where
+    tntcSupported = tablesNextToCodeSupported archOs
+
+mkTarget :: Opts -> M Target
+mkTarget opts = do
+    cc0 <- findCc (optCc opts)
+    cxx <- findCxx (optCxx opts)
+    cpp <- findCpp (optCpp opts) cc0
+    archOs <- parseTriple cc0 (optTriple opts)
+    cc <- addPlatformDepCcFlags archOs cc0
+    readelf <- optional $ findReadelf (optReadelf opts)
+    ccLink <- findCcLink (optCcLink opts) archOs cc readelf
+
+    ar <- findAr (optAr opts)
+    ranlib <- if arNeedsRanlib ar
+                 then Just <$> findRanlib (optRanlib opts)
+                 else return Nothing
+
+    nm <- findNm (optNm opts)
+    mergeObjs <- optional $ findMergeObjs (optMergeObjs opts) cc ccLink nm
+
+    -- Windows-specific utilities
+    (windres, dllwrap) <-
+        case archOS_OS archOs of
+          OSMinGW32 -> do
+            windres <- findProgram "windres" (optWindres opts) ["windres"]
+            dllwrap <- findProgram "dllwrap" (optDllwrap opts) ["dllwrap"]
+            return (Just windres, Just dllwrap)
+          _ -> return (Nothing, Nothing)
+
+    -- various other properties of the platform
+    tgtWordSize <- checkWordSize cc
+    tgtEndianness <- checkEndianness cc
+    tgtSymbolsHaveLeadingUnderscore <- checkLeadingUnderscore cc nm
+    tgtSupportsSubsectionsViaSymbols <- checkSubsectionsViaSymbols cc
+    tgtSupportsIdentDirective <- checkIdentDirective cc
+    tgtSupportsGnuNonexecStack <- checkGnuNonexecStack archOs cc
+    tgtLlvmTarget <- pure $ optTriple opts
+
+    -- code generator configuration
+    tgtUnregisterised <- determineUnregisterised archOs (optUnregisterised opts)
+    tgtTablesNextToCode <-
+        determineTablesNextToCode archOs tgtUnregisterised (optTablesNextToCode opts)
+    when tgtUnregisterised $ do
+        -- The via-C code generator requires these
+        let prog = "int main(int argc, char** argv) { return 0; }I"
+            via_c_args = ["-fwrapv", "-fno-builtin"]
+        forM_ via_c_args $ \arg -> checking ("support of "++arg) $ withTempDir $ \dir -> do
+            let cc' = over (_ccProgram % _prgFlags) (++ [arg]) cc
+            compileC cc' (dir </> "test.o") prog
+            return ()
+
+    let t = Target { tgtArchOs = archOs
+                   , tgtCCompiler = cc
+                   , tgtCxxCompiler = cxx
+                   , tgtCPreprocessor = cpp
+                   , tgtAr = ar
+                   , tgtCCompilerLink = ccLink
+                   , tgtRanlib = ranlib
+                   , tgtNm = nm
+                   , tgtMergeObjs = mergeObjs
+                   , tgtWindres = windres
+                   , tgtDllwrap = dllwrap
+                   , tgtWordSize
+                   , tgtEndianness
+                   , tgtUnregisterised
+                   , tgtTablesNextToCode
+                   , tgtSymbolsHaveLeadingUnderscore
+                   , tgtSupportsSubsectionsViaSymbols
+                   , tgtSupportsIdentDirective
+                   , tgtSupportsGnuNonexecStack
+                   , tgtLlvmTarget
+                   }
+    return t