Fix copying of fs*.h files during RTS registration (#566)
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 12 Apr 2018 01:32:31 +0000 (02:32 +0100)
committerGitHub <noreply@github.com>
Thu, 12 Apr 2018 01:32:31 +0000 (02:32 +0100)
* Fix indentation

* Pass the verbosity setting to Cabal

* Add a workaround for missing fs.h files

src/Hadrian/Haskell/Cabal/Parse.hs
src/Rules/Generate.hs
src/Rules/Register.hs

index 931c121..a36e25d 100644 (file)
@@ -152,8 +152,10 @@ configurePackage context@Context {..} = do
     flagList <- interpret (target context (CabalFlags stage) [] []) flavourArgs
     -- Compute the Cabal configurartion arguments.
     argList <- interpret (target context (GhcCabal Conf stage) [] []) flavourArgs
+    verbosity <- getVerbosity
+    let v = if verbosity >= Loud then "-v3" else "-v0"
     liftIO $ C.defaultMainWithHooksNoReadArgs hooks gpd
-        (argList ++ ["--flags=" ++ unwords flagList])
+        (argList ++ ["--flags=" ++ unwords flagList, v])
 
 -- | Copy the 'Package' of a given 'Context' into the package database
 -- corresponding to the 'Stage' of the 'Context'.
@@ -163,8 +165,10 @@ copyPackage context@Context {..} = do
     Cabal _ _ _ gpd _ _ <- unsafeReadCabalFile context
     ctxPath   <- Context.contextPath context
     pkgDbPath <- packageDbPath stage
+    verbosity <- getVerbosity
+    let v = if verbosity >= Loud then "-v3" else "-v0"
     liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
-        [ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath ]
+        [ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath, v ]
 
 -- | Register the 'Package' of a given 'Context' into the package database.
 registerPackage :: Context -> Action ()
@@ -172,8 +176,10 @@ registerPackage context@Context {..} = do
     putLoud $ "| Register package " ++ quote (pkgName package)
     ctxPath <- Context.contextPath context
     Cabal _ _ _ gpd _ _ <- unsafeReadCabalFile context
+    verbosity <- getVerbosity
+    let v = if verbosity >= Loud then "-v3" else "-v0"
     liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
-        [ "register", "--builddir", ctxPath ]
+        [ "register", "--builddir", ctxPath, v ]
 
 -- | Parse the 'PackageData' of the 'Package' of a given 'Context'.
 parsePackageData :: Context -> Action PackageData
index 2bae8d2..b57f547 100644 (file)
@@ -106,12 +106,12 @@ generatePackageCode context@(Context stage pkg _) = do
         generated f = (root -/- dir ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
         go gen file = generate file context gen
     generated ?> \file -> do
-      let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
-      (src, builder) <- unpack <$> findGenerator context file
-      need [src]
-      build $ target context builder [src] [file]
-      let boot = src -<.> "hs-boot"
-      whenM (doesFileExist boot) . copyFile boot $ file -<.> "hs-boot"
+        let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
+        (src, builder) <- unpack <$> findGenerator context file
+        need [src]
+        build $ target context builder [src] [file]
+        let boot = src -<.> "hs-boot"
+        whenM (doesFileExist boot) . copyFile boot $ file -<.> "hs-boot"
 
     priority 2.0 $ do
         when (pkg == compiler) $ do root <//> dir -/- "Config.hs" %> go generateConfigHs
@@ -132,20 +132,19 @@ generatePackageCode context@(Context stage pkg _) = do
         -- only generate this once! Until we have the include logic fixed.
         -- See the note on `platformH`
         when (stage == Stage0) $ do
-           root <//> "compiler/ghc_boot_platform.h" %> go generateGhcBootPlatformH
+            root <//> "compiler/ghc_boot_platform.h" %> go generateGhcBootPlatformH
         root <//> platformH stage %> go generateGhcBootPlatformH
 
     when (pkg == rts) $ do
-      root <//> dir -/- "cmm/AutoApply.cmm" %> \file ->
-        build $ target context GenApply [] [file]
-
-      -- XXX: this should be fixed properly, e.g. generated here on demand.
-      (root <//> dir -/- "DerivedConstants.h") <~ (buildRoot <&> (-/- generatedDir))
-      (root <//> dir -/- "ghcautoconf.h") <~ (buildRoot <&> (-/- generatedDir))
-      (root <//> dir -/- "ghcplatform.h") <~ (buildRoot <&> (-/- generatedDir))
-      (root <//> dir -/- "ghcversion.h") <~ (buildRoot <&> (-/- generatedDir))
+        root <//> dir -/- "cmm/AutoApply.cmm" %> \file ->
+            build $ target context GenApply [] [file]
+        -- XXX: this should be fixed properly, e.g. generated here on demand.
+        (root <//> dir -/- "DerivedConstants.h") <~ (buildRoot <&> (-/- generatedDir))
+        (root <//> dir -/- "ghcautoconf.h") <~ (buildRoot <&> (-/- generatedDir))
+        (root <//> dir -/- "ghcplatform.h") <~ (buildRoot <&> (-/- generatedDir))
+        (root <//> dir -/- "ghcversion.h") <~ (buildRoot <&> (-/- generatedDir))
     when (pkg == integerGmp) $ do
-      (root <//> dir -/- "ghc-gmp.h") <~ (buildRoot <&> (-/- "include"))
+        (root <//> dir -/- "ghc-gmp.h") <~ (buildRoot <&> (-/- "include"))
  where
     pattern <~ mdir = pattern %> \file -> do
         dir <- mdir
@@ -161,14 +160,20 @@ copyRules :: Rules ()
 copyRules = do
     root <- buildRootRules
     forM_ [Stage0 ..] $ \stage -> do
-      let prefix = root -/- stageString stage -/- "lib"
-      (prefix -/- "ghc-usage.txt")     <~ return "driver"
-      (prefix -/- "ghci-usage.txt"  )  <~ return "driver"
-      (prefix -/- "llvm-targets")      <~ return "."
-      (prefix -/- "platformConstants") <~ (buildRoot <&> (-/- generatedDir))
-      (prefix -/- "settings")          <~ return "."
-      (prefix -/- "template-hsc.h")    <~ return (pkgPath hsc2hs)
+        let prefix = root -/- stageString stage -/- "lib"
+        prefix -/- "ghc-usage.txt"     <~ return "driver"
+        prefix -/- "ghci-usage.txt"    <~ return "driver"
+        prefix -/- "llvm-targets"      <~ return "."
+        prefix -/- "platformConstants" <~ (buildRoot <&> (-/- generatedDir))
+        prefix -/- "settings"          <~ return "."
+        prefix -/- "template-hsc.h"    <~ return (pkgPath hsc2hs)
+
+    -- TODO: Get rid of this workaround.
+    -- See https://github.com/snowleopard/hadrian/issues/554
+    root -/- buildDir rtsContext -/- "rts/fs.h"     <~ return "rts"
+    root -/- buildDir rtsContext -/- "rts/fs_rts.h" <~ return "rts"
   where
+    infixl 1 <~
     pattern <~ mdir = pattern %> \file -> do
         dir <- mdir
         copyFile (dir -/- takeFileName file) file
@@ -181,9 +186,9 @@ generateRules = do
     priority 2.0 $ (root -/- generatedDir -/-  "ghcversion.h") <~ generateGhcVersionH
 
     forM_ [Stage0 ..] $ \stage ->
-      root -/- ghcSplitPath stage %> \path -> do
-        generate path emptyTarget generateGhcSplit
-        makeExecutable path
+        root -/- ghcSplitPath stage %> \path -> do
+            generate path emptyTarget generateGhcSplit
+            makeExecutable path
 
     -- TODO: simplify, get rid of fake rts context
     root -/- generatedDir ++ "//*" %> \file -> do
index 0bd3eaf..8c726b5 100644 (file)
@@ -45,9 +45,8 @@ buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
 buildConf _ context@Context {..} _conf = do
     depPkgIds <- cabalDependencies context
 
-    -- setup-config, triggers `ghc-cabal configure`
-    -- everything of a package should depend on that
-    -- in the first place.
+    -- Calling 'need' on @setup-config@, triggers @ghc-cabal configure@
+    -- Building anything in a package transitively depends on its configuration.
     setupConfig <- contextPath context <&> (-/- "setup-config")
     need [setupConfig]
     need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
@@ -55,25 +54,26 @@ buildConf _ context@Context {..} _conf = do
     ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty)
     need =<< concatMapM (libraryTargets True) [ context { way = w } | w <- ways ]
 
-    -- might need some package-db resource to limit read/write,
-    -- see packageRules
-    bldPath <- buildPath context
+    -- We might need some package-db resource to limit read/write, see packageRules.
+    path <- buildPath context
 
-    -- special package cases (these should ideally be rolled into cabal one way or the other)
+    -- Special package cases (these should ideally be rolled into Cabal).
     when (package == rts) $
-      -- iif cabal new about "generated-headers", we could read them from the configuredCabal
-      -- information, and just "need" them here.
-      need [ bldPath -/- "DerivedConstants.h"
-           , bldPath -/- "ghcautoconf.h"
-           , bldPath -/- "ghcplatform.h"
-           , bldPath -/- "ghcversion.h"
-           , bldPath -/- "ffi.h"
-           ]
-
-    when (package == integerGmp) $
-      need [bldPath -/- "ghc-gmp.h"]
-
-    -- copy and register the package
+        -- If Cabal knew about "generated-headers", we could read them from the
+        -- 'configuredCabal' information, and just "need" them here.
+        need [ path -/- "DerivedConstants.h"
+             , path -/- "ghcautoconf.h"
+             , path -/- "ghcplatform.h"
+             , path -/- "ghcversion.h"
+             , path -/- "ffi.h"
+             -- TODO: Get rid of this workaround.
+             -- See https://github.com/snowleopard/hadrian/issues/554
+             , path -/- "rts/fs.h"
+             , path -/- "rts/fs_rts.h" ]
+
+    when (package == integerGmp) $ need [path -/- "ghc-gmp.h"]
+
+    -- Copy and register the package.
     copyPackage context
     registerPackage context
 
@@ -82,16 +82,15 @@ copyConf rs context@Context {..} conf = do
     depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $
       target context (GhcPkg Dependencies stage) [pkgName package] []
     need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
-    -- we should unregister if the file exists since ghc-pkg will complain
-    -- about existing pkg id (See https://github.com/snowleopard/hadrian/issues/543)
-    -- also, we don't always do the unregistration + registration to avoid
-    -- repeated work after a full build
+    -- We should unregister if the file exists since @ghc-pkg@ will complain
+    -- about existing package: https://github.com/snowleopard/hadrian/issues/543.
+    -- Also, we don't always do the unregistration + registration to avoid
+    -- repeated work after a full build.
     unlessM (doesFileExist conf) $ do
-      buildWithResources rs $
-        target context (GhcPkg Unregister stage) [pkgName package] []
-      buildWithResources rs $
-        target context (GhcPkg Clone stage) [pkgName package] [conf]
-
+        buildWithResources rs $
+            target context (GhcPkg Unregister stage) [pkgName package] []
+        buildWithResources rs $
+            target context (GhcPkg Clone stage) [pkgName package] [conf]
   where
     stdOutToPkgIds :: String -> [String]
     stdOutToPkgIds = drop 1 . concatMap words . lines