diff options
Diffstat (limited to 'hadrian')
| -rw-r--r-- | hadrian/cfg/system.config.in | 1 | ||||
| -rw-r--r-- | hadrian/hadrian.cabal | 2 | ||||
| -rw-r--r-- | hadrian/src/Builder.hs | 38 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Builder/Git.hs | 13 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Utilities.hs | 13 | ||||
| -rw-r--r-- | hadrian/src/Oracles/ModuleFiles.hs | 1 | ||||
| -rw-r--r-- | hadrian/src/Rules/SourceDist.hs | 224 | ||||
| -rw-r--r-- | hadrian/src/Settings/Builders/Win32Tarballs.hs | 13 | ||||
| -rw-r--r-- | hadrian/src/Settings/Default.hs | 7 |
9 files changed, 202 insertions, 110 deletions
diff --git a/hadrian/cfg/system.config.in b/hadrian/cfg/system.config.in index 860c12fbec..003d9d0029 100644 --- a/hadrian/cfg/system.config.in +++ b/hadrian/cfg/system.config.in @@ -29,6 +29,7 @@ xelatex = @XELATEX@ makeindex = @MAKEINDEX@ makeinfo = @MAKEINFO@ bourne-shell = @SH@ +git = @GIT@ # Python 3 is required to run test driver. # See: https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk#L220 diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal index 1fd2787a5b..13ac5d1362 100644 --- a/hadrian/hadrian.cabal +++ b/hadrian/hadrian.cabal @@ -43,6 +43,7 @@ executable hadrian , Hadrian.Builder.Ar , Hadrian.Builder.Sphinx , Hadrian.Builder.Tar + , Hadrian.Builder.Git , Hadrian.BuildPath , Hadrian.Expression , Hadrian.Haskell.Cabal @@ -103,6 +104,7 @@ executable hadrian , Settings.Builders.Make , Settings.Builders.MergeObjects , Settings.Builders.RunTest + , Settings.Builders.Win32Tarballs , Settings.Builders.Xelatex , Settings.Default , Settings.Flavours.Benchmark diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs index 8ef2f2b411..6da009bda1 100644 --- a/hadrian/src/Builder.hs +++ b/hadrian/src/Builder.hs @@ -3,7 +3,7 @@ module Builder ( -- * Data types ArMode (..), CcMode (..), ConfigurationInfo (..), DependencyType (..), GhcMode (..), GhcPkgMode (..), HaddockMode (..), TestMode(..), SphinxMode (..), - TarMode (..), Builder (..), + TarMode (..), GitMode (..), Builder (..), Win32TarballsMode(..), -- * Builder properties builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilder, @@ -38,6 +38,10 @@ import Oracles.Flag import Oracles.Setting (setting, Setting(..)) import Packages +import GHC.IO.Encoding (getFileSystemEncoding) +import qualified Data.ByteString as BS +import qualified GHC.Foreign as GHC + -- | C compiler can be used in two different modes: -- * Compile or preprocess a source file. -- * Extract source dependencies by passing @-MM@ command line argument. @@ -123,6 +127,21 @@ instance Binary TestMode instance Hashable TestMode instance NFData TestMode +-- | Git is used to create source distributions +data GitMode = ListFiles deriving (Eq, Generic, Show) + +instance Binary GitMode +instance Hashable GitMode +instance NFData GitMode + +data Win32TarballsMode = ListTarballs | VerifyTarballs | DownloadTarballs deriving (Eq, Generic, Show) + +instance Binary Win32TarballsMode +instance Hashable Win32TarballsMode +instance NFData Win32TarballsMode + + + -- | A 'Builder' is a (usually external) command invoked in a separate process -- via 'cmd'. Here are some examples: -- * 'Alex' is a lexical analyser generator that builds @Lexer.hs@ from @Lexer.x@. @@ -163,6 +182,8 @@ data Builder = Alex | Unlit | Xelatex | Makeindex -- ^ from xelatex + | Git GitMode + | Win32Tarballs Win32TarballsMode deriving (Eq, Generic, Show) instance Binary Builder @@ -255,6 +276,19 @@ instance H.Builder Builder where withTempFile $ \temp -> do () <- cmd' [path] (buildArgs ++ ["--only-report-hadrian-deps", temp]) readFile' temp + Git ListFiles -> do + path <- builderPath builder + withResources buildResources $ do + -- NUL separated list of files + -- We need to read this in the filesystem encoding + enc <- liftIO getFileSystemEncoding + Stdout stdout <- cmd' BinaryPipes [path] buildArgs + liftIO $ BS.useAsCStringLen stdout $ \fp -> GHC.peekCStringLen enc fp + Win32Tarballs ListTarballs -> do + path <- builderPath builder + withResources buildResources $ do + Stdout stdout <- cmd' [path] buildArgs + pure stdout _ -> error $ "Builder " ++ show builder ++ " can not be asked!" runBuilderWith :: Builder -> BuildInfo -> Action () @@ -388,8 +422,10 @@ systemBuilderPath builder = case builder of Testsuite _ -> fromKey "python" Sphinx _ -> fromKey "sphinx-build" Tar _ -> fromKey "tar" + Git _ -> fromKey "git" Xelatex -> fromKey "xelatex" Makeindex -> fromKey "makeindex" + Win32Tarballs _ -> fromKey "python" _ -> error $ "No entry for " ++ show builder ++ inCfg where inCfg = " in " ++ quote configFile ++ " file." diff --git a/hadrian/src/Hadrian/Builder/Git.hs b/hadrian/src/Hadrian/Builder/Git.hs new file mode 100644 index 0000000000..6875a48fbd --- /dev/null +++ b/hadrian/src/Hadrian/Builder/Git.hs @@ -0,0 +1,13 @@ +module Hadrian.Builder.Git (gitArgs) where + +import Expression + +-- | Default command line arguments for invoking the archiving utility @tar@. +gitArgs :: Args +gitArgs = mconcat + [ builder (Git ListFiles) ? mconcat + [ arg "ls-files" + , arg "--recurse-submodules" + , arg "-z" + ] + ] diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs index bbb61f68f1..a7d8bacc15 100644 --- a/hadrian/src/Hadrian/Utilities.hs +++ b/hadrian/src/Hadrian/Utilities.hs @@ -18,7 +18,7 @@ module Hadrian.Utilities ( -- * File system operations copyFile, copyFileUntracked, createFileLink, fixFile, makeExecutable, moveFile, removeFile, createDirectory, copyDirectory, - moveDirectory, removeDirectory, + moveDirectory, removeDirectory, removeFile_, -- * Diagnostic info Colour (..), ANSIColour (..), putColoured, shouldUseColor, @@ -54,6 +54,7 @@ import qualified Data.HashMap.Strict as Map import qualified System.Directory.Extra as IO import qualified System.Info.Extra as IO import qualified System.IO as IO +import System.IO.Error (isPermissionError) -- | Extract a value from a singleton list, or terminate with an error message -- if the list does not contain exactly one value. @@ -322,6 +323,15 @@ copyFile source target = do putProgressInfo =<< renderAction "Copy file" source target quietly $ copyFileChanged source target +-- | Remove a file or a link, but don't worry if it fails +removeFile_ :: FilePath -> IO () +removeFile_ x = + (IO.removeFile x >> IO.removeDirectoryLink x) `IO.catch` \e -> + when (isPermissionError e) $ IO.handle (\(_ :: IO.IOException) -> pure ()) $ do + perms <- IO.getPermissions x + IO.setPermissions x perms{IO.readable = True, IO.searchable = True, IO.writable = True} + IO.removeFile x + -- | Copy a file without tracking the source. Create the target directory if missing. copyFileUntracked :: FilePath -> FilePath -> Action () copyFileUntracked source target = do @@ -347,6 +357,7 @@ makeExecutable file = do putProgressInfo $ "| Make " ++ quote file ++ " executable." quietly $ cmd "chmod +x " [file] + -- | Move a file. Note that we cannot track the source, because it is moved. moveFile :: FilePath -> FilePath -> Action () moveFile source target = do diff --git a/hadrian/src/Oracles/ModuleFiles.hs b/hadrian/src/Oracles/ModuleFiles.hs index d2f0299563..b53a5901e1 100644 --- a/hadrian/src/Oracles/ModuleFiles.hs +++ b/hadrian/src/Oracles/ModuleFiles.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Oracles.ModuleFiles ( decodeModule, encodeModule, findGenerator, hsSources, hsObjects, + determineBuilder, moduleFilesOracle ) where diff --git a/hadrian/src/Rules/SourceDist.hs b/hadrian/src/Rules/SourceDist.hs index de35922ae1..4cb9baab5a 100644 --- a/hadrian/src/Rules/SourceDist.hs +++ b/hadrian/src/Rules/SourceDist.hs @@ -1,142 +1,152 @@ module Rules.SourceDist (sourceDistRules) where -import Hadrian.Oracles.DirectoryContents - import Base import Builder import Context import Oracles.Setting import Packages -import Rules.Clean +import Utilities (askWithResources, build) +import Hadrian.Target (target) +import qualified System.Directory.Extra as IO +import qualified Control.Exception.Base as IO +import Oracles.ModuleFiles (determineBuilder) sourceDistRules :: Rules () -sourceDistRules = do +sourceDistRules = alternatives $ do root <- buildRootRules "source-dist" ~> do - -- We clean the source tree first. - -- See https://github.com/snowleopard/hadrian/issues/384. - -- TODO: Do we still need to clean the tree? - cleanSourceTree version <- setting ProjectVersion need [root -/- "source-dist" -/- ("ghc-" ++ version ++ "-src.tar.xz")] + need [root -/- "source-dist" -/- ("ghc-" ++ version ++ "-testsuite.tar.xz")] + need [root -/- "source-dist" -/- ("ghc-" ++ version ++ "-windows-extra-src.tar.xz")] putSuccess "| Done" - root -/- "source-dist" -/- "ghc-*-src.tar.xz" %> \fname -> do - let tarName = takeFileName fname - dropTarXz = dropExtension . dropExtension - treeDir = dropTarXz tarName - treePath = root -/- "source-dist" -/- treeDir - prepareTree treePath - runBuilderWithCmdOptions - [Cwd $ root -/- "source-dist"] - (Tar Create) - ["cJf", tarName, treeDir] - ["cJf", tarName] [treeDir] + + -- Ordering of rules is important so that windows-extra-src matches before src + root -/- "source-dist" -/- "ghc-*-windows-extra-src.tar.xz" %> + archiveSourceTree prepareWindowsExtraTree + root -/- "source-dist" -/- "ghc-*-testsuite.tar.xz" %> + archiveSourceTree prepareTestsuiteTree + root -/- "source-dist" -/- "ghc-*-src.tar.xz" %> + archiveSourceTree prepareTree "GIT_COMMIT_ID" %> \fname -> writeFileChanged fname =<< setting ProjectGitCommitId "VERSION" %> \fname -> writeFileChanged fname =<< setting ProjectVersion + -- Rules to download mingw tarballs + let mingw_tarballs_stamp = "ghc-tarballs/mingw-w64/.mingw-w64.download.stamp" + ["ghc-tarballs/mingw-w64/*/*.tar.*","ghc-tarballs/mingw-w64/*/SHA256SUMS"] |%> \_ -> + need [mingw_tarballs_stamp] + mingw_tarballs_stamp %> \stamp -> do + build (target (vanillaContext Stage1 compiler) (Win32Tarballs DownloadTarballs) [] []) + writeFile' stamp "OK" + + +archiveSourceTree :: (FilePath -> Action ()) -> FilePath -> Action () +archiveSourceTree prepare fname = do + root <- buildRoot + version <- setting ProjectVersion + let dropTarXz = dropExtension . dropExtension + tarName = takeFileName fname + dirName = dropTarXz tarName + baseName = "ghc-" ++ version + treeDir = dirName -/- baseName + treePath = sourceDistRoot -/- treeDir + sourceDistRoot = root -/- "source-dist" + removeDirectory treePath + prepare treePath + runBuilderWithCmdOptions + [Cwd $ sourceDistRoot -/- dirName] + (Tar Create) + ["chJf", ".." -/- tarName, baseName] + ["chJf", ".." -/- tarName] [baseName] + + +-- | This creates a symlink to the 'source' at 'target' +-- $tar -h$ will eventually copy the source into the tarball +-- This is also how `make sdist` works. +-- 1. It preserves relative symlinks +-- 2. It copies non-empty directories also. This is because git includes +-- directories in its output if they are non empty. +copyFileSourceDist :: FilePath -> FilePath -> Action () +copyFileSourceDist source target = do + isSymlink <- liftIO $ IO.pathIsSymbolicLink source + if isSymlink then do + link_target <- liftIO $ IO.getSymbolicLinkTarget source + when (not $ isRelative link_target) $ + error ("source-dist: tried to create non-relative symlink in source dist: " ++ show link_target) + putProgressInfo =<< renderAction ("Create symlink (" ++ link_target ++ ")") source target + isDirectory <- liftIO $ IO.doesDirectoryExist source + when (not isDirectory) $ + need [source] + let createLink src tgt + | isDirectory = liftIO $ IO.createDirectoryLink src tgt + | otherwise = liftIO $ IO.createFileLink src tgt + let dir = takeDirectory target + liftIO $ IO.createDirectoryIfMissing True dir + liftIO $ removeFile_ target + createLink link_target target + else do + isDirectory <- liftIO $ IO.doesDirectoryExist source + if isDirectory then do + contents <- liftIO $ IO.listDirectory source + when (not $ null contents) $ -- Git only includes directories in the output if they are empty + error ("source-dist: non-empty dir" ++ show source) + createDirectory target + else createFileLink source target + +prepareTestsuiteTree :: FilePath -> Action () +prepareTestsuiteTree dest = do + top <- topDirectory + let testsuiteFiles = filter testFilter . split (=='\NUL') + testFilter file = not (null file) && ("testsuite//" ?== file) + files <- testsuiteFiles <$> askWithResources [] (target (vanillaContext Stage1 compiler) (Git ListFiles) [] []) + forM_ files $ \source -> do + let target = dest -/- source + copyFileSourceDist (top -/- source) target + +prepareWindowsExtraTree :: FilePath -> Action () +prepareWindowsExtraTree dest = do + top <- topDirectory + + files <- lines <$> askWithResources [] (target (vanillaContext Stage1 compiler) (Win32Tarballs ListTarballs) [] []) + need files + build (target (vanillaContext Stage1 compiler) (Win32Tarballs VerifyTarballs) [] []) + + createDirectory dest + liftIO $ IO.createFileLink (top -/- "ghc-tarballs") (dest -/- "ghc-tarballs") + prepareTree :: FilePath -> Action () prepareTree dest = do - root <- buildRoot - mapM_ cpDir srcDirs - mapM_ cpFile srcFiles - copyAlexHappyFiles root + out <- askWithResources [] (target (vanillaContext Stage1 compiler) (Git ListFiles) [] []) + top <- topDirectory + let files = ["GIT_COMMIT_ID", "VERSION"] ++ getFiles out + need ["GIT_COMMIT_ID", "VERSION"] + forM_ files $ \source -> do + let target = dest -/- source + copyFileSourceDist (top -/- source) target + copyAlexHappyFiles where - copyAlexHappyFiles root = + getFiles = filter treeFilter . split (=='\NUL') + treeFilter file = not (null file) && not ("testsuite//" ?== file) + + copyAlexHappyFiles = forM_ alexHappyFiles $ \(stg, pkg, inp, out) -> do - let dir = root -/- buildDir (Context stg pkg vanilla) + let ctx = Context stg pkg vanilla srcInputFile = dest -/- pkgPath pkg -/- inp + generatedFile = dest -/- pkgPath pkg -/- out + Just builder = determineBuilder stg inp + -- We first make sure that the generated file is... generated. - need [ dir -/- out ] - -- We then copy the generated file in the source dist, right - -- next to the input file. - copyFile (dir -/- out) - (dest -/- pkgPath pkg -/- out) + build $ target ctx builder [srcInputFile] [generatedFile] + -- We finally add a ".source" suffix to the input file to -- prevent it from being used when building GHC, since the -- generated file being there already should prevent -- the need for the original input. moveFile srcInputFile (srcInputFile <.> "source") - cpFile a = copyFile a (dest -/- a) - cpDir a = copyDirectoryContents (Not excluded) a (dest -/- a) - excluded = Or - [ Test "**/.*" - , Test "**/#*" - , Test "**/*-SAVE" - , Test "**/*.orig" - , Test "**/*.rej" - , Test "**/*~" - , Test "**/autom4te*" - , Test "**/dist" - , Test "**/dist-install" - , Test "**/log" - , Test "**/stage0" - , Test "**/stage1" - , Test "**/stage2" - , Test "**/stage3" - , Test "hadrian/.cabal-sandbox" - , Test "hadrian/.stack-work" - , Test "hadrian/UserSettings.hs" - , Test "hadrian/cabal.sandbox.config" - , Test "hadrian/cfg/system.config" - , Test "hadrian/bin" - , Test "hadrian/dist" - , Test "hadrian/dist-newstyle" - , Test "libraries/**/*.buildinfo" - , Test "libraries/**/GNUmakefile" - , Test "libraries/**/config.log" - , Test "libraries/**/config.status" - , Test "libraries/**/ghc.mk" - , Test "libraries/**/include/Hs*Config.h" - , Test "libraries/dph" - , Test "libraries/primitive" - , Test "libraries/random" - , Test "libraries/vector" - , Test "rts/rts.cabal" - , Test "mk/build.mk" ] - srcDirs = - [ "bindisttest" - , "compiler" - , "distrib" - , "docs" - , "docs" - , "driver" - , "ghc" - , "hadrian" - , "includes" - , "libffi" - , "libffi-tarballs" - , "libraries" - , "mk" - , "rts" - , "rules" - , "utils" - , "m4" ] - srcFiles = - [ "GIT_COMMIT_ID" - , "HACKING.md" - , "INSTALL.md" - , "LICENSE" - , "MAKEHELP.md" - , "Makefile" - , "README.md" - , "VERSION" - , "aclocal.m4" - , "boot" - , "config.guess" - , "config.sub" - , "configure" - , "configure.ac" - , "ghc.mk" - , "install-sh" - , "packages" - , "llvm-targets" - , "llvm-passes" - ] - -- (stage, package, input file, output file) alexHappyFiles = [ (Stage0, compiler, "GHC/Cmm/Parser.y", "GHC/Cmm/Parser.hs") diff --git a/hadrian/src/Settings/Builders/Win32Tarballs.hs b/hadrian/src/Settings/Builders/Win32Tarballs.hs new file mode 100644 index 0000000000..7be63d4f86 --- /dev/null +++ b/hadrian/src/Settings/Builders/Win32Tarballs.hs @@ -0,0 +1,13 @@ +module Settings.Builders.Win32Tarballs (win32TarballsArgs) where + +import Settings.Builders.Common + +win32TarballsArgs :: Args +win32TarballsArgs = do + scriptPath <- expr $ (-/- "mk" -/- "get-win32-tarballs.py") <$> topDirectory + expr $ need [scriptPath] + mconcat + [ builder (Win32Tarballs DownloadTarballs) ? pure [scriptPath, "download", "all"] + , builder (Win32Tarballs ListTarballs) ? pure [scriptPath, "list", "all"] + , builder (Win32Tarballs VerifyTarballs) ? pure [scriptPath, "verify", "all"] + ] diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs index a20a1d821d..93b14d0f7e 100644 --- a/hadrian/src/Settings/Default.hs +++ b/hadrian/src/Settings/Default.hs @@ -43,6 +43,8 @@ import Settings.Builders.RunTest import Settings.Builders.Xelatex import Settings.Packages import Settings.Warnings +import qualified Hadrian.Builder.Git +import Settings.Builders.Win32Tarballs -- | Packages that are built by default. You can change this in "UserSettings". defaultPackages :: Stage -> Action [Package] @@ -261,6 +263,7 @@ defaultBuilderArgs = mconcat , runTestBuilderArgs , validateBuilderArgs , xelatexBuilderArgs + , win32TarballsArgs -- Generic builders from the Hadrian library: , builder (Ar Pack ) ? Hadrian.Builder.Ar.args Pack , builder (Ar Unpack ) ? Hadrian.Builder.Ar.args Unpack @@ -269,7 +272,9 @@ defaultBuilderArgs = mconcat , builder (Sphinx ManMode ) ? Hadrian.Builder.Sphinx.args ManMode , builder (Sphinx InfoMode ) ? Hadrian.Builder.Sphinx.args InfoMode , builder (Tar Create ) ? Hadrian.Builder.Tar.args Create - , builder (Tar Extract ) ? Hadrian.Builder.Tar.args Extract ] + , builder (Tar Extract ) ? Hadrian.Builder.Tar.args Extract + , Hadrian.Builder.Git.gitArgs + ] -- | All 'Package'-dependent command line arguments. defaultPackageArgs :: Args |