Unverified Commit 66117c5e authored by Andrey Mokhov's avatar Andrey Mokhov Committed by GitHub
Browse files

Fix copying of fs*.h files during RTS registration (#566)

* Fix indentation

* Pass the verbosity setting to Cabal

* Add a workaround for missing fs.h files
parent b6c77f39
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment