Program.hs 4.76 KB
Newer Older
Andrey Mokhov's avatar
Andrey Mokhov committed
1 2
module Rules.Program (buildProgram) where

3
import Hadrian.Haskell.Cabal
Ben Gamari's avatar
Ben Gamari committed
4

Ben Gamari's avatar
Ben Gamari committed
5
import Base
6
import Context
7
import Expression hiding (stage, way)
8
import Oracles.ModuleFiles
Andrey Mokhov's avatar
Andrey Mokhov committed
9
import Oracles.PackageData
10
import Oracles.Setting
11
import Rules.Wrappers
Andrey Mokhov's avatar
Andrey Mokhov committed
12
import Settings
13
import Settings.Packages.Rts
14
import Target
15
import Utilities
Andrey Mokhov's avatar
Andrey Mokhov committed
16

17
-- TODO: Drop way in build rule generation?
18
buildProgram :: [(Resource, Int)] -> Context -> Rules ()
Andrey Mokhov's avatar
Andrey Mokhov committed
19
buildProgram rs context@Context {..} = when (isProgram package) $ do
Andrey Mokhov's avatar
Andrey Mokhov committed
20
    let installStage = do
Andrey Mokhov's avatar
Andrey Mokhov committed
21
            latest <- latestBuildStage package -- fromJust below is safe
Andrey Mokhov's avatar
Andrey Mokhov committed
22 23
            return $ if package == ghc then stage else fromJust latest

24
    "//" ++ contextDir context -/- programName context <.> exe %> \bin -> do
25 26
        context' <- programContext stage package
        buildBinaryAndWrapper rs context' bin
Andrey Mokhov's avatar
Andrey Mokhov committed
27 28

    -- Rules for programs built in install directories
Andrey Mokhov's avatar
Andrey Mokhov committed
29
    when (stage == Stage0 || package == ghc) $ do
30 31
        -- Some binaries in inplace/bin are wrapped
        inplaceBinPath -/- programName context <.> exe %> \bin -> do
32
            context' <- programContext stage package
Andrey Mokhov's avatar
Andrey Mokhov committed
33
            binStage <- installStage
34
            buildBinaryAndWrapper rs (context' { stage = binStage }) bin
Zhen Zhang's avatar
Zhen Zhang committed
35

36
        inplaceLibBinPath -/- programName context <.> exe %> \bin -> do
Zhen Zhang's avatar
Zhen Zhang committed
37
            binStage <- installStage
38
            context' <- programContext stage package
Zhen Zhang's avatar
Zhen Zhang committed
39 40
            if package /= iservBin then
                -- We *normally* build only unwrapped binaries in inplace/lib/bin,
41
                buildBinary rs (context' { stage = binStage }) bin
Zhen Zhang's avatar
Zhen Zhang committed
42 43 44
            else
                -- build both binary and wrapper in inplace/lib/bin
                -- for ghc-iserv on *nix platform now
45
                buildBinaryAndWrapperLib rs (context' { stage = binStage }) bin
Zhen Zhang's avatar
Zhen Zhang committed
46 47

        inplaceLibBinPath -/- programName context <.> "bin" %> \bin -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
48
            binStage <- installStage
49 50
            context' <- programContext stage package
            buildBinary rs (context' { stage = binStage }) bin
Andrey Mokhov's avatar
Andrey Mokhov committed
51

Zhen Zhang's avatar
Zhen Zhang committed
52 53 54 55 56 57 58 59 60 61 62 63 64 65
buildBinaryAndWrapperLib :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildBinaryAndWrapperLib rs context bin = do
    windows <- windowsHost
    if windows
    then buildBinary rs context bin -- We don't build wrappers on Windows
    else case lookup context inplaceWrappers of
        Nothing      -> buildBinary rs context bin -- No wrapper found
        Just wrapper -> do
            top <- topDirectory
            let libdir = top -/- inplaceLibPath
            let wrappedBin = inplaceLibBinPath -/- programName context <.> "bin"
            need [wrappedBin]
            buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName wrappedBin))

Andrey Mokhov's avatar
Andrey Mokhov committed
66 67 68 69 70
buildBinaryAndWrapper :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildBinaryAndWrapper rs context bin = do
    windows <- windowsHost
    if windows
    then buildBinary rs context bin -- We don't build wrappers on Windows
Zhen Zhang's avatar
Zhen Zhang committed
71
    else case lookup context inplaceWrappers of
Andrey Mokhov's avatar
Andrey Mokhov committed
72 73
        Nothing      -> buildBinary rs context bin -- No wrapper found
        Just wrapper -> do
74 75 76
            top <- topDirectory
            let libdir = top -/- inplaceLibPath
            let wrappedBin = inplaceLibBinPath -/- takeFileName bin
Andrey Mokhov's avatar
Andrey Mokhov committed
77
            need [wrappedBin]
78
            buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName bin))
Andrey Mokhov's avatar
Andrey Mokhov committed
79

80 81 82
buildWrapper :: Context -> Wrapper -> FilePath -> WrappedBinary -> Action ()
buildWrapper context@Context {..} wrapper wrapperPath wrapped = do
    contents <- interpretInContext context $ wrapper wrapped
Andrey Mokhov's avatar
Andrey Mokhov committed
83
    writeFileChanged wrapperPath contents
84
    makeExecutable wrapperPath
Andrey Mokhov's avatar
Andrey Mokhov committed
85
    putSuccess $ "| Successfully created wrapper for " ++
Andrey Mokhov's avatar
Andrey Mokhov committed
86
        quote (pkgName package) ++ " (" ++ show stage ++ ")."
Andrey Mokhov's avatar
Andrey Mokhov committed
87 88

-- TODO: Get rid of the Paths_hsc2hs.o hack.
89
buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
Andrey Mokhov's avatar
Andrey Mokhov committed
90 91
buildBinary rs context@Context {..} bin = do
    binDeps <- if stage == Stage0 && package == ghcCabal
92
        then hsSources context
Andrey Mokhov's avatar
Andrey Mokhov committed
93
        else do
94
            needLibrary =<< contextDependencies context
95
            when (stage > Stage0) $ do
96
                ways <- interpretInContext context (getLibraryWays <> getRtsWays)
97
                needLibrary [ rtsContext { way = w } | w <- ways ]
98 99 100
            path   <- buildPath context
            cSrcs  <- pkgDataList (CSrcs path)
            cObjs  <- mapM (objectPath context) cSrcs
101 102 103 104
            hsObjs <- hsObjects context
            return $ cObjs ++ hsObjs
                  ++ [ path -/- "Paths_hsc2hs.o"  | package == hsc2hs  ]
                  ++ [ path -/- "Paths_haddock.o" | package == haddock ]
Andrey Mokhov's avatar
Andrey Mokhov committed
105
    need binDeps
106
    buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin]
107
    synopsis <- traverse pkgSynopsis (pkgCabalFile package)
Moritz Angermann's avatar
Moritz Angermann committed
108
    putSuccess $ renderProgram
109
        (quote (pkgName package) ++ " (" ++ show stage ++ ").") bin synopsis