hadrian: optimise Rules.Compile

Previously, as reported in #15938, resuming a build "in the middle",
e.g when building _build/stage1/libraries/base/, hadrian would take up to
a whole minute to get started doing actual work, building code.

This was mostly due to a big enumeration that we do in Rules.hs, to generate
all the possible patterns for object files for 1) all ways, 2) all packages
and 3) all stages. Since rule enumeration is always performed, whatever the
target, we were always paying this cost, which seemed to grow bigger the
farther in the build we stopped and were resuming from.

Instead, this patch borrows the approach that we took for Rules.Library in
snowleopard/hadrian#571, which exposes all the
relevant object files under as few catch-all rules as possible (8 here),
and parses all the information we need out of the object's path.

The concrete effect of this patch that I have observed is to reduce the
45-60 seconds pause to <5 seconds. Along with the Shake performance
improvements that Neil mentions in #15938, most of the pause should
effectively disappear.

hadrian/src/Rules.hs

@@ -94,18 +94,9 @@ packageRules = do
     let readPackageDb  = [(packageDb, 1)]
         writePackageDb = [(packageDb, maxConcurrentReaders)]
 
-    let contexts        = liftM3 Context        allStages knownPackages allWays
-        vanillaContexts = liftM2 vanillaContext allStages knownPackages
+    let vanillaContexts = liftM2 vanillaContext allStages knownPackages
 
-    -- TODO: we might want to look into converting more and more
-    --       rules to the style introduced in Rules.Library in
-    --       https://github.com/snowleopard/hadrian/pull/571,
-    --       where "catch-all" rules are used to "catch" the need
-    --       for library files, and we then use parsec parsers to
-    --       extract all sorts of information needed to build them, like
-    --       the package, the stage, the way, etc.
-
-    forM_ contexts (Rules.Compile.compilePackage readPackageDb)
+    Rules.Compile.compilePackage readPackageDb
 
     Rules.Program.buildProgram readPackageDb
 

hadrian/src/Rules/Compile.hs

@@ -6,34 +6,199 @@ import Base
 import Context
 import Expression
 import Rules.Generate
+import Rules.Library
+import Settings
+import Settings.Default
 import Target
 import Utilities
 
-compilePackage :: [(Resource, Int)] -> Context -> Rules ()
-compilePackage rs context@Context {..} = do
+import qualified Text.Parsec as Parsec
+
+-- * Rules for building objects
+
+compilePackage :: [(Resource, Int)] -> Rules ()
+compilePackage rs = do
     root <- buildRootRules
-    let dir             = root -/- buildDir context
-        nonHs extension = dir -/- extension <//> "*" <.> osuf way
-        compile compiler obj2src obj = do
-            src <- obj2src context obj
-            need [src]
-            needDependencies context src $ obj <.> "d"
-            buildWithResources rs $ target context (compiler stage) [src] [obj]
-        compileHs = \[obj, _hi] -> do
-            path <- contextPath context
-            (src, deps) <- lookupDependencies (path -/- ".dependencies") obj
-            need $ src : deps
-            needLibrary =<< contextDependencies context
-            buildWithResources rs $ target context (Ghc CompileHs stage) [src] [obj]
-
-    priority 2.0 $ do
-        nonHs "c"   %> compile (Ghc CompileCWithGhc) (obj2src "c"   $ const False     )
-        nonHs "cmm" %> compile (Ghc CompileHs)       (obj2src "cmm" isGeneratedCmmFile)
-        nonHs "s"   %> compile (Ghc CompileHs)       (obj2src "S"   $ const False     )
-
-    -- TODO: Add dependencies for #include of .h and .hs-incl files (gcc -MM?).
-    [ dir <//> "*" <.> suf way | suf <- [    osuf,     hisuf] ] &%> compileHs
-    [ dir <//> "*" <.> suf way | suf <- [obootsuf, hibootsuf] ] &%> compileHs
+
+    -- We match all file paths that look like:
+    --   <root>/...stuffs.../build/...stuffs.../<something>.<suffix>
+    --
+    -- where:
+    --   - the '...stuffs...' bits can be one or more path components,
+    --   - the '<suffix>' part is a way prefix (e.g thr_p_, or nothing if vanilla)
+    --     followed by an object file extension, without the dot (o, o-boot, hi,
+    --     hi-boot)
+    --
+    -- and parse the information we need (stage, package path, ...) from
+    -- the path and figure out the suitable way to produce that object file.
+    objectFilesUnder root |%> \path -> do
+      obj <- parsePath (parseBuildObject root) "<object file path parser>" path
+      compileObject rs path obj
+
+  where
+    objectFilesUnder r = [ r -/- ("**/build/**/*" ++ pat)
+                         | pat <- extensionPats
+                         ]
+
+    exts = [ "o", "hi", "o-boot", "hi-boot" ]
+    patternsFor e = [ "." ++ e, ".*_" ++ e ]
+    extensionPats = concatMap patternsFor exts
+
+-- * Object file paths types and parsers
+
+-- | Non Haskell source languages that we compile to get object files.
+data SourceLang = Asm | C | Cmm
+  deriving (Eq, Show)
+
+parseSourceLang :: Parsec.Parsec String () SourceLang
+parseSourceLang = Parsec.choice
+  [ Parsec.char 'c' *> Parsec.choice
+      [ Parsec.string "mm" *> pure Cmm
+      , pure C
+      ]
+  , Parsec.char 's' *> pure Asm
+  ]
+
+type Basename = String
+
+parseBasename :: Parsec.Parsec String () Basename
+parseBasename = Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.char '.')
+
+-- | > <c|cmm|s>/<file>.<way prefix>_o
+data NonHsObject = NonHsObject SourceLang Basename Way
+  deriving (Eq, Show)
+
+parseNonHsObject :: Parsec.Parsec String () NonHsObject
+parseNonHsObject = do
+  lang <- parseSourceLang
+  _ <- Parsec.char '/'
+  file <- parseBasename
+  way <- parseWayPrefix vanilla
+  _ <- Parsec.char 'o'
+  return (NonHsObject lang file way)
+
+-- | > <o|hi|o-boot|hi-boot>
+data SuffixType = O | Hi | OBoot | HiBoot
+  deriving (Eq, Show)
+
+parseSuffixType :: Parsec.Parsec String () SuffixType
+parseSuffixType = Parsec.choice
+  [ Parsec.char 'o' *> Parsec.choice
+      [ Parsec.string "-boot" *> pure OBoot
+      , pure O
+      ]
+  , Parsec.string "hi" *> Parsec.choice
+      [ Parsec.string "-boot" *> pure HiBoot
+      , pure Hi
+      ]
+  ]
+
+-- | > <way prefix>_<o|hi|o-boot|hi-boot>
+data Extension = Extension Way SuffixType
+  deriving (Eq, Show)
+
+parseExtension :: Parsec.Parsec String () Extension
+parseExtension =
+  Extension <$> parseWayPrefix vanilla <*> parseSuffixType
+
+-- | > <file>.<way prefix>_<o|hi|o-boot|hi-boot>
+data HsObject = HsObject Basename Extension
+  deriving (Eq, Show)
+
+parseHsObject :: Parsec.Parsec String () HsObject
+parseHsObject = do
+  file <- parseBasename
+  ext <- parseExtension
+  return (HsObject file ext)
+
+data Object = Hs HsObject | NonHs NonHsObject
+  deriving (Eq, Show)
+
+parseObject :: Parsec.Parsec String () Object
+parseObject = Parsec.choice
+  [ NonHs <$> parseNonHsObject
+  , Hs    <$> parseHsObject
+  ]
+
+-- * Toplevel parsers
+
+parseBuildObject :: FilePath -> Parsec.Parsec String () (BuildPath Object)
+parseBuildObject root = parseBuildPath root parseObject
+
+-- * Getting contexts from objects
+
+objectContext :: BuildPath Object -> Action Context
+objectContext (BuildPath _ stage pkgpath obj) = do
+  pkg <- getPackageFromPath pkgpath
+  return (Context stage pkg way)
+
+  where way = case obj of
+          NonHs (NonHsObject _lang _file w)      -> w
+          Hs (HsObject _file (Extension w _suf)) -> w
+
+        getPackageFromPath path = do
+          pkgs <- getPackages
+          case filter (\p -> pkgPath p == path) pkgs of
+            (p:_) -> return p
+            _     -> error $ "couldn't find a package with path: " ++ path
+
+        getPackages = do
+          pkgs <- stagePackages stage
+          testPkgs <- testsuitePackages
+          return $ pkgs ++ if stage == Stage1 then testPkgs else []
+
+-- * Building an object
+
+compileHsObject
+  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> HsObject -> Action ()
+compileHsObject rs objpath b@(BuildPath _root stage _path _o) hsobj =
+  case hsobj of
+    HsObject _basename (Extension _way Hi)     ->
+      need [ change "hi" "o" objpath ]
+    HsObject _basename (Extension _way HiBoot) ->
+      need [ change "hi-boot" "o-boot" objpath ]
+    HsObject _basename (Extension _way _suf)   -> do
+      ctx <- objectContext b
+      ctxPath <- contextPath ctx
+      (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
+      need (src:deps)
+      needLibrary =<< contextDependencies ctx
+      buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath]
+
+  where change oldSuffix newSuffix str
+          | not (oldSuffix `isSuffixOf` str) = error $ "compileHsObject.change: " ++ oldSuffix ++ " not a suffix of " ++ str
+          | otherwise = take (length str - length oldSuffix) str
+                     ++ newSuffix
+
+compileNonHsObject
+  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> NonHsObject -> Action ()
+compileNonHsObject rs objpath b@(BuildPath _root stage _path _o) nonhsobj =
+  case nonhsobj of
+    NonHsObject lang _basename _way ->
+      go (builderFor lang) (toSrcFor lang)
+
+  where builderFor C = Ghc CompileCWithGhc
+        builderFor _ = Ghc CompileHs
+
+        toSrcFor Asm = obj2src "S"   (const False)
+        toSrcFor C   = obj2src "c"   (const False)
+        toSrcFor Cmm = obj2src "cmm" isGeneratedCmmFile
+
+        go builder tosrc = do
+          ctx <- objectContext b
+          src <- tosrc ctx objpath
+          need [src]
+          needDependencies ctx src (objpath <.> "d")
+          buildWithResources rs $ target ctx (builder stage) [src] [objpath]
+
+compileObject
+  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> Action ()
+compileObject rs objpath b@(BuildPath _root _stage _path (Hs o)) =
+  compileHsObject rs objpath b o
+compileObject rs objpath b@(BuildPath _root _stage _path (NonHs o)) =
+  compileNonHsObject rs objpath b o
+
+-- * Helpers
 
 -- | Discover dependencies of a given source file by iteratively calling @gcc@
 -- in the @-MM -MG@ mode and building generated dependencies if they are missing

hadrian/src/Rules/Library.hs

@@ -1,4 +1,4 @@
-module Rules.Library (libraryRules) where
+module Rules.Library {- (libraryRules) -} where
 
 import Data.Functor
 import Hadrian.Haskell.Cabal
@@ -251,18 +251,30 @@ parseStage = (Parsec.string "stage" *> Parsec.choice
 -- suffix out of a shared library file name).
 parseWaySuffix :: Way -> Parsec.Parsec String () Way
 parseWaySuffix w = Parsec.choice
-    [ Parsec.string "_" *> (wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.string "_"))
+    [ Parsec.char '_' *> (wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.char '_'))
     , pure w
     ] Parsec.<?> "way suffix (e.g _thr_p, or none for vanilla)"
-  where
-    parseWayUnit = Parsec.choice
-        [ Parsec.string "thr" *> pure Threaded
-        , Parsec.char   'd'   *>
-          (Parsec.choice [ Parsec.string "ebug" *> pure Debug
-                         , Parsec.string "yn"   *> pure Dynamic ])
-        , Parsec.char 'p'     *> pure Profiling
-        , Parsec.char 'l'     *> pure Logging
-        ] Parsec.<?> "way unit (thr, debug, dyn, p, l)"
+
+-- | Same as 'parseWaySuffix', but for parsing e.g @thr_p_@
+--   instead of @_thr_p@, like 'parseWaySuffix' does.
+--
+--   This is used to parse paths to object files,
+--   in Rules.Compile.
+parseWayPrefix :: Way -> Parsec.Parsec String () Way
+parseWayPrefix w = Parsec.choice
+    [ wayFromUnits <$> Parsec.endBy1 parseWayUnit (Parsec.char '_')
+    , pure w
+    ] Parsec.<?> "way prefix (e.g thr_p_, or none for vanilla)"
+
+parseWayUnit :: Parsec.Parsec String () WayUnit
+parseWayUnit = Parsec.choice
+    [ Parsec.string "thr" *> pure Threaded
+    , Parsec.char   'd'   *>
+      (Parsec.choice [ Parsec.string "ebug" *> pure Debug
+                     , Parsec.string "yn"   *> pure Dynamic ])
+    , Parsec.char 'p'     *> pure Profiling
+    , Parsec.char 'l'     *> pure Logging
+    ] Parsec.<?> "way unit (thr, debug, dyn, p, l)"
 
 -- | Parse a @"pkgname-pkgversion"@ string into the package name and the
 -- integers that make up the package version.