Commit ffff1b38 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Simplify, drop code duplication, add comments

parent bb43f249
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Oracles.ModuleFiles (
decodeModule, encodeModule, findGenerator, haskellSources, moduleFilesOracle
decodeModule, encodeModule, findGenerator, hsSources, hsObjects, moduleFilesOracle
) where
import qualified Data.HashMap.Strict as Map
......@@ -73,8 +73,8 @@ findGenerator Context {..} file = do
return (source, builder)
-- | Find all Haskell source files for a given 'Context'.
haskellSources :: Context -> Action [FilePath]
haskellSources context = do
hsSources :: Context -> Action [FilePath]
hsSources context = do
let autogen = buildPath context -/- "autogen"
-- Generated source files live in buildPath and have extension "hs", except
-- for GHC/Prim.hs that lives in autogen. TODO: fix the inconsistency?
......@@ -85,10 +85,21 @@ haskellSources context = do
| otherwise = generatedFile context m
map modFile <$> contextFiles context
-- | Find all Haskell object files for a given 'Context'. Note: this is a much
-- simpler function compared to 'hsSources', because all object files live in
-- the build directory regardless of whether they are generated or not.
hsObjects :: Context -> Action [FilePath]
hsObjects context = do
modules <- pkgDataList $ Modules (buildPath context)
-- GHC.Prim module is only for documentation, we do not actually build it.
return . map (objectPath context . moduleSource) $ filter (/= "GHC.Prim") modules
-- | Generated module files live in the 'Context' specific build directory.
generatedFile :: Context -> String -> FilePath
generatedFile context moduleName =
buildPath context -/- replaceEq '.' '/' moduleName <.> "hs"
generatedFile context moduleName = buildPath context -/- moduleSource moduleName
moduleSource :: String -> FilePath
moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs"
-- | Module files for a given 'Context'.
contextFiles :: Context -> Action [(String, Maybe FilePath)]
......
......@@ -20,7 +20,7 @@ compilePackage rs context@Context {..} = do
need [src]
needDependencies context src $ obj <.> "d"
build $ Target context (compiler stage) [src] [obj]
compileHs = \[obj, _] -> do
compileHs = \[obj, _hi] -> do
(src, deps) <- fileDependencies context obj
need $ src : deps
when (isLibrary package) $ need =<< return <$> pkgConfFile context
......
......@@ -13,7 +13,7 @@ import Target
buildPackageDependencies :: [(Resource, Int)] -> Context -> Rules ()
buildPackageDependencies rs context@Context {..} =
buildPath context -/- ".dependencies" %> \deps -> do
srcs <- haskellSources context
srcs <- hsSources context
need srcs
let mk = deps <.> "mk"
if srcs == []
......
......@@ -17,14 +17,14 @@ haddockHtmlLib = "inplace/lib/html/haddock-util.js"
-- Note: this build rule creates plenty of files, not just the .haddock one.
-- All of them go into the 'doc' subdirectory. Pedantically tracking all built
-- files in the Shake databases seems fragile and unnecesarry.
-- files in the Shake databases seems fragile and unnecessary.
buildPackageDocumentation :: Context -> Rules ()
buildPackageDocumentation context@Context {..} =
let cabalFile = pkgCabalFile package
haddockFile = pkgHaddockFile context
in when (stage == Stage1) $ do
haddockFile %> \file -> do
srcs <- haskellSources context
srcs <- hsSources context
deps <- map PackageName <$> interpretInContext context (getPkgDataList DepNames)
let haddocks = [ pkgHaddockFile $ vanillaContext Stage1 depPkg
| Just depPkg <- map findKnownPackage deps
......
module Rules.Library (
buildPackageLibrary, buildPackageGhciLibrary, cSources, hsSources
) where
module Rules.Library (buildPackageLibrary, buildPackageGhciLibrary) where
import Data.Char
import qualified System.Directory as IO
......@@ -10,9 +8,9 @@ import Context
import Expression
import Flavour
import GHC
import Oracles.ModuleFiles
import Oracles.PackageData
import Rules.Actions
import Rules.Generate
import Settings
import Settings.Paths
import Target
......@@ -22,97 +20,52 @@ buildPackageLibrary :: Context -> Rules ()
buildPackageLibrary context@Context {..} = do
let path = buildPath context
libPrefix = path -/- "libHS" ++ pkgNameString package
-- TODO: handle dynamic libraries
matchVersionedFilePath libPrefix (waySuffix way <.> "a") ?> \a -> do
removeFile a
asmSrcs <- asmSources context
cSrcs <- cSources context
cmmSrcs <- cmmSources context
hsSrcs <- hsSources context
let asmObjs = [ objFile context src | src <- asmSrcs ]
cObjs = [ objFile context src | src <- cSrcs ]
cmmObjs = [ objFile context src | src <- cmmSrcs ]
hsObjs = [ path -/- src <.> osuf way | src <- hsSrcs ]
asmObjs <- map (objectPath context) <$> pkgDataList (AsmSrcs path)
cObjs <- cObjects context
cmmObjs <- map (objectPath context) <$> pkgDataList (CmmSrcs path)
eObjs <- extraObjects context
hsObjs <- hsObjects context
let noHsObjs = asmObjs ++ cObjs ++ cmmObjs ++ eObjs
-- This will create split objects if required (we don't track them
-- explicitly as this would needlessly bloat the Shake database).
need $ asmObjs ++ cObjs ++ cmmObjs ++ hsObjs
need $ noHsObjs ++ hsObjs
split <- interpretInContext context $ splitObjects flavour
splitObjs <- if not split then return hsObjs else -- TODO: make clearer!
concatForM hsSrcs $ \src -> do
let splitPath = path -/- src ++ "_" ++ osuf way ++ "_split"
contents <- liftIO $ IO.getDirectoryContents splitPath
return . map (splitPath -/-)
. filter (not . all (== '.')) $ contents
let getSplitObjs = concatForM hsObjs $ \obj -> do
let dir = dropExtension obj ++ "_" ++ osuf way ++ "_split"
contents <- liftIO $ IO.getDirectoryContents dir
return . map (dir -/-) $ filter (not . all (== '.')) contents
eObjs <- extraObjects context
let objs = asmObjs ++ cObjs ++ cmmObjs ++ splitObjs ++ eObjs
objs <- (noHsObjs ++) <$> if split then getSplitObjs else return hsObjs
asuf <- libsuf way
let isLib0 = ("//*-0" ++ asuf) ?== a
if isLib0
then build $ Target context Ar [] [a] -- TODO: scan for dlls
else build $ Target context Ar objs [a]
if isLib0 then build $ Target context Ar [] [a] -- TODO: Scan for dlls
else build $ Target context Ar objs [a]
synopsis <- interpretInContext context $ getPkgData Synopsis
unless isLib0 . putSuccess $ renderLibrary
(quote (pkgNameString package) ++ " (" ++ show stage ++ ", way " ++ show way ++ ").")
a
(dropWhileEnd isPunctuation synopsis)
(quote (pkgNameString package) ++ " (" ++ show stage ++ ", way "
++ show way ++ ").") a (dropWhileEnd isPunctuation synopsis)
buildPackageGhciLibrary :: Context -> Rules ()
buildPackageGhciLibrary context@Context {..} = priority 2 $ do
let path = buildPath context
libPrefix = path -/- "HS" ++ pkgNameString package
let libPrefix = buildPath context -/- "HS" ++ pkgNameString package
matchVersionedFilePath libPrefix (waySuffix way <.> "o") ?> \obj -> do
cSrcs <- cSources context
hsSrcs <- hsSources context
eObjs <- extraObjects context
let cObjs = map (objFile context) cSrcs
hsObjs = [ path -/- src <.> osuf way | src <- hsSrcs ]
objs = cObjs ++ hsObjs ++ eObjs
objs <- concatMapM ($ context) [cObjects, hsObjects, extraObjects]
need objs
build $ Target context Ld objs [obj]
-- | Given a 'Context' and a 'FilePath' to a source file, compute the 'FilePath'
-- to its object file. For example:
-- * "Task.c" -> "_build/stage1/rts/Task.thr_o"
-- * "_build/stage1/rts/cmm/AutoApply.cmm" -> "_build/stage1/rts/cmm/AutoApply.o"
objFile :: Context -> FilePath -> FilePath
objFile context@Context {..} src
| isGenerated src = src -<.> osuf way
| otherwise = buildPath context -/- extension -/- src -<.> osuf way
where
extension = drop 1 $ takeExtension src
isGenerated
| extension == "c" = isGeneratedCFile
| extension == "cmm" = isGeneratedCmmFile
| otherwise = const False
asmSources :: Context -> Action [FilePath]
asmSources context = interpretInContext context $ getPkgDataList AsmSrcs
-- TODO: simplify
cSources :: Context -> Action [FilePath]
cSources context = do
srcs <- interpretInContext context $ getPkgDataList CSrcs
if way context == threaded
then return srcs
else return [ src | src <- srcs
, takeFileName src `notElem` ["Evac_thr.c", "Scav_thr.c"] ]
cmmSources :: Context -> Action [FilePath]
cmmSources context = interpretInContext context $ getPkgDataList CmmSrcs
hsSources :: Context -> Action [FilePath]
hsSources context = do
modules <- interpretInContext context $ getPkgDataList Modules
-- GHC.Prim is special: we do not build it.
return . map (replaceEq '.' '/') . filter (/= "GHC.Prim") $ modules
cObjects :: Context -> Action [FilePath]
cObjects context = do
objs <- map (objectPath context) <$> pkgDataList (CSrcs $ buildPath context)
return $ if way context == threaded
then objs
else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs
extraObjects :: Context -> Action [FilePath]
extraObjects context
......
......@@ -8,9 +8,9 @@ import Expression
import GHC
import Oracles.Config.Setting
import Oracles.Dependencies
import Oracles.ModuleFiles
import Oracles.PackageData
import Rules.Actions
import Rules.Library
import Rules.Wrappers.Ghc
import Rules.Wrappers.GhcPkg
import Settings
......@@ -23,43 +23,35 @@ import UserSettings
programInplaceLibPath :: FilePath
programInplaceLibPath = "inplace/lib/bin"
-- | Wrapper is parameterised by the path to the wrapped binary.
-- | Wrapper is an expression depending on the 'FilePath' to the wrapped binary.
type Wrapper = FilePath -> Expr String
-- | List of wrappers we build.
wrappers :: [(Context, Wrapper)]
wrappers = [ (vanillaContext Stage0 ghc , ghcWrapper )
, (vanillaContext Stage1 ghc , ghcWrapper )
, (vanillaContext Stage0 ghcPkg, ghcPkgWrapper)]
, (vanillaContext Stage0 ghcPkg, ghcPkgWrapper) ]
buildProgram :: [(Resource, Int)] -> Context -> Rules ()
buildProgram rs context@Context {..} = do
let match file = case programPath context of
Nothing -> False
Just program -> program == file
matchWrapped file = case programPath context of
Nothing -> False
Just program -> case computeWrappedPath program of
Nothing -> False
Just wrappedProgram -> wrappedProgram == file
let match file = any (== file) (programPath context)
matchWrapped file = any (== file) (programPath context >>= wrappedPath)
match ?> \bin -> do
windows <- windowsHost
if windows
then buildBinary rs context bin -- We don't build wrappers on Windows
else case find ((== context) . fst) wrappers of
Nothing -> buildBinary rs context bin -- No wrapper found
Just (_, wrapper) -> do
let Just wrappedBin = computeWrappedPath bin
else case lookup context wrappers of
Nothing -> buildBinary rs context bin -- No wrapper found
Just wrapper -> do
let Just wrappedBin = wrappedPath bin
need [wrappedBin]
buildWrapper context wrapper bin wrappedBin
matchWrapped ?> \bin -> buildBinary rs context bin
matchWrapped ?> buildBinary rs context
-- | Replace 'programInplacePath' with 'programInplaceLibPath' in a given path.
computeWrappedPath :: FilePath -> Maybe FilePath
computeWrappedPath =
fmap (programInplaceLibPath ++) . stripPrefix programInplacePath
wrappedPath :: FilePath -> Maybe FilePath
wrappedPath = fmap (programInplaceLibPath ++) . stripPrefix programInplacePath
buildWrapper :: Context -> Wrapper -> FilePath -> FilePath -> Action ()
buildWrapper context@Context {..} wrapper wrapperPath binPath = do
......@@ -73,19 +65,18 @@ buildWrapper context@Context {..} wrapper wrapperPath binPath = do
-- TODO: Do we need to consider other ways when building programs?
buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildBinary rs context@Context {..} bin = do
hsSrcs <- hsSources context
binDeps <- if stage == Stage0 && package == ghcCabal
then return [ pkgPath package -/- src <.> "hs" | src <- hsSrcs ]
then hsSources context
else do
ways <- interpretInContext context getLibraryWays
deps <- contextDependencies context
needContext [ dep { way = w } | dep <- deps, w <- ways ]
cSrcs <- cSources context -- TODO: Drop code duplication (Library.hs).
let path = buildPath context
return $ [ path -/- "c" -/- src -<.> osuf vanilla | src <- cSrcs ]
++ [ path -/- src <.> osuf vanilla | src <- hsSrcs ]
++ [ path -/- "Paths_hsc2hs.o" | package == hsc2hs ]
++ [ path -/- "Paths_haddock.o" | package == haddock ]
cObjs <- map (objectPath context) <$> pkgDataList (CSrcs path)
hsObjs <- hsObjects context
return $ cObjs ++ hsObjs
++ [ path -/- "Paths_hsc2hs.o" | package == hsc2hs ]
++ [ path -/- "Paths_haddock.o" | package == haddock ]
need binDeps
buildWithResources rs $ Target context (Ghc LinkHs stage) binDeps [bin]
synopsis <- interpretInContext context $ getPkgData Synopsis
......
......@@ -2,7 +2,8 @@ module Settings.Paths (
contextDirectory, buildPath, pkgDataFile, pkgHaddockFile, pkgLibraryFile,
pkgLibraryFile0, pkgGhciLibraryFile, gmpBuildPath, gmpObjects, gmpLibraryH,
gmpBuildInfoPath, generatedPath, libffiBuildPath, shakeFilesPath, pkgConfFile,
packageDbDirectory, packageDbStamp, bootPackageConstraints, packageDependencies
packageDbDirectory, packageDbStamp, bootPackageConstraints, packageDependencies,
objectPath
) where
import Base
......@@ -12,15 +13,21 @@ import GHC
import Oracles.PackageData
import UserSettings
-- | Path to the directory containing the Shake database and other auxiliary
-- files generated by Hadrian.
shakeFilesPath :: FilePath
shakeFilesPath = buildRootPath -/- "hadrian/shake-files"
-- | Boot package versions extracted from @.cabal@ files.
bootPackageConstraints :: FilePath
bootPackageConstraints = shakeFilesPath -/- "boot-package-constraints"
-- | Dependencies between packages extracted from @.cabal@ files.
packageDependencies :: FilePath
packageDependencies = shakeFilesPath -/- "package-dependencies"
-- | Path to the directory containing generated source files that are not
-- package-specific, e.g. @ghcplatform.h@.
generatedPath :: FilePath
generatedPath = buildRootPath -/- "generated"
......@@ -101,3 +108,23 @@ pkgConfFile :: Context -> Action FilePath
pkgConfFile context@Context {..} = do
componentId <- pkgData . ComponentId $ buildPath context
return $ packageDbDirectory stage -/- componentId <.> "conf"
-- | Given a 'FilePath' to a source file, return 'True' if it is generated.
-- The current implementation simply assumes that a file is generated if it
-- lives in 'buildRootPath'. Since most files are not generated the test is
-- usually very fast.
isGeneratedSource :: FilePath -> Bool
isGeneratedSource = (buildRootPath `isPrefixOf`)
-- | Given a 'Context' and a 'FilePath' to a source file, compute the 'FilePath'
-- to its object file. For example:
-- * "Task.c" -> "_build/stage1/rts/Task.thr_o"
-- * "_build/stage1/rts/cmm/AutoApply.cmm" -> "_build/stage1/rts/cmm/AutoApply.o"
objectPath :: Context -> FilePath -> FilePath
objectPath context@Context {..} src
| isGeneratedSource src = obj
| "*hs*" ?== extension = buildPath context -/- obj
| otherwise = buildPath context -/- extension -/- obj
where
extension = drop 1 $ takeExtension src
obj = src -<.> osuf way
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