Library.hs 3.68 KB
Newer Older
Zhen Zhang's avatar
Zhen Zhang committed
1
module Rules.Library (
Andrey Mokhov's avatar
Andrey Mokhov committed
2
    buildPackageLibrary, buildPackageGhciLibrary, buildDynamicLib
3
    ) where
4

5
import Hadrian.Haskell.Cabal
6
import qualified System.Directory as IO
Ben Gamari's avatar
Ben Gamari committed
7

8
import Base
9
import Context
10
import Expression hiding (way, package)
Andrey Mokhov's avatar
Andrey Mokhov committed
11
import Flavour
Andrey Mokhov's avatar
Andrey Mokhov committed
12
import GHC
13
import Oracles.ModuleFiles
Andrey Mokhov's avatar
Andrey Mokhov committed
14
import Oracles.PackageData
15
import Oracles.Setting
16
import Rules.Gmp
17
import Settings
18
import Target
19
import Utilities
20

Andrey Mokhov's avatar
Andrey Mokhov committed
21 22
libraryObjects :: Context -> Action [FilePath]
libraryObjects context@Context{..} = do
Zhen Zhang's avatar
Zhen Zhang committed
23 24 25 26 27 28 29
    hsObjs   <- hsObjects    context
    noHsObjs <- nonHsObjects context

    -- This will create split objects if required (we don't track them
    -- explicitly as this would needlessly bloat the Shake database).
    need $ noHsObjs ++ hsObjs

30
    split <- interpretInContext context =<< splitObjects <$> flavour
Zhen Zhang's avatar
Zhen Zhang committed
31
    let getSplitObjs = concatForM hsObjs $ \obj -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
32 33 34
            let dir = dropExtension obj ++ "_" ++ osuf way ++ "_split"
            contents <- liftIO $ IO.getDirectoryContents dir
            return . map (dir -/-) $ filter (not . all (== '.')) contents
Zhen Zhang's avatar
Zhen Zhang committed
35 36 37 38 39

    (noHsObjs ++) <$> if split then getSplitObjs else return hsObjs

buildDynamicLib :: Context -> Rules ()
buildDynamicLib context@Context{..} = do
Andrey Mokhov's avatar
Andrey Mokhov committed
40
    let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgName package
Andrey Mokhov's avatar
Andrey Mokhov committed
41
    -- OS X
Andrey Mokhov's avatar
Andrey Mokhov committed
42
    libPrefix ++ "*.dylib" %> buildDynamicLibUnix
Zhen Zhang's avatar
Zhen Zhang committed
43
    -- Linux
Andrey Mokhov's avatar
Andrey Mokhov committed
44
    libPrefix ++ "*.so"    %> buildDynamicLibUnix
Zhen Zhang's avatar
Zhen Zhang committed
45 46
    -- TODO: Windows
  where
Andrey Mokhov's avatar
Andrey Mokhov committed
47
    buildDynamicLibUnix lib = do
Zhen Zhang's avatar
Zhen Zhang committed
48
        deps <- contextDependencies context
Andrey Mokhov's avatar
Andrey Mokhov committed
49 50
        need =<< mapM pkgLibraryFile deps
        objs <- libraryObjects context
Andrey Mokhov's avatar
Andrey Mokhov committed
51
        build $ target context (Ghc LinkHs stage) objs [lib]
Zhen Zhang's avatar
Zhen Zhang committed
52

53
buildPackageLibrary :: Context -> Rules ()
54
buildPackageLibrary context@Context {..} = do
Andrey Mokhov's avatar
Andrey Mokhov committed
55
    let libPrefix = "//" ++ contextDir context -/- "libHS" ++ pkgName package
56
    libPrefix ++ "*" ++ (waySuffix way <.> "a") %%> \a -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
57
        objs <- libraryObjects context
58
        asuf <- libsuf way
59
        let isLib0 = ("//*-0" ++ asuf) ?== a
Andrey Mokhov's avatar
Andrey Mokhov committed
60
        removeFile a
61 62
        if isLib0 then build $ target context (Ar stage) []   [a] -- TODO: Scan for dlls
                  else build $ target context (Ar stage) objs [a]
63

64
        synopsis <- pkgSynopsis package
Moritz Angermann's avatar
Moritz Angermann committed
65
        unless isLib0 . putSuccess $ renderLibrary
Andrey Mokhov's avatar
Andrey Mokhov committed
66
            (quote (pkgName package) ++ " (" ++ show stage ++ ", way "
67
            ++ show way ++ ").") a synopsis
68

69
buildPackageGhciLibrary :: Context -> Rules ()
70
buildPackageGhciLibrary context@Context {..} = priority 2 $ do
Andrey Mokhov's avatar
Andrey Mokhov committed
71
    let libPrefix = "//" ++ contextDir context -/- "HS" ++ pkgName package
72
    libPrefix ++ "*" ++ (waySuffix way <.> "o") %> \obj -> do
73
        objs <- allObjects context
Andrey Mokhov's avatar
Andrey Mokhov committed
74
        need objs
75
        build $ target context Ld objs [obj]
Andrey Mokhov's avatar
Andrey Mokhov committed
76

77 78 79 80 81
allObjects :: Context -> Action [FilePath]
allObjects context = (++) <$> nonHsObjects context <*> hsObjects context

nonHsObjects :: Context -> Action [FilePath]
nonHsObjects context = do
82
    path    <- buildPath context
83
    cObjs   <- cObjects context
84 85
    cmmSrcs <- pkgDataList (CmmSrcs path)
    cmmObjs <- mapM (objectPath context) cmmSrcs
86 87 88
    eObjs   <- extraObjects context
    return $ cObjs ++ cmmObjs ++ eObjs

89 90
cObjects :: Context -> Action [FilePath]
cObjects context = do
91 92 93
    path <- buildPath context
    srcs <- pkgDataList (CSrcs path)
    objs <- mapM (objectPath context) srcs
94 95 96
    return $ if way context == threaded
        then objs
        else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs
97

98
extraObjects :: Context -> Action [FilePath]
99
extraObjects context
Andrey Mokhov's avatar
Andrey Mokhov committed
100
    | package context == integerGmp = do
101 102 103
        gmpPath <- gmpBuildPath
        need [gmpPath -/- gmpLibraryH]
        map unifyPath <$> getDirectoryFiles "" [gmpPath -/- gmpObjectsDir -/- "*.o"]
104
    | otherwise         = return []