Reinstallable GHC

This patch allows ghc and its dependencies to be built using a normal
invocation of cabal-install. Each componenent which relied on generated
files or additional configuration now has a Setup.hs file.

There are also various fixes to the cabal files to satisfy
cabal-install.

There is a new hadrian command which will build a stage2 compiler and
then a stage3 compiler by using cabal.

```
./hadrian/build build-cabal
```

There is also a new CI job which tests running this command.

For the 9.4 release we will upload all the dependent executables to
hackage and then end users will be free to build GHC and GHC executables
via cabal.

There are still some unresolved questions about how to ensure soundness
when loading plugins into a reinstalled GHC (#20742) which will be
tighted up in due course.

Fixes #19896

1 files changed, 138 insertions, 0 deletions

diff --git a/compiler/Setup.hs b/compiler/Setup.hs
new file mode 100644
index 0000000000..e6d3d09d18
--- /dev/null
+++ b/compiler/Setup.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
+module Main where
+
+import Distribution.Simple
+import Distribution.Simple.BuildPaths
+import Distribution.Types.LocalBuildInfo
+import Distribution.Verbosity
+import Distribution.Simple.Program
+import Distribution.Simple.Utils
+import Distribution.Simple.Setup
+
+import System.IO
+import System.Process
+import System.Directory
+import System.FilePath
+import Control.Monad
+import Data.Char
+import GHC.ResponseFile
+import System.Environment
+
+main :: IO ()
+main = defaultMainWithHooks ghcHooks
+  where
+    ghcHooks = simpleUserHooks
+      { postConf = \args cfg pd lbi -> do
+          let verbosity = fromFlagOrDefault minBound (configVerbosity cfg)
+          ghcAutogen verbosity lbi
+          postConf simpleUserHooks args cfg pd lbi
+      }
+
+-- Mapping from primop-*.hs-incl file to command
+primopIncls :: [(String,String)]
+primopIncls =
+    [ ("primop-data-decl.hs-incl"         , "--data-decl")
+    , ("primop-tag.hs-incl"               , "--primop-tag")
+    , ("primop-list.hs-incl"              , "--primop-list")
+    , ("primop-has-side-effects.hs-incl"  , "--has-side-effects")
+    , ("primop-out-of-line.hs-incl"       , "--out-of-line")
+    , ("primop-commutable.hs-incl"        , "--commutable")
+    , ("primop-code-size.hs-incl"         , "--code-size")
+    , ("primop-can-fail.hs-incl"          , "--can-fail")
+    , ("primop-strictness.hs-incl"        , "--strictness")
+    , ("primop-fixity.hs-incl"            , "--fixity")
+    , ("primop-primop-info.hs-incl"       , "--primop-primop-info")
+    , ("primop-vector-uniques.hs-incl"    , "--primop-vector-uniques")
+    , ("primop-vector-tys.hs-incl"        , "--primop-vector-tys")
+    , ("primop-vector-tys-exports.hs-incl", "--primop-vector-tys-exports")
+    , ("primop-vector-tycons.hs-incl"     , "--primop-vector-tycons")
+    , ("primop-docs.hs-incl"              , "--wired-in-docs")
+    ]
+
+ghcAutogen :: Verbosity -> LocalBuildInfo -> IO ()
+ghcAutogen verbosity lbi@LocalBuildInfo{..} = do
+  -- Get compiler/ root directory from the cabal file
+  let Just compilerRoot = takeDirectory <$> pkgDescrFile
+
+  -- Require the necessary programs
+  (gcc   ,withPrograms) <- requireProgram normal gccProgram withPrograms
+  (ghc   ,withPrograms) <- requireProgram normal ghcProgram withPrograms
+
+  settings <- read <$> getProgramOutput normal ghc ["--info"]
+  -- We are reinstalling GHC
+  -- Write primop-*.hs-incl
+  let hsCppOpts = case lookup "Haskell CPP flags" settings of
+        Just fs -> unescapeArgs fs
+        Nothing -> []
+      primopsTxtPP = compilerRoot </> "GHC/Builtin/primops.txt.pp"
+      cppOpts = hsCppOpts ++ ["-P","-x","c"]
+      cppIncludes = map ("-I"++) [compilerRoot]
+  -- Preprocess primops.txt.pp
+  primopsStr <- getProgramOutput normal gcc (cppOpts ++ cppIncludes ++ [primopsTxtPP])
+  -- Call genprimopcode to generate *.hs-incl
+  forM_ primopIncls $ \(file,command) -> do
+    contents <- readProcess "genprimopcode" [command] primopsStr
+    rewriteFileEx verbosity (buildDir </> file) contents
+
+  -- Write GHC.Platform.Constants
+  let platformConstantsPath = autogenPackageModulesDir lbi </> "GHC/Platform/Constants.hs"
+      targetOS = case lookup "target os" settings of
+        Nothing -> error "no target os in settings"
+        Just os -> os
+  createDirectoryIfMissingVerbose verbosity True (takeDirectory platformConstantsPath)
+  withTempFile (takeDirectory platformConstantsPath) "Constants_tmp.hs" $ \tmp h -> do
+    hClose h
+    callProcess "deriveConstants" ["--gen-haskell-type","-o",tmp,"--target-os",targetOS]
+    renameFile tmp platformConstantsPath
+
+  -- Write GHC.Settings.Config
+  let configHsPath = autogenPackageModulesDir lbi </> "GHC/Settings/Config.hs"
+      configHs = generateConfigHs settings
+  createDirectoryIfMissingVerbose verbosity True (takeDirectory configHsPath)
+  rewriteFileEx verbosity configHsPath configHs
+
+getSetting :: [(String,String)] -> String -> String -> Either String String
+getSetting settings kh kr = go settings kr
+  where
+    go settings k =  case lookup k settings of
+      Nothing -> Left (show k ++ " not found in settings: " ++ show settings)
+      Just v -> Right v
+
+generateConfigHs :: [(String,String)] -> String
+generateConfigHs settings = either error id $ do
+    let getSetting' = getSetting $ (("cStage","2"):) settings
+    buildPlatform  <- getSetting' "cBuildPlatformString" "Host platform"
+    hostPlatform   <- getSetting' "cHostPlatformString" "Target platform"
+    cProjectName   <- getSetting' "cProjectName" "Project name"
+    cBooterVersion <- getSetting' "cBooterVersion" "Project version"
+    cStage         <- getSetting' "cStage" "cStage"
+    return $ unlines
+        [ "module GHC.Settings.Config"
+        , "  ( module GHC.Version"
+        , "  , cBuildPlatformString"
+        , "  , cHostPlatformString"
+        , "  , cProjectName"
+        , "  , cBooterVersion"
+        , "  , cStage"
+        , "  ) where"
+        , ""
+        , "import GHC.Prelude"
+        , ""
+        , "import GHC.Version"
+        , ""
+        , "cBuildPlatformString :: String"
+        , "cBuildPlatformString = " ++ show buildPlatform
+        , ""
+        , "cHostPlatformString :: String"
+        , "cHostPlatformString = " ++ show hostPlatform
+        , ""
+        , "cProjectName          :: String"
+        , "cProjectName          = " ++ show cProjectName
+        , ""
+        , "cBooterVersion        :: String"
+        , "cBooterVersion        = " ++ show cBooterVersion
+        , ""
+        , "cStage                :: String"
+        , "cStage                = show ("++ cStage ++ " :: Int)"
+        ]