0bf6f1db014f9e7d94fdd5c702b7461b8196ed4b
[ghc.git] / hadrian / src / Rules / Compile.hs
1 module Rules.Compile (compilePackage) where
2
3 import Hadrian.BuildPath
4 import Hadrian.Oracles.TextFile
5
6 import Base
7 import Context
8 import Expression
9 import Rules.Generate
10 import Settings
11 import Target
12 import Utilities
13 import Rules.Library
14
15 import qualified Text.Parsec as Parsec
16
17 -- * Rules for building objects and Haskell interface files
18
19 compilePackage :: [(Resource, Int)] -> Rules ()
20 compilePackage rs = do
21 root <- buildRootRules
22 -- We match all file paths that look like:
23 -- <root>/...stuffs.../build/...stuffs.../<something>.<suffix>
24 --
25 -- where:
26 -- - the '...stuffs...' bits can be one or more path components,
27 -- - the '<suffix>' part is a way prefix (e.g thr_p_, or nothing if
28 -- vanilla) followed by an object file extension, without the dot
29 -- (o, o-boot, hi, hi-boot),
30 --
31 -- and parse the information we need (stage, package path, ...) from
32 -- the path and figure out the suitable way to produce that object file.
33 objectFilesUnder root |%> \path -> do
34 obj <- parsePath (parseBuildObject root) "<object file path parser>" path
35 compileObject rs path obj
36 where
37 objectFilesUnder r = [ r -/- ("**/build/**/*" ++ pat)
38 | pat <- extensionPats ]
39
40 exts = [ "o", "hi", "o-boot", "hi-boot" ]
41 patternsFor e = [ "." ++ e, ".*_" ++ e ]
42 extensionPats = concatMap patternsFor exts
43
44 -- * Object file paths types and parsers
45
46 {- We are using a non uniform representation that separates
47 object files produced from Haskell code and from other
48 languages, because the two "groups" have to be parsed
49 differently enough that this would complicated the parser
50 significantly.
51
52 Indeed, non-Haskell files can only produce .o (or .thr_o, ...)
53 files while Haskell modules can produce those as well as
54 interface files, both in -boot or non-boot variants.
55
56 Moreover, non-Haskell object files live under:
57 <root>/stage<N>/<path/to/pkg>/build/{c,cmm,s}/
58
59 while Haskell object/interface files live under:
60 <root>/stage<N>/<path/to/pkg>/build/
61
62 So the kind of object is partially determined by
63 whether we're in c/, cmm/ or s/ but also by the
64 object file's extension, in the case of a Haskell file.
65 This could have been addressed with some knot-tying but
66 Parsec's monad doesn't give us a MonadFix instance.
67
68 We therefore stick to treating those two type of object
69 files non uniformly.
70 -}
71
72 -- | Non Haskell source languages that we compile to get object files.
73 data SourceLang = Asm | C | Cmm deriving (Eq, Show)
74
75 parseSourceLang :: Parsec.Parsec String () SourceLang
76 parseSourceLang = Parsec.choice
77 [ Parsec.char 'c' *> Parsec.choice
78 [ Parsec.string "mm" *> pure Cmm
79 , pure C
80 ]
81 , Parsec.char 's' *> pure Asm
82 ]
83
84 type Basename = String
85
86 parseBasename :: Parsec.Parsec String () Basename
87 parseBasename = Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.char '.')
88
89 -- | > <c|cmm|s>/<file>.<way prefix>_o
90 data NonHsObject = NonHsObject SourceLang Basename Way
91 deriving (Eq, Show)
92
93 parseNonHsObject :: Parsec.Parsec String () NonHsObject
94 parseNonHsObject = do
95 lang <- parseSourceLang
96 _ <- Parsec.char '/'
97 file <- parseBasename
98 way <- parseWayPrefix vanilla
99 _ <- Parsec.char 'o'
100 return (NonHsObject lang file way)
101
102 -- | > <o|hi|o-boot|hi-boot>
103 data SuffixType = O | Hi | OBoot | HiBoot deriving (Eq, Show)
104
105 parseSuffixType :: Parsec.Parsec String () SuffixType
106 parseSuffixType = Parsec.choice
107 [ Parsec.char 'o' *> Parsec.choice
108 [ Parsec.string "-boot" *> pure OBoot
109 , pure O
110 ]
111 , Parsec.string "hi" *> Parsec.choice
112 [ Parsec.string "-boot" *> pure HiBoot
113 , pure Hi
114 ]
115 ]
116
117 -- | > <way prefix>_<o|hi|o-boot|hi-boot>
118 data Extension = Extension Way SuffixType deriving (Eq, Show)
119
120 parseExtension :: Parsec.Parsec String () Extension
121 parseExtension = Extension <$> parseWayPrefix vanilla <*> parseSuffixType
122
123 -- | > <file>.<way prefix>_<o|hi|o-boot|hi-boot>
124 data HsObject = HsObject Basename Extension deriving (Eq, Show)
125
126 parseHsObject :: Parsec.Parsec String () HsObject
127 parseHsObject = do
128 file <- parseBasename
129 ext <- parseExtension
130 return (HsObject file ext)
131
132 data Object = Hs HsObject | NonHs NonHsObject deriving (Eq, Show)
133
134 parseObject :: Parsec.Parsec String () Object
135 parseObject = Parsec.choice
136 [ NonHs <$> parseNonHsObject
137 , Hs <$> parseHsObject ]
138
139 -- * Toplevel parsers
140
141 parseBuildObject :: FilePath -> Parsec.Parsec String () (BuildPath Object)
142 parseBuildObject root = parseBuildPath root parseObject
143
144 -- * Getting contexts from objects
145
146 objectContext :: BuildPath Object -> Context
147 objectContext (BuildPath _ stage pkgPath obj) =
148 Context stage (unsafeFindPackageByPath pkgPath) way
149 where
150 way = case obj of
151 NonHs (NonHsObject _lang _file w) -> w
152 Hs (HsObject _file (Extension w _suf)) -> w
153
154 -- * Building an object
155
156 compileHsObject
157 :: [(Resource, Int)] -> FilePath -> BuildPath Object -> HsObject -> Action ()
158 compileHsObject rs objpath b@(BuildPath _root stage _path _o) hsobj =
159 case hsobj of
160 HsObject _basename (Extension way Hi ) -> need [objpath -<.> osuf way]
161 HsObject _basename (Extension way HiBoot) -> need [objpath -<.> obootsuf way]
162 HsObject _basename (Extension way suf) -> do
163 let ctx = objectContext b
164 ctxPath <- contextPath ctx
165 (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
166 need (src:deps)
167 needLibrary =<< contextDependencies ctx
168
169 -- The .dependencies files only lists shallow dependencies. ghc will
170 -- generally read more *.hi and *.hi-boot files (deep dependencies).
171 -- Allow such reads (see https://gitlab.haskell.org/ghc/ghc/wikis/Developing-Hadrian#cloud-shared-cache-build)
172 -- Note that this may allow too many *.hi and *.hi-boot files, but
173 -- calculating the exact set of deep dependencies is not feasible.
174 trackAllow [ "//*." ++ hisuf way
175 , "//*." ++ hibootsuf way
176 ]
177
178 buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath]
179 -- Andrey: It appears that the previous refactoring has broken
180 -- multiple-output build rules. Ideally, we should bring multiple-output
181 -- rules back, see: https://github.com/snowleopard/hadrian/issues/216.
182 -- As a temporary solution, I'm using Shake's new 'produces' feature to
183 -- record that this rule also produces a corresponding interface file.
184 let hi | suf == O = objpath -<.> hisuf way
185 | suf == OBoot = objpath -<.> hibootsuf way
186 | otherwise = error "Internal error: unknown Haskell object extension"
187 produces [hi]
188
189 compileNonHsObject
190 :: [(Resource, Int)] -> FilePath -> BuildPath Object -> NonHsObject
191 -> Action ()
192 compileNonHsObject rs objpath b@(BuildPath _root stage _path _o) nonhsobj =
193 case nonhsobj of
194 NonHsObject lang _basename _way ->
195 go (builderFor lang) (toSrcFor lang)
196
197 where builderFor C = Ghc CompileCWithGhc
198 builderFor _ = Ghc CompileHs
199
200 toSrcFor Asm = obj2src "S" (const False)
201 toSrcFor C = obj2src "c" (const False)
202 toSrcFor Cmm = obj2src "cmm" isGeneratedCmmFile
203
204 go builder tosrc = do
205 let ctx = objectContext b
206 src <- tosrc ctx objpath
207 need [src]
208 needDependencies ctx src (objpath <.> "d")
209 buildWithResources rs $ target ctx (builder stage) [src] [objpath]
210
211 compileObject
212 :: [(Resource, Int)] -> FilePath -> BuildPath Object -> Action ()
213 compileObject rs objpath b@(BuildPath _root _stage _path (Hs o)) =
214 compileHsObject rs objpath b o
215 compileObject rs objpath b@(BuildPath _root _stage _path (NonHs o)) =
216 compileNonHsObject rs objpath b o
217
218 -- * Helpers
219
220 -- | Discover dependencies of a given source file by iteratively calling @gcc@
221 -- in the @-MM -MG@ mode and building generated dependencies if they are missing
222 -- until reaching a fixed point.
223 needDependencies :: Context -> FilePath -> FilePath -> Action ()
224 needDependencies context@Context {..} src depFile = discover
225 where
226 discover = do
227 build $ target context (Cc FindCDependencies stage) [src] [depFile]
228 deps <- parseFile depFile
229 -- Generated dependencies, if not yet built, will not be found and hence
230 -- will be referred to simply by their file names.
231 let notFound = filter (\file -> file == takeFileName file) deps
232 -- We find the full paths to generated dependencies, so we can request
233 -- to build them by calling 'need'.
234 todo <- catMaybes <$> mapM (fullPathIfGenerated context) notFound
235
236 if null todo
237 then need deps -- The list of dependencies is final, need all
238 else do
239 need todo -- Build newly discovered generated dependencies
240 discover -- Continue the discovery process
241
242 parseFile :: FilePath -> Action [String]
243 parseFile file = do
244 input <- liftIO $ readFile file
245 case parseMakefile input of
246 [(_file, deps)] -> return deps
247 _ -> return []
248
249 -- | Find a given 'FilePath' in the list of generated files in the given
250 -- 'Context' and return its full path.
251 fullPathIfGenerated :: Context -> FilePath -> Action (Maybe FilePath)
252 fullPathIfGenerated context file = interpretInContext context $ do
253 generated <- generatedDependencies
254 return $ find ((== file) . takeFileName) generated
255
256 obj2src :: String -> (FilePath -> Bool) -> Context -> FilePath -> Action FilePath
257 obj2src extension isGenerated context@Context {..} obj
258 | isGenerated src = return src
259 | otherwise = (pkgPath package ++) <$> suffix
260 where
261 src = obj -<.> extension
262 suffix = do
263 path <- buildPath context
264 return $ fromMaybe ("Cannot determine source for " ++ obj)
265 $ stripPrefix (path -/- extension) src