wip: jsemwip/hadrian-jsem

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) "<object file path parser>" 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"