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 https://github.com/snowleopard/hadrian/pull/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.

Reviewers: snowleopard, bgamari, goldfire

Reviewed By: snowleopard

Subscribers: rwbarton, carter

GHC Trac Issues: #15938

Differential Revision: https://phabricator.haskell.org/D5412

1 files changed, 218 insertions, 24 deletions

diff --git a/hadrian/src/Rules/Compile.hs b/hadrian/src/Rules/Compile.hs
index 4e85db2df6..74570a1556 100644
--- a/hadrian/src/Rules/Compile.hs
+++ b/hadrian/src/Rules/Compile.hs
@@ -1,39 +1,233 @@
 module Rules.Compile (compilePackage) where
 
+import Hadrian.BuildPath
 import Hadrian.Oracles.TextFile
 
 import Base
 import Context
 import Expression
 import Rules.Generate
+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 and Haskell interface files
+
+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
+
+{- We are using a non uniform representation that separates
+   object files produced from Haskell code and from other
+   languages, because the two "groups" have to be parsed
+   differently enough that this would complicated the parser
+   significantly.
+
+   Indeed, non-Haskell files can only produce .o (or .thr_o, ...)
+   files while Haskell modules can produce those as well as
+   interface files, both in -boot or non-boot variants.
+
+   Moreover, non-Haskell object files live under:
+     <root>/stage<N>/<path/to/pkg>/build/{c,cmm,s}/
+
+   while Haskell object/interface files live under:
+     <root>/stage<N>/<path/to/pkg>/build/
+
+   So the kind of object is partially determined by
+   whether we're in c/, cmm/ or s/ but also by the
+   object file's extension, in the case of a Haskell file.
+   This could have been addressed with some knot-tying but
+   Parsec's monad doesn't give us a MonadFix instance.
+
+   We therefore stick to treating those two type of object
+   files non uniformly.
+-}
+
+-- | 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