From d5d55b4cccb960e092f6ae34b62d575dbb4eadea Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Fri, 15 Jul 2022 15:25:05 +0100 Subject: wip: jsem --- hadrian/hadrian.cabal | 2 ++ hadrian/src/Builder.hs | 4 ++- hadrian/src/Main.hs | 20 +++++++++---- hadrian/src/Rules/Compile.hs | 55 +++++++++++++++++++++--------------- hadrian/src/Rules/Library.hs | 4 +-- hadrian/src/Settings/Builders/Ghc.hs | 12 ++++++-- hadrian/src/Settings/Packages.hs | 11 ++++---- 7 files changed, 68 insertions(+), 40 deletions(-) diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal index a855dda4ba..16618f8e0c 100644 --- a/hadrian/hadrian.cabal +++ b/hadrian/hadrian.cabal @@ -59,6 +59,7 @@ executable hadrian , Hadrian.Package , Hadrian.Target , Hadrian.Utilities + , Hadrian.Semaphore , Oracles.Flag , Oracles.Flavour , Oracles.Setting @@ -155,6 +156,7 @@ executable hadrian , unordered-containers >= 0.2.1 && < 0.3 , text >= 1.2 && < 3 , time + , unix ghc-options: -Wall -Wincomplete-record-updates -Wredundant-constraints diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs index 74e7fd2e77..bde7b884e4 100644 --- a/hadrian/src/Builder.hs +++ b/hadrian/src/Builder.hs @@ -41,6 +41,7 @@ import Packages import GHC.IO.Encoding (getFileSystemEncoding) import qualified Data.ByteString as BS import qualified GHC.Foreign as GHC +import Hadrian.Semaphore -- | C compiler can be used in two different modes: -- * Compile or preprocess a source file. @@ -391,7 +392,8 @@ instance H.Builder Builder where fail "tests failed" Ghc (CompileHs GhcMake) _ -> do - Exit code <- cmd [path] buildArgs + sem <- getJsemSemaphore + Exit code <- withSemaphore sem $ cmd [path] buildArgs when (code /= ExitSuccess) $ do fail "build failed" diff --git a/hadrian/src/Main.hs b/hadrian/src/Main.hs index d2e0ace795..c74a9b5069 100644 --- a/hadrian/src/Main.hs +++ b/hadrian/src/Main.hs @@ -23,6 +23,7 @@ import qualified Rules.Selftest import qualified Rules.SourceDist import qualified Rules.Test import qualified UserSettings +import Hadrian.Semaphore main :: IO () main = do @@ -109,24 +110,31 @@ main = do -- command line options (which happens in shakeArgsOptionsWith, but -- isn't exposed to the user) to the exception handler, which uses the -- verbosity and colour information to decide how much of the error to display. - shake_opts_var <- newIORef options + shake_opts_var <- newIORef (options, NoSemaphore) handleShakeException shake_opts_var $ shakeArgsOptionsWith options CommandLine.optDescrs $ \shake_opts _ targets -> do - writeIORef shake_opts_var shake_opts + sem <- initialiseSemaphore (shakeThreads shake_opts) + let extra' = insertExtra sem (shakeExtra shake_opts) + writeIORef shake_opts_var (shake_opts, sem) let targets' = filter (not . null) $ removeKVs targets Environment.setupEnvironment - return . Just $ (shake_opts, if null targets' + return . Just $ (shake_opts { shakeExtra = extra' }, if null targets' then rules else want targets' >> withoutActions rules) -handleShakeException :: IORef ShakeOptions -> IO a -> IO a +handleShakeException :: IORef (ShakeOptions, GlobalSemaphore) -> IO a -> IO a handleShakeException shake_opts_var shake_run = do args <- getArgs -- Using withArgs here is a bit of a hack but the API doesn't allow another way -- See https://github.com/ndmitchell/shake/issues/811 -- Passing --exception means shake throws an exception rather than -- catching ShakeException and displaying the error itself to the user. - catch (withArgs ("--exception" : args) $ shake_run) $ \(_e :: ShakeException) -> do - shake_opts <- readIORef shake_opts_var + let cleanup_sem = do + (_, sem) <- readIORef shake_opts_var + unlinkSemaphore sem + let action = (withArgs ("--exception" : args) $ shake_run) + `finally` cleanup_sem + catch action $ \(_e :: ShakeException) -> do + (shake_opts, _) <- readIORef shake_opts_var let FailureColour col = lookupExtra red (shakeExtra shake_opts) esc = if shakeColor shake_opts then escape col else id diff --git a/hadrian/src/Rules/Compile.hs b/hadrian/src/Rules/Compile.hs index 96c6ddc93a..5d6b3eabac 100644 --- a/hadrian/src/Rules/Compile.hs +++ b/hadrian/src/Rules/Compile.hs @@ -206,30 +206,39 @@ compileHsObjectAndHi rs objpath = do b@(BuildPath _root stage _path _o) <- parsePath (parseBuildObject root) "" objpath let ctx = objectContext b - way = C.way ctx - lib_ways <- interpretInContext ctx getLibraryWays - ctxPath <- contextPath ctx - -- Need the stamp file, which triggers a rebuild via make - stamp <- pkgStampFile ctx - if way == dynamic && vanilla `elem` lib_ways - then return () - else need [stamp] - - {- - (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath - need (src:deps) - - -- The .dependencies file lists indicating inputs. ghc will - -- generally read more *.hi and *.hi-boot files (direct inputs). - -- Allow such reads (see https://gitlab.haskell.org/ghc/ghc/wikis/Developing-Hadrian#haskell-object-files-and-hi-inputs) - -- Note that this may allow too many *.hi and *.hi-boot files, but - -- calculating the exact set of direct inputs is not feasible. - trackAllow [ "**/*." ++ hisuf way - , "**/*." ++ hibootsuf way - ] + -- Ideally we want to use --make to build with stage0 but we need to use -jsem + -- to recover build-time performance so we only do it for stage1 at the moment. + if isStage0 stage + then compileWithOneShot ctx + else compileWithMake ctx - buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath] - -} + where + compileWithMake ctx = do + -- Need the stamp file, which triggers a rebuild via make + stamp <- pkgStampFile ctx + let way = C.way ctx + lib_ways <- interpretInContext ctx getLibraryWays + -- In this situation -dynamic-too will produce both ways + unless (way == dynamic && vanilla `elem` lib_ways) $ + need [stamp] + + compileWithOneShot ctx = do + let way = C.way ctx + stage = C.stage ctx + ctxPath <- contextPath ctx + (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath + need (src:deps) + + -- The .dependencies file lists indicating inputs. ghc will + -- generally read more *.hi and *.hi-boot files (direct inputs). + -- Allow such reads (see https://gitlab.haskell.org/ghc/ghc/wikis/Developing-Hadrian#haskell-object-files-and-hi-inputs) + -- Note that this may allow too many *.hi and *.hi-boot files, but + -- calculating the exact set of direct inputs is not feasible. + trackAllow [ "**/*." ++ hisuf way + , "**/*." ++ hibootsuf way + ] + + buildWithResources rs $ target ctx (Ghc (CompileHs GhcOneShot) stage) [src] [objpath] compileNonHsObject :: [(Resource, Int)] -> SourceLang -> FilePath -> Action () compileNonHsObject rs lang path = do diff --git a/hadrian/src/Rules/Library.hs b/hadrian/src/Rules/Library.hs index 1a8ea966e0..791ca9313a 100644 --- a/hadrian/src/Rules/Library.hs +++ b/hadrian/src/Rules/Library.hs @@ -18,7 +18,6 @@ import Utilities import Data.Time.Clock import Rules.Generate (generatedDependencies) import Hadrian.Oracles.Cabal (readPackageData) -import Flavour import Oracles.Flag -- * Library 'Rules' @@ -69,7 +68,8 @@ buildPackage root fp = do | pkg <- depPkgs, pkg `elem` stagePkgs ] need deps need (srcs ++ gens) - unless (null srcs) (build $ target ctx (Ghc (CompileHs GhcMake) stage) srcs []) + unless (null srcs) $ do + build $ target ctx (Ghc (CompileHs GhcMake) stage) srcs [] time <- liftIO $ getCurrentTime liftIO $ writeFile fp (show time) ways <- interpretInContext ctx getLibraryWays diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs index 92b259983e..29080f03d6 100644 --- a/hadrian/src/Settings/Builders/Ghc.hs +++ b/hadrian/src/Settings/Builders/Ghc.hs @@ -13,6 +13,7 @@ import qualified Context as Context import Rules.Libffi (libffiName) import qualified Data.Set as Set import System.Directory +import Hadrian.Semaphore ghcBuilderArgs :: Args ghcBuilderArgs = mconcat @@ -62,14 +63,19 @@ compileAndLinkHs = (builder (Ghc . CompileHs) ||^ builder (Ghc LinkHs)) ? do , defaultGhcWarningsArgs , builder (Ghc (CompileHs GhcOneShot)) ? mconcat [ arg "-c" ] - , builder (Ghc (CompileHs GhcMake)) ? mconcat - [ arg "--make" - , arg "-no-link" ] + , builder (Ghc (CompileHs GhcMake)) ? do + jsem <- expr getJsemSemaphore + mconcat + ([ arg "--make" + , arg "-no-link" + ] ) + -- ++ semaphore [] (\name _ -> [ arg "-jsem", arg name]) jsem) , getInputs , notM (builder (Ghc (CompileHs GhcMake))) ? mconcat [arg "-o", arg =<< getOutput] ] + compileC :: Args compileC = builder (Ghc CompileCWithGhc) ? do way <- getWay diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs index 084e609f0a..a9b0f2121d 100644 --- a/hadrian/src/Settings/Packages.hs +++ b/hadrian/src/Settings/Packages.hs @@ -51,6 +51,12 @@ packageArgs = do , package compiler ? mconcat [ builder Alex ? arg "--latin1" + -- These files take a very long time to compile with -O1, + -- so we use -O0 for them just in Stage0 to speed up the + -- build but not affect Stage1+ executables + , builder (Ghc (CompileHs GhcOneShot)) ? inputs ["**/GHC/Hs/Instances.hs", "**/GHC/Driver/Session.hs"] ? stage0 ? + pure ["-O0"] + , builder (Ghc . CompileHs) ? mconcat [ debugAssertions ? notStage0 ? arg "-DDEBUG" @@ -60,11 +66,6 @@ packageArgs = do -- Enable -haddock and -Winvalid-haddock for the compiler , arg "-haddock" , notStage0 ? arg "-Winvalid-haddock" ] - -- These files take a very long time to compile with -O1, - -- so we use -O0 for them just in Stage0 to speed up the - -- build but not affect Stage1+ executables - -- , inputs ["**/GHC/Hs/Instances.hs", "**/GHC/Driver/Session.hs"] ? stage0 ? - -- pure ["-O0"] ] , builder (Cabal Setup) ? mconcat [ arg "--disable-library-for-ghci" -- cgit v1.2.1