From 7ce1b694f7be7fbf6e2d7b7eb0639e61fbe358c6 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sun, 13 Jun 2021 16:02:06 +0530 Subject: 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 --- compiler/Setup.hs | 138 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 138 insertions(+) create mode 100644 compiler/Setup.hs (limited to 'compiler/Setup.hs') 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)" + ] -- cgit v1.2.1