hadrian: eliminate most of the remaining big rule enumerations

Following what was done to Rules.Library some time ago and to
Rules.Compile recently (D5412), this patch moves more rules away from
the "enumerate a lot of contexts and generate one rule for each" style
and instead uses the "parse data from file path to recover context"
approach. In fact, the only rules left to convert seem to be the ones
from Rules.Generate.

This effectively decreases the pauses described in #15938 further as
well as the amount of allocations and GC that we do, unsurprisingly.
Nowhere as drastically as D5412, though.

Test Plan: perform full build and generate docs

Reviewers: snowleopard, bgamari

Reviewed By: snowleopard

Subscribers: rwbarton, carter

GHC Trac Issues: #15938

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

6 files changed, 213 insertions, 104 deletions

diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs
index 0e55087b7d..69a151c206 100644
--- a/hadrian/src/Rules.hs
+++ b/hadrian/src/Rules.hs
@@ -95,15 +95,12 @@ packageRules = do
         writePackageDb = [(packageDb, maxConcurrentReaders)]
 
     Rules.Compile.compilePackage readPackageDb
+    Rules.Dependencies.buildPackageDependencies readPackageDb
+    Rules.Documentation.buildPackageDocumentation
+    Rules.Program.buildProgramRules readPackageDb
+    Rules.Register.configurePackageRules
 
-    Rules.Program.buildProgram readPackageDb
-
-    forM_ [Stage0 .. ] $ \stage ->
-        -- we create a dummy context, that has the correct state, but contains
-        -- @dummyPackage@ as a... dummy package. The package isn't accessed but the record
-        -- need to be set properly. @undefined@ is not an option as it ends up
-        -- being forced.
-        Rules.Register.registerPackage writePackageDb (Context stage dummyPackage vanilla)
+    forM_ [Stage0, Stage1] (Rules.Register.registerPackageRules writePackageDb)
 
     -- TODO: Can we get rid of this enumeration of contexts? Since we iterate
     --       over it to generate all 4 types of rules below, all the time, we
@@ -111,11 +108,7 @@ packageRules = do
     --       Rules.Compile and Rules.Library could save us some time there.
     let vanillaContexts = liftM2 vanillaContext allStages knownPackages
 
-    forM_ vanillaContexts $ mconcat
-        [ Rules.Register.configurePackage
-        , Rules.Dependencies.buildPackageDependencies readPackageDb
-        , Rules.Documentation.buildPackageDocumentation
-        , Rules.Generate.generatePackageCode ]
+    forM_ vanillaContexts Rules.Generate.generatePackageCode
 
 buildRules :: Rules ()
 buildRules = do
diff --git a/hadrian/src/Rules/Dependencies.hs b/hadrian/src/Rules/Dependencies.hs
index 9589d12aa0..8b09a82b56 100644
--- a/hadrian/src/Rules/Dependencies.hs
+++ b/hadrian/src/Rules/Dependencies.hs
@@ -6,25 +6,33 @@ import Data.Function
 import Base
 import Context
 import Expression
+import Hadrian.BuildPath
 import Oracles.ModuleFiles
 import Rules.Generate
+import Settings.Default
 import Target
 import Utilities
 
-buildPackageDependencies :: [(Resource, Int)] -> Context -> Rules ()
-buildPackageDependencies rs context@Context {..} = do
+import qualified Text.Parsec as Parsec
+
+buildPackageDependencies :: [(Resource, Int)] -> Rules ()
+buildPackageDependencies rs = do
     root <- buildRootRules
-    root -/- contextDir context -/- ".dependencies.mk" %> \mk -> do
+    root -/- "**/.dependencies.mk" %> \mk -> do
+        depfile <- getDepMkFile root mk
+        context <- depMkFileContext depfile
         srcs <- hsSources context
         need srcs
         orderOnly =<< interpretInContext context generatedDependencies
         if null srcs
         then writeFileChanged mk ""
         else buildWithResources rs $
-            target context (Ghc FindHsDependencies stage) srcs [mk]
+            target context
+                   (Ghc FindHsDependencies $ Context.stage context)
+                   srcs [mk]
         removeFile $ mk <.> "bak"
 
-    root -/- contextDir context -/- ".dependencies" %> \deps -> do
+    root -/- "**/.dependencies" %> \deps -> do
         mkDeps <- readFile' (deps <.> "mk")
         writeFileChanged deps . unlines
                               . map (\(src, deps) -> unwords $ src : deps)
@@ -33,3 +41,24 @@ buildPackageDependencies rs context@Context {..} = do
                               . groupBy ((==) `on` fst)
                               . sortBy (compare `on` fst)
                               $ parseMakefile mkDeps
+
+
+data DepMkFile = DepMkFile Stage FilePath
+  deriving (Eq, Show)
+
+parseDepMkFile :: FilePath -> Parsec.Parsec String () DepMkFile
+parseDepMkFile root = do
+  _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+  stage <- parseStage
+  _ <- Parsec.char '/'
+  pkgPath <- Parsec.manyTill Parsec.anyChar
+    (Parsec.try $ Parsec.string "/.dependencies.mk")
+  return (DepMkFile stage pkgPath)
+
+getDepMkFile :: FilePath -> FilePath -> Action DepMkFile
+getDepMkFile root = parsePath (parseDepMkFile root) "<dependencies file>"
+
+depMkFileContext :: DepMkFile -> Action Context
+depMkFileContext (DepMkFile stage pkgpath) = do
+  pkg <- getPackageByPath pkgpath
+  return (Context stage pkg vanilla)
diff --git a/hadrian/src/Rules/Documentation.hs b/hadrian/src/Rules/Documentation.hs
index 963bc4c5a0..f1a7454fbb 100644
--- a/hadrian/src/Rules/Documentation.hs
+++ b/hadrian/src/Rules/Documentation.hs
@@ -6,6 +6,7 @@ module Rules.Documentation (
     haddockDependencies
     ) where
 
+import Hadrian.BuildPath
 import Hadrian.Haskell.Cabal
 import Hadrian.Haskell.Cabal.Type
 
@@ -21,6 +22,7 @@ import Target
 import Utilities
 
 import Data.List (union)
+import qualified Text.Parsec as Parsec
 
 docRoot :: FilePath
 docRoot = "docs"
@@ -138,26 +140,28 @@ allHaddocks :: Action [FilePath]
 allHaddocks = do
     pkgs <- stagePackages Stage1
     sequence [ pkgHaddockFile $ vanillaContext Stage1 pkg
-             | pkg <- pkgs, isLibrary pkg ]
+             | pkg <- pkgs, isLibrary pkg, pkgName pkg /= "rts" ]
 
 -- Note: this build rule creates plenty of files, not just the .haddock one.
 -- All of them go into the 'docRoot' subdirectory. Pedantically tracking all
 -- built files in the Shake database seems fragile and unnecessary.
-buildPackageDocumentation :: Context -> Rules ()
-buildPackageDocumentation context@Context {..} = when (stage == Stage1 && package /= rts) $ do
+buildPackageDocumentation :: Rules ()
+buildPackageDocumentation = do
     root <- buildRootRules
 
     -- Per-package haddocks
-    root -/- htmlRoot -/- "libraries" -/- pkgName package -/- "haddock-prologue.txt" %> \file -> do
+    root -/- htmlRoot -/- "libraries/*/haddock-prologue.txt" %> \file -> do
+        ctx <- getPkgDocTarget root file >>= pkgDocContext
         need [root -/- haddockHtmlLib]
         -- This is how @ghc-cabal@ used to produces "haddock-prologue.txt" files.
-        syn  <- pkgSynopsis    package
-        desc <- pkgDescription package
+        syn  <- pkgSynopsis    (Context.package ctx)
+        desc <- pkgDescription (Context.package ctx)
         let prologue = if null desc then syn else desc
         liftIO $ writeFile file prologue
 
-    root -/- htmlRoot -/- "libraries" -/- pkgName package -/- pkgName package <.> "haddock" %> \file -> do
-        need [root -/- htmlRoot -/- "libraries" -/- pkgName package -/- "haddock-prologue.txt"]
+    root -/- htmlRoot -/- "libraries/*/*.haddock" %> \file -> do
+        context <- getPkgDocTarget root file >>= pkgDocContext
+        need [ takeDirectory file  -/- "haddock-prologue.txt"]
         haddocks <- haddockDependencies context
 
         -- `ghc-prim` has a source file for 'GHC.Prim' which is generated just
@@ -176,6 +180,35 @@ buildPackageDocumentation context@Context {..} = when (stage == Stage1 && packag
         let haddockWay = if dynamicPrograms then dynamic else vanilla
         build $ target (context {way = haddockWay}) (Haddock BuildPackage) srcs [file]
 
+data PkgDocTarget = DotHaddock PackageName | HaddockPrologue PackageName
+  deriving (Eq, Show)
+
+pkgDocContext :: PkgDocTarget -> Action Context
+pkgDocContext target = case findPackageByName pkgname of
+  Nothing -> error $ "pkgDocContext: couldn't find package " ++ pkgname
+  Just p  -> return (Context Stage1 p vanilla)
+
+  where pkgname = case target of
+          DotHaddock n      -> n
+          HaddockPrologue n -> n
+
+parsePkgDocTarget :: FilePath -> Parsec.Parsec String () PkgDocTarget
+parsePkgDocTarget root = do
+  _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+  _ <- Parsec.string (htmlRoot ++ "/")
+  _ <- Parsec.string "libraries/"
+  pkgname <- Parsec.manyTill Parsec.anyChar (Parsec.char '/')
+  Parsec.choice
+    [ Parsec.try (Parsec.string "haddock-prologue.txt")
+        *> pure (HaddockPrologue pkgname)
+    , Parsec.string (pkgname <.> "haddock")
+        *> pure (DotHaddock pkgname)
+    ]
+
+getPkgDocTarget :: FilePath -> FilePath -> Action PkgDocTarget
+getPkgDocTarget root path =
+  parsePath (parsePkgDocTarget root) "<doc target>" path
+
 -------------------------------------- PDF -------------------------------------
 
 -- | Build all PDF documentation
diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs
index aeed0268f8..316cc44fb5 100644
--- a/hadrian/src/Rules/Program.hs
+++ b/hadrian/src/Rules/Program.hs
@@ -1,4 +1,4 @@
-module Rules.Program (buildProgram) where
+module Rules.Program (buildProgramRules) where
 
 import Hadrian.Haskell.Cabal
 import Hadrian.Haskell.Cabal.Type
@@ -15,62 +15,71 @@ import Target
 import Utilities
 
 -- | TODO: Drop code duplication
-buildProgram :: [(Resource, Int)] -> Rules ()
-buildProgram rs = do
+buildProgramRules :: [(Resource, Int)] -> Rules ()
+buildProgramRules rs = do
     root <- buildRootRules
     forM_ [Stage0 ..] $ \stage ->
         [ root -/- stageString stage -/- "bin"     -/- "*"
         , root -/- stageString stage -/- "lib/bin" -/- "*" ] |%> \bin -> do
-            -- This is quite inefficient, but we can't access 'programName' from
-            -- 'Rules', because it is an 'Action' depending on an oracle.
-            sPackages <- filter isProgram <$> stagePackages stage
-            tPackages <- testsuitePackages
-            -- TODO: Shall we use Stage2 for testsuite packages instead?
-            let allPackages = sPackages
-                           ++ if stage == Stage1 then tPackages else []
-            nameToCtxList <- fmap concat . forM allPackages $ \pkg -> do
-                -- the iserv pkg results in three different programs at
-                -- the moment, ghc-iserv (built the vanilla way),
-                -- ghc-iserv-prof (built the profiling way), and
-                -- ghc-iserv-dyn (built the dynamic way).
-                -- The testsuite requires all to be present, so we
-                -- make sure that we cover these
-                -- "prof-build-under-other-name" cases.
-                -- iserv gets its names from Packages.hs:programName
-                let allCtxs = [ vanillaContext stage pkg
-                              , Context stage pkg profiling
-                              , Context stage pkg dynamic
-                              ]
-                forM allCtxs $ \ctx -> do
-                    name <- programName ctx
-                    return (name <.> exe, ctx)
+            programContexts <- getProgramContexts stage
+            case lookupProgramContext bin programContexts of
+                Nothing  -> error $ "Unknown program " ++ show bin
+                Just ctx -> buildProgram bin ctx rs
 
-            case lookup (takeFileName bin) nameToCtxList of
-                Nothing -> error $ "Unknown program " ++ show bin
-                Just ctx@(Context {..}) -> do
-                    -- Custom dependencies: this should be modeled better in the
-                    -- Cabal file somehow.
-                    -- TODO: Is this still needed? See 'runtimeDependencies'.
-                    when (package == hsc2hs) $ do
-                        -- 'Hsc2hs' needs the @template-hsc.h@ file.
-                        template <- templateHscPath stage
-                        need [template]
-                    when (package == ghc) $ do
-                        -- GHC depends on @settings@, @platformConstants@,
-                        -- @llvm-targets@, @ghc-usage.txt@, @ghci-usage.txt@,
-                        -- @llvm-passes@.
-                        need =<< ghcDeps stage
+getProgramContexts :: Stage -> Action [(FilePath, Context)]
+getProgramContexts stage = do
+  -- This is quite inefficient, but we can't access 'programName' from
+  -- 'Rules', because it is an 'Action' depending on an oracle.
+  sPackages <- filter isProgram <$> stagePackages stage
+  tPackages <- testsuitePackages
+  -- TODO: Shall we use Stage2 for testsuite packages instead?
+  let allPackages = sPackages
+                ++ if stage == Stage1 then tPackages else []
+  fmap concat . forM allPackages $ \pkg -> do
+    -- the iserv pkg results in three different programs at
+    -- the moment, ghc-iserv (built the vanilla way),
+    -- ghc-iserv-prof (built the profiling way), and
+    -- ghc-iserv-dyn (built the dynamic way).
+    -- The testsuite requires all to be present, so we
+    -- make sure that we cover these
+    -- "prof-build-under-other-name" cases.
+    -- iserv gets its names from Packages.hs:programName
+    let allCtxs = [ vanillaContext stage pkg
+                  , Context stage pkg profiling
+                  , Context stage pkg dynamic
+                  ]
+    forM allCtxs $ \ctx -> do
+      name <- programName ctx
+      return (name <.> exe, ctx)
 
-                    cross <- flag CrossCompiling
-                    -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@.
-                    case (cross, stage) of
-                        (True, s) | s > Stage0 -> do
-                            srcDir <- buildRoot <&> (-/- (stageString Stage0 -/- "bin"))
-                            copyFile (srcDir -/- takeFileName bin) bin
-                        (False, s) | s > Stage0 && (package `elem` [touchy, unlit]) -> do
-                            srcDir <- stageLibPath Stage0 <&> (-/- "bin")
-                            copyFile (srcDir -/- takeFileName bin) bin
-                        _ -> buildBinary rs bin ctx
+lookupProgramContext :: FilePath -> [(FilePath, Context)] -> Maybe Context
+lookupProgramContext wholePath progs = lookup (takeFileName wholePath) progs
+
+buildProgram :: FilePath -> Context -> [(Resource, Int)] -> Action ()
+buildProgram bin ctx@(Context{..}) rs = do
+  -- Custom dependencies: this should be modeled better in the
+  -- Cabal file somehow.
+  -- TODO: Is this still needed? See 'runtimeDependencies'.
+  when (package == hsc2hs) $ do
+    -- 'Hsc2hs' needs the @template-hsc.h@ file.
+    template <- templateHscPath stage
+    need [template]
+  when (package == ghc) $ do
+    -- GHC depends on @settings@, @platformConstants@,
+    -- @llvm-targets@, @ghc-usage.txt@, @ghci-usage.txt@,
+    -- @llvm-passes@.
+    need =<< ghcDeps stage
+
+  cross <- flag CrossCompiling
+  -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@.
+  case (cross, stage) of
+    (True, s) | s > Stage0 -> do
+        srcDir <- buildRoot <&> (-/- (stageString Stage0 -/- "bin"))
+        copyFile (srcDir -/- takeFileName bin) bin
+    (False, s) | s > Stage0 && (package `elem` [touchy, unlit]) -> do
+        srcDir <- stageLibPath Stage0 <&> (-/- "bin")
+        copyFile (srcDir -/- takeFileName bin) bin
+    _ -> buildBinary rs bin ctx
 
 buildBinary :: [(Resource, Int)] -> FilePath -> Context -> Action ()
 buildBinary rs bin context@Context {..} = do
diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs
index 62023d72e4..b513c37097 100644
--- a/hadrian/src/Rules/Register.hs
+++ b/hadrian/src/Rules/Register.hs
@@ -1,54 +1,75 @@
-module Rules.Register (configurePackage, registerPackage) where
-
-import Distribution.ParseUtils
-import Distribution.Version (Version)
-import qualified Distribution.Compat.ReadP   as Parse
-import qualified Hadrian.Haskell.Cabal.Parse as Cabal
-import Hadrian.Expression
-import qualified System.Directory            as IO
+module Rules.Register (configurePackageRules, registerPackageRules) where
 
 import Base
 import Context
+import Hadrian.BuildPath
+import Hadrian.Expression
 import Packages
 import Settings
+import Settings.Default
 import Target
 import Utilities
 
-parseCabalName :: String -> Maybe (String, Version)
-parseCabalName = readPToMaybe parse
-  where
-    parse = (,) <$> (parsePackageName <* Parse.char '-') <*> parseOptVersion
+import Distribution.ParseUtils
+import Distribution.Version (Version)
+
+import qualified Distribution.Compat.ReadP   as Parse
+import qualified Hadrian.Haskell.Cabal.Parse as Cabal
+import qualified System.Directory            as IO
+import qualified Text.Parsec                 as Parsec
+
+-- * Configuring
 
 -- | Configure a package and build its @setup-config@ file.
-configurePackage :: Context -> Rules ()
-configurePackage context@Context {..} = do
+configurePackageRules :: Rules ()
+configurePackageRules = do
     root <- buildRootRules
-    root -/- contextDir context -/- "setup-config" %> \_ ->
-        Cabal.configurePackage context
+    root -/- "**/setup-config" %> \path ->
+        parsePath (parseSetupConfig root) "<setup config path parser>" path
+          >>= configurePackage
+
+parseSetupConfig :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
+parseSetupConfig root = do
+  _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+  stage <- parseStage
+  _ <- Parsec.char '/'
+  pkgPath <- Parsec.manyTill Parsec.anyChar
+    (Parsec.try $ Parsec.string "/setup-config")
+  return (stage, pkgPath)
+
+configurePackage :: (Stage, FilePath) -> Action ()
+configurePackage (stage, pkgpath) = do
+  pkg <- getPackageByPath pkgpath
+  Cabal.configurePackage (Context stage pkg vanilla)
+
+-- * Registering
 
 -- | Register a package and initialise the corresponding package database if
 -- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
-registerPackage :: [(Resource, Int)] -> Context -> Rules ()
-registerPackage rs context@Context {..} = when (stage < Stage2) $ do
+registerPackageRules :: [(Resource, Int)] -> Stage -> Rules ()
+registerPackageRules rs stage = do
     root <- buildRootRules
 
     -- Initialise the package database.
     root -/- relativePackageDbPath stage -/- packageDbStamp %> \stamp ->
         writeFileLines stamp []
 
-    -- TODO: Add proper error handling for partial functions.
     -- Register a package.
     root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do
-        settings <- libPath context <&> (-/- "settings")
-        platformConstants <- libPath context <&> (-/- "platformConstants")
+        let libpath = takeDirectory (takeDirectory conf)
+            settings = libpath -/- "settings"
+            platformConstants = libpath -/- "platformConstants"
+
         need [settings, platformConstants]
-        let Just pkgName | takeBaseName conf == "rts" = Just "rts"
-                         | otherwise = fst <$> parseCabalName (takeBaseName conf)
-        let Just pkg = findPackageByName pkgName
+
+        pkgName <- getPackageNameFromConfFile conf
+        pkg <- getPackageByName pkgName
         isBoot <- (pkg `notElem`) <$> stagePackages Stage0
+
+        let ctx = Context stage pkg vanilla
         case stage of
-            Stage0 | isBoot -> copyConf  rs (context { package = pkg }) conf
-            _               -> buildConf rs (context { package = pkg }) conf
+            Stage0 | isBoot -> copyConf  rs ctx conf
+            _               -> buildConf rs ctx conf
 
 buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
 buildConf _ context@Context {..} _conf = do
@@ -101,3 +122,20 @@ copyConf rs context@Context {..} conf = do
   where
     stdOutToPkgIds :: String -> [String]
     stdOutToPkgIds = drop 1 . concatMap words . lines
+
+getPackageNameFromConfFile :: FilePath -> Action String
+getPackageNameFromConfFile conf
+  | takeBaseName conf == "rts" = return "rts"
+  | otherwise = case parseCabalName (takeBaseName conf) of
+      Nothing -> error $ "getPackageNameFromConfFile: couldn't parse " ++ conf
+      Just (name, _) -> return name
+
+parseCabalName :: String -> Maybe (String, Version)
+parseCabalName = readPToMaybe parse
+  where
+    parse = (,) <$> (parsePackageName <* Parse.char '-') <*> parseOptVersion
+
+getPackageByName :: String -> Action Package
+getPackageByName n = case findPackageByName n of
+  Nothing -> error $ "getPackageByName: couldn't find " ++ n
+  Just p  -> return p
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
index 031bd45ace..b0e269ce1b 100644
--- a/hadrian/src/Settings/Default.hs
+++ b/hadrian/src/Settings/Default.hs
@@ -1,6 +1,6 @@
 module Settings.Default (
     -- * Packages that are build by default and for the testsuite
-    defaultPackages, testsuitePackages,
+    defaultPackages, testsuitePackages, getPackageByPath,
 
     -- * Default build ways
     defaultLibraryWays, defaultRtsWays,
@@ -141,6 +141,13 @@ testsuitePackages = do
              , unlit         ] ++
              [ timeout | win ]
 
+getPackageByPath :: FilePath -> Action Package
+getPackageByPath pkgpath = do
+  case filter (\p -> pkgPath p == pkgpath) knownPackages of
+    (p:_) -> return p
+    _     -> error $
+      "getPackageByPath: couldn't find a package with path: " ++ pkgpath
+
 -- | Default build ways for library packages:
 -- * We always build 'vanilla' way.
 -- * We build 'profiling' way when stage > Stage0.