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, 122 insertions, 0 deletions

diff --git a/hadrian/src/Hadrian/BuildPath.hs b/hadrian/src/Hadrian/BuildPath.hs
new file mode 100644
index 0000000000..962475cb38
--- /dev/null
+++ b/hadrian/src/Hadrian/BuildPath.hs
@@ -0,0 +1,122 @@
+module Hadrian.BuildPath where
+
+import Base
+
+import Data.Functor
+import qualified Text.Parsec as Parsec
+
+-- | A path of the form
+--
+-- > <build root>/stage<N>/<path/to/pkg/from/ghc/root>/build/<something>
+--
+-- where @something@ describes a library or object file or ... to be built
+-- for the given package.
+--
+-- @a@, which represents that @something@, is instantiated with library-related
+-- data types in @Rules.Library@ and with object/interface files related types
+-- in @Rules.Compile@.
+data BuildPath a = BuildPath FilePath -- ^ > <build root>/
+                             Stage    -- ^ > stage<N>/
+                             FilePath -- ^ > <path/to/pkg/from/ghc/root>/build/
+                             a        -- ^ > whatever comes after 'build/'
+    deriving (Eq, Show)
+
+-- | Parse a build path under the given build root.
+parseBuildPath
+    :: FilePath -- ^ build root
+    -> Parsec.Parsec String () a -- ^ what to parse after @build/@
+    -> Parsec.Parsec String () (BuildPath a)
+parseBuildPath root afterBuild = do
+    _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+    stage <- parseStage
+    _ <- Parsec.char '/'
+    pkgpath <- Parsec.manyTill Parsec.anyChar
+        (Parsec.try $ Parsec.string "/build/")
+    a <- afterBuild
+    return (BuildPath root stage pkgpath a)
+
+-- To be kept in sync with Stage.hs's stageString function
+-- | Parse @"stageX"@ into a 'Stage'.
+parseStage :: Parsec.Parsec String () Stage
+parseStage = (Parsec.string "stage" *> Parsec.choice
+    [ Parsec.string (show n) $> toEnum n
+    | n <- map fromEnum [minBound .. maxBound :: Stage]
+    ]) Parsec.<?> "stage string"
+
+-- To be kept in sync with the show instances in 'Way.Type', until we perhaps
+-- use some bidirectional parsing/pretty printing approach or library.
+-- | Parse a way suffix, returning the argument when no suffix is found (the
+-- argument will be vanilla in most cases, but dynamic when we parse the way
+-- suffix out of a shared library file name).
+parseWaySuffix :: Way -> Parsec.Parsec String () Way
+parseWaySuffix w = Parsec.choice
+    [ Parsec.char '_' *>
+        (wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.char '_'))
+    , pure w
+    ] Parsec.<?> "way suffix (e.g _thr_p, or none for vanilla)"
+
+-- | 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.
+parsePkgId :: Parsec.Parsec String () (String, [Integer])
+parsePkgId = parsePkgId' "" Parsec.<?> "package identifier (<name>-<version>)"
+  where
+    parsePkgId' currName = do
+        s <- Parsec.many1 Parsec.alphaNum
+        _ <- Parsec.char '-'
+        let newName = if null currName then s else currName ++ "-" ++ s
+        Parsec.choice [ (newName,) <$> parsePkgVersion
+                      , parsePkgId' newName ]
+
+-- | Parse "."-separated integers that describe a package's version.
+parsePkgVersion :: Parsec.Parsec String () [Integer]
+parsePkgVersion = fmap reverse (parsePkgVersion' [])
+       Parsec.<?> "package version"
+  where
+    parsePkgVersion' xs = do
+        n <- parseNatural
+        Parsec.choice
+            [ Parsec.try
+                  (Parsec.lookAhead (Parsec.char '.' *>
+                                        (Parsec.letter <|> Parsec.char '_')
+                                    )
+                  )
+              $> (n:xs)
+            , Parsec.char '.' *> parsePkgVersion' (n:xs)
+            , pure $ (n:xs) ]
+
+-- | Parse a natural number.
+parseNatural :: Parsec.Parsec String () Integer
+parseNatural = (read <$> Parsec.many1 Parsec.digit) Parsec.<?> "natural number"
+
+-- | Runs the given parser against the given path, erroring out when the parser
+-- fails (because it shouldn't if the code from this module is correct).
+parsePath
+    :: Parsec.Parsec String () a -- ^ parser to run
+    -> String                    -- ^ string describing the input source
+    -> FilePath                  -- ^ path to parse
+    -> Action a
+parsePath p inp path = case Parsec.parse p inp path of
+    Left err -> fail $ "Hadrian.BuildPath.parsePath: path="
+                    ++ path ++ ", error:\n" ++ show err
+    Right a  -> pure a