Program.hs 4.75 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 GHC
9
import Oracles.ModuleFiles
Andrey Mokhov's avatar
Andrey Mokhov committed
10
import Oracles.PackageData
11
import Oracles.Setting
12
import Rules.Wrappers
Andrey Mokhov's avatar
Andrey Mokhov committed
13
import Settings
14
import Settings.Packages.Rts
15
import Target
16
import Utilities
Andrey Mokhov's avatar
Andrey Mokhov committed
17

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

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

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

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

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

Zhen Zhang's avatar
Zhen Zhang committed
53 54 55 56 57 58 59 60 61 62 63 64 65 66
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
67 68 69 70 71
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
72
    else case lookup context inplaceWrappers of
Andrey Mokhov's avatar
Andrey Mokhov committed
73 74
        Nothing      -> buildBinary rs context bin -- No wrapper found
        Just wrapper -> do
75 76 77
            top <- topDirectory
            let libdir = top -/- inplaceLibPath
            let wrappedBin = inplaceLibBinPath -/- takeFileName bin
Andrey Mokhov's avatar
Andrey Mokhov committed
78
            need [wrappedBin]
79
            buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName bin))
Andrey Mokhov's avatar
Andrey Mokhov committed
80

81 82 83
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
84
    writeFileChanged wrapperPath contents
85
    makeExecutable wrapperPath
Andrey Mokhov's avatar
Andrey Mokhov committed
86
    putSuccess $ "| Successfully created wrapper for " ++
Andrey Mokhov's avatar
Andrey Mokhov committed
87
        quote (pkgName package) ++ " (" ++ show stage ++ ")."
Andrey Mokhov's avatar
Andrey Mokhov committed
88 89

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