Compile.hs 3.5 KB
Newer Older
1
2
module Rules.Compile (compilePackage) where

3
4
import Hadrian.Oracles.KeyValue

Ben Gamari's avatar
Ben Gamari committed
5
import Base
6
import Context
7
import Expression
8
import Rules.Generate
9
import Settings.Path
Andrey Mokhov's avatar
Andrey Mokhov committed
10
import Target
11
import Utilities
12

13
compilePackage :: [(Resource, Int)] -> Context -> Rules ()
14
compilePackage rs context@Context {..} = do
15
    let path            = buildPath context
Andrey Mokhov's avatar
Andrey Mokhov committed
16
        nonHs extension = path -/- extension <//> "*" <.> osuf way
17
        compile compiler obj2src obj = do
18
            let src = obj2src context obj
19
            need [src]
20
            needDependencies context src $ obj <.> "d"
21
            build $ target context (compiler stage) [src] [obj]
22
        compileHs = \[obj, _hi] -> do
23
            (src, deps) <- lookupDependencies (path -/- ".dependencies") obj
Andrey Mokhov's avatar
Andrey Mokhov committed
24
            need $ src : deps
25
            when (isLibrary package) $ need =<< return <$> pkgConfFile context
26
            needLibrary =<< contextDependencies context
27
            buildWithResources rs $ target context (Ghc CompileHs stage) [src] [obj]
Andrey Mokhov's avatar
Andrey Mokhov committed
28

29
    priority 2.0 $ do
Zhen Zhang's avatar
Zhen Zhang committed
30
31
32
        nonHs "c"   %> compile (Ghc CompileCWithGhc) (obj2src "c"   isGeneratedCFile  )
        nonHs "cmm" %> compile (Ghc CompileHs)       (obj2src "cmm" isGeneratedCmmFile)
        nonHs "s"   %> compile (Ghc CompileHs)       (obj2src "S"   $ const False     )
Andrey Mokhov's avatar
Andrey Mokhov committed
33

34
35
36
    -- TODO: Add dependencies for #include of .h and .hs-incl files (gcc -MM?).
    [ path <//> "*" <.> suf way | suf <- [    osuf,     hisuf] ] &%> compileHs
    [ path <//> "*" <.> suf way | suf <- [obootsuf, hibootsuf] ] &%> compileHs
37

38
39
40
41
42
-- | Discover dependencies of a given source file by iteratively calling @gcc@
-- in the @-MM -MG@ mode and building generated dependencies if they are missing
-- until reaching a fixed point.
needDependencies :: Context -> FilePath -> FilePath -> Action ()
needDependencies context@Context {..} src depFile = discover
43
  where
44
    discover = do
45
        build $ target context (Cc FindCDependencies stage) [src] [depFile]
46
47
48
49
50
51
52
        deps <- parseFile depFile
        -- Generated dependencies, if not yet built, will not be found and hence
        -- will be referred to simply by their file names.
        let notFound = filter (\file -> file == takeFileName file) deps
        -- We find the full paths to generated dependencies, so we can request
        -- to build them by calling 'need'.
        todo <- catMaybes <$> mapM (fullPathIfGenerated context) notFound
53

54
55
56
57
58
        if null todo
        then need deps -- The list of dependencies is final, need all
        else do
            need todo  -- Build newly discovered generated dependencies
            discover   -- Continue the discovery process
59
60
61
62
63
64
65
66

    parseFile :: FilePath -> Action [String]
    parseFile file = do
        input <- liftIO $ readFile file
        case parseMakefile input of
            [(_file, deps)] -> return deps
            _               -> return []

67
68
69
70
71
72
73
-- | Find a given 'FilePath' in the list of generated files in the given
-- 'Context' and return its full path.
fullPathIfGenerated :: Context -> FilePath -> Action (Maybe FilePath)
fullPathIfGenerated context file = interpretInContext context $ do
    generated <- generatedDependencies
    return $ find ((== file) . takeFileName) generated

74
75
76
77
78
79
80
81
obj2src :: String -> (FilePath -> Bool) -> Context -> FilePath -> FilePath
obj2src extension isGenerated context@Context {..} obj
    | isGenerated src = src
    | otherwise       = pkgPath package ++ suffix
  where
    src    = obj -<.> extension
    suffix = fromMaybe ("Cannot determine source for " ++ obj)
           $ stripPrefix (buildPath context -/- extension) src