032f6a68c1579af31139585b95f3b02e950bdbae
[ghc.git] / hadrian / src / Rules / Generate.hs
1 module Rules.Generate (
2 isGeneratedCmmFile, compilerDependencies, generatePackageCode,
3 generateRules, copyRules, generatedDependencies, generatedGhcDependencies,
4 ghcPrimDependencies
5 ) where
6
7 import Base
8 import Expression
9 import Flavour
10 import Oracles.Flag
11 import Oracles.ModuleFiles
12 import Oracles.Setting
13 import Packages
14 import Rules.Gmp
15 import Rules.Libffi
16 import Settings
17 import Target
18 import Utilities
19
20 -- | Track this file to rebuild generated files whenever it changes.
21 trackGenerateHs :: Expr ()
22 trackGenerateHs = expr $ need [sourcePath -/- "Rules/Generate.hs"]
23
24 primopsSource :: FilePath
25 primopsSource = "compiler/prelude/primops.txt.pp"
26
27 primopsTxt :: Stage -> FilePath
28 primopsTxt stage = buildDir (vanillaContext stage compiler) -/- "primops.txt"
29
30 isGeneratedCmmFile :: FilePath -> Bool
31 isGeneratedCmmFile file = takeBaseName file == "AutoApply"
32
33 ghcPrimDependencies :: Expr [FilePath]
34 ghcPrimDependencies = do
35 stage <- getStage
36 path <- expr $ buildPath (vanillaContext stage ghcPrim)
37 return [path -/- "GHC/Prim.hs", path -/- "GHC/PrimopWrappers.hs"]
38
39 derivedConstantsDependencies :: [FilePath]
40 derivedConstantsDependencies = fmap (generatedDir -/-)
41 [ "DerivedConstants.h"
42 , "GHCConstantsHaskellExports.hs"
43 , "GHCConstantsHaskellType.hs"
44 , "GHCConstantsHaskellWrappers.hs" ]
45
46 compilerDependencies :: Expr [FilePath]
47 compilerDependencies = do
48 root <- getBuildRoot
49 stage <- getStage
50 isGmp <- (== integerGmp) <$> getIntegerPackage
51 ghcPath <- expr $ buildPath (vanillaContext stage compiler)
52 gmpPath <- expr gmpBuildPath
53 rtsPath <- expr (rtsBuildPath stage)
54 mconcat [ return ((root -/-) <$> derivedConstantsDependencies)
55 , notStage0 ? isGmp ? return [gmpPath -/- gmpLibraryH]
56 , notStage0 ? return ((rtsPath -/-) <$> libffiDependencies)
57 , return $ fmap (ghcPath -/-)
58 [ "primop-can-fail.hs-incl"
59 , "primop-code-size.hs-incl"
60 , "primop-commutable.hs-incl"
61 , "primop-data-decl.hs-incl"
62 , "primop-fixity.hs-incl"
63 , "primop-has-side-effects.hs-incl"
64 , "primop-list.hs-incl"
65 , "primop-out-of-line.hs-incl"
66 , "primop-primop-info.hs-incl"
67 , "primop-strictness.hs-incl"
68 , "primop-tag.hs-incl"
69 , "primop-vector-tycons.hs-incl"
70 , "primop-vector-tys-exports.hs-incl"
71 , "primop-vector-tys.hs-incl"
72 , "primop-vector-uniques.hs-incl" ] ]
73
74 generatedDependencies :: Expr [FilePath]
75 generatedDependencies = do
76 root <- getBuildRoot
77 stage <- getStage
78 rtsPath <- expr (rtsBuildPath stage)
79 includes <- expr includesDependencies
80 mconcat [ package compiler ? compilerDependencies
81 , package ghcPrim ? ghcPrimDependencies
82 , package rts ? return (fmap (rtsPath -/-) libffiDependencies
83 ++ includes
84 ++ fmap (root -/-) derivedConstantsDependencies)
85 , stage0 ? return includes ]
86
87 generate :: FilePath -> Context -> Expr String -> Action ()
88 generate file context expr = do
89 contents <- interpretInContext context expr
90 writeFileChanged file contents
91 putSuccess $ "| Successfully generated " ++ file ++ "."
92
93 generatePackageCode :: Context -> Rules ()
94 generatePackageCode context@(Context stage pkg _) = do
95 root <- buildRootRules
96 let dir = buildDir context
97 generated f = (root -/- dir ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
98 go gen file = generate file context gen
99 generated ?> \file -> do
100 let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
101 (src, builder) <- unpack <$> findGenerator context file
102 need [src]
103 build $ target context builder [src] [file]
104 let boot = src -<.> "hs-boot"
105 whenM (doesFileExist boot) $ do
106 let target = file -<.> "hs-boot"
107 copyFile boot target
108 produces [target]
109
110 priority 2.0 $ do
111 when (pkg == compiler) $ do
112 root <//> dir -/- "Config.hs" %> go generateConfigHs
113 root <//> dir -/- "*.hs-incl" %> genPrimopCode context
114 when (pkg == ghcPrim) $ do
115 root <//> dir -/- "GHC/Prim.hs" %> genPrimopCode context
116 root <//> dir -/- "GHC/PrimopWrappers.hs" %> genPrimopCode context
117 when (pkg == ghcPkg) $
118 root <//> dir -/- "Version.hs" %> go generateVersionHs
119
120 when (pkg == compiler) $ do
121 root -/- primopsTxt stage %> \file -> do
122 includes <- includesDependencies
123 need $ [primopsSource] ++ includes
124 build $ target context HsCpp [primopsSource] [file]
125
126 root -/- stageString stage <//> "ghc_boot_platform.h" %>
127 go generateGhcBootPlatformH
128
129 when (pkg == rts) $ do
130 root <//> dir -/- "cmm/AutoApply.cmm" %> \file ->
131 build $ target context GenApply [] [file]
132 -- TODO: This should be fixed properly, e.g. generated here on demand.
133 (root <//> dir -/- "DerivedConstants.h") <~ (buildRoot <&> (-/- generatedDir))
134 (root <//> dir -/- "ghcautoconf.h") <~ (buildRoot <&> (-/- generatedDir))
135 (root <//> dir -/- "ghcplatform.h") <~ (buildRoot <&> (-/- generatedDir))
136 (root <//> dir -/- "ghcversion.h") <~ (buildRoot <&> (-/- generatedDir))
137 where
138 pattern <~ mdir = pattern %> \file -> do
139 dir <- mdir
140 copyFile (dir -/- takeFileName file) file
141
142 genPrimopCode :: Context -> FilePath -> Action ()
143 genPrimopCode context@(Context stage _pkg _) file = do
144 root <- buildRoot
145 need [root -/- primopsTxt stage]
146 build $ target context GenPrimopCode [root -/- primopsTxt stage] [file]
147
148 copyRules :: Rules ()
149 copyRules = do
150 root <- buildRootRules
151 forM_ [Stage0 ..] $ \stage -> do
152 let prefix = root -/- stageString stage -/- "lib"
153
154 infixl 1 <~
155 pattern <~ mdir = pattern %> \file -> do
156 dir <- mdir
157 copyFile (dir -/- makeRelative prefix file) file
158
159 prefix -/- "ghc-usage.txt" <~ return "driver"
160 prefix -/- "ghci-usage.txt" <~ return "driver"
161 prefix -/- "llvm-targets" <~ return "."
162 prefix -/- "llvm-passes" <~ return "."
163 prefix -/- "platformConstants" <~ (buildRoot <&> (-/- generatedDir))
164 prefix -/- "settings" <~ return "."
165 prefix -/- "template-hsc.h" <~ return (pkgPath hsc2hs)
166
167 prefix -/- "html//*" <~ return "utils/haddock/haddock-api/resources"
168 prefix -/- "latex//*" <~ return "utils/haddock/haddock-api/resources"
169
170 generateRules :: Rules ()
171 generateRules = do
172 root <- buildRootRules
173 priority 2.0 $ (root -/- generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH
174 priority 2.0 $ (root -/- generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH
175 priority 2.0 $ (root -/- generatedDir -/- "ghcversion.h") <~ generateGhcVersionH
176
177 -- TODO: simplify, get rid of fake rts context
178 root -/- generatedDir ++ "//*" %> \file -> do
179 withTempDir $ \dir -> build $
180 target (rtsContext Stage1) DeriveConstants [] [file, dir]
181 where
182 file <~ gen = file %> \out -> generate out emptyTarget gen
183
184 -- TODO: Use the Types, Luke! (drop partial function)
185 -- We sometimes need to evaluate expressions that do not require knowing all
186 -- information about the context. In this case, we don't want to know anything.
187 emptyTarget :: Context
188 emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
189 (error "Rules.Generate.emptyTarget: unknown package")
190
191 -- Generators
192
193 -- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
194 -- the resulting 'String' is a valid C preprocessor identifier.
195 cppify :: String -> String
196 cppify = replaceEq '-' '_' . replaceEq '.' '_'
197
198 -- | Generate @ghcplatform.h@ header.
199 generateGhcPlatformH :: Expr String
200 generateGhcPlatformH = do
201 trackGenerateHs
202 hostPlatform <- getSetting HostPlatform
203 hostArch <- getSetting HostArch
204 hostOs <- getSetting HostOs
205 hostVendor <- getSetting HostVendor
206 targetPlatform <- getSetting TargetPlatform
207 targetArch <- getSetting TargetArch
208 targetOs <- getSetting TargetOs
209 targetVendor <- getSetting TargetVendor
210 ghcUnreg <- getFlag GhcUnregisterised
211 return . unlines $
212 [ "#ifndef __GHCPLATFORM_H__"
213 , "#define __GHCPLATFORM_H__"
214 , ""
215 , "#define BuildPlatform_TYPE " ++ cppify hostPlatform
216 , "#define HostPlatform_TYPE " ++ cppify targetPlatform
217 , ""
218 , "#define " ++ cppify hostPlatform ++ "_BUILD 1"
219 , "#define " ++ cppify targetPlatform ++ "_HOST 1"
220 , ""
221 , "#define " ++ hostArch ++ "_BUILD_ARCH 1"
222 , "#define " ++ targetArch ++ "_HOST_ARCH 1"
223 , "#define BUILD_ARCH " ++ show hostArch
224 , "#define HOST_ARCH " ++ show targetArch
225 , ""
226 , "#define " ++ hostOs ++ "_BUILD_OS 1"
227 , "#define " ++ targetOs ++ "_HOST_OS 1"
228 , "#define BUILD_OS " ++ show hostOs
229 , "#define HOST_OS " ++ show targetOs
230 , ""
231 , "#define " ++ hostVendor ++ "_BUILD_VENDOR 1"
232 , "#define " ++ targetVendor ++ "_HOST_VENDOR 1"
233 , "#define BUILD_VENDOR " ++ show hostVendor
234 , "#define HOST_VENDOR " ++ show targetVendor
235 , ""
236 , "/* These TARGET macros are for backwards compatibility... DO NOT USE! */"
237 , "#define TargetPlatform_TYPE " ++ cppify targetPlatform
238 , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
239 , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
240 , "#define TARGET_ARCH " ++ show targetArch
241 , "#define " ++ targetOs ++ "_TARGET_OS 1"
242 , "#define TARGET_OS " ++ show targetOs
243 , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1" ]
244 ++
245 [ "#define UnregisterisedCompiler 1" | ghcUnreg ]
246 ++
247 [ "\n#endif /* __GHCPLATFORM_H__ */" ]
248
249 -- | Generate @Config.hs@ files.
250 generateConfigHs :: Expr String
251 generateConfigHs = do
252 trackGenerateHs
253 cProjectName <- getSetting ProjectName
254 cProjectGitCommitId <- getSetting ProjectGitCommitId
255 cProjectVersion <- getSetting ProjectVersion
256 cProjectVersionInt <- getSetting ProjectVersionInt
257 cProjectPatchLevel <- getSetting ProjectPatchLevel
258 cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
259 cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
260 cBooterVersion <- getSetting GhcVersion
261 intLib <- getIntegerPackage
262 debugged <- ghcDebugged <$> expr flavour
263 let cIntegerLibraryType
264 | intLib == integerGmp = "IntegerGMP"
265 | intLib == integerSimple = "IntegerSimple"
266 | otherwise = error $ "Unknown integer library: " ++ pkgName intLib
267 cGhcWithInterpreter <- expr $ yesNo <$> ghcWithInterpreter
268 cGhcWithNativeCodeGen <- expr $ yesNo <$> ghcWithNativeCodeGen
269 cGhcWithSMP <- expr $ yesNo <$> ghcWithSMP
270 cGhcEnableTablesNextToCode <- expr $ yesNo <$> ghcEnableTablesNextToCode
271 cLeadingUnderscore <- expr $ yesNo <$> flag LeadingUnderscore
272 cGHC_UNLIT_PGM <- fmap takeFileName $ getBuilderPath Unlit
273 cLibFFI <- expr useLibFFIForAdjustors
274 rtsWays <- getRtsWays
275 cGhcRtsWithLibdw <- getFlag WithLibdw
276 let cGhcRTSWays = unwords $ map show rtsWays
277 return $ unlines
278 [ "{-# LANGUAGE CPP #-}"
279 , "module Config where"
280 , ""
281 , "import GhcPrelude"
282 , ""
283 , "#include \"ghc_boot_platform.h\""
284 , ""
285 , "data IntegerLibrary = IntegerGMP"
286 , " | IntegerSimple"
287 , " deriving Eq"
288 , ""
289 , "cBuildPlatformString :: String"
290 , "cBuildPlatformString = BuildPlatform_NAME"
291 , "cHostPlatformString :: String"
292 , "cHostPlatformString = HostPlatform_NAME"
293 , "cTargetPlatformString :: String"
294 , "cTargetPlatformString = TargetPlatform_NAME"
295 , ""
296 , "cProjectName :: String"
297 , "cProjectName = " ++ show cProjectName
298 , "cProjectGitCommitId :: String"
299 , "cProjectGitCommitId = " ++ show cProjectGitCommitId
300 , "cProjectVersion :: String"
301 , "cProjectVersion = " ++ show cProjectVersion
302 , "cProjectVersionInt :: String"
303 , "cProjectVersionInt = " ++ show cProjectVersionInt
304 , "cProjectPatchLevel :: String"
305 , "cProjectPatchLevel = " ++ show cProjectPatchLevel
306 , "cProjectPatchLevel1 :: String"
307 , "cProjectPatchLevel1 = " ++ show cProjectPatchLevel1
308 , "cProjectPatchLevel2 :: String"
309 , "cProjectPatchLevel2 = " ++ show cProjectPatchLevel2
310 , "cBooterVersion :: String"
311 , "cBooterVersion = " ++ show cBooterVersion
312 , "cStage :: String"
313 , "cStage = show (STAGE :: Int)"
314 , "cIntegerLibrary :: String"
315 , "cIntegerLibrary = " ++ show (pkgName intLib)
316 , "cIntegerLibraryType :: IntegerLibrary"
317 , "cIntegerLibraryType = " ++ cIntegerLibraryType
318 , "cGhcWithInterpreter :: String"
319 , "cGhcWithInterpreter = " ++ show cGhcWithInterpreter
320 , "cGhcWithNativeCodeGen :: String"
321 , "cGhcWithNativeCodeGen = " ++ show cGhcWithNativeCodeGen
322 , "cGhcWithSMP :: String"
323 , "cGhcWithSMP = " ++ show cGhcWithSMP
324 , "cGhcRTSWays :: String"
325 , "cGhcRTSWays = " ++ show cGhcRTSWays
326 , "cGhcEnableTablesNextToCode :: String"
327 , "cGhcEnableTablesNextToCode = " ++ show cGhcEnableTablesNextToCode
328 , "cLeadingUnderscore :: String"
329 , "cLeadingUnderscore = " ++ show cLeadingUnderscore
330 , "cGHC_UNLIT_PGM :: String"
331 , "cGHC_UNLIT_PGM = " ++ show cGHC_UNLIT_PGM
332 , "cLibFFI :: Bool"
333 , "cLibFFI = " ++ show cLibFFI
334 , "cGhcThreaded :: Bool"
335 , "cGhcThreaded = " ++ show (any (wayUnit Threaded) rtsWays)
336 , "cGhcDebugged :: Bool"
337 , "cGhcDebugged = " ++ show debugged
338 , "cGhcRtsWithLibdw :: Bool"
339 , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
340
341 -- | Generate @ghcautoconf.h@ header.
342 generateGhcAutoconfH :: Expr String
343 generateGhcAutoconfH = do
344 trackGenerateHs
345 configHContents <- expr $ map undefinePackage <$> readFileLines configH
346 tablesNextToCode <- expr ghcEnableTablesNextToCode
347 ghcUnreg <- getFlag GhcUnregisterised
348 ccLlvmBackend <- getSetting CcLlvmBackend
349 ccClangBackend <- getSetting CcClangBackend
350 return . unlines $
351 [ "#ifndef __GHCAUTOCONF_H__"
352 , "#define __GHCAUTOCONF_H__" ]
353 ++ configHContents ++
354 [ "\n#define TABLES_NEXT_TO_CODE 1" | tablesNextToCode && not ghcUnreg ]
355 ++
356 [ "\n#define llvm_CC_FLAVOR 1" | ccLlvmBackend == "1" ]
357 ++
358 [ "\n#define clang_CC_FLAVOR 1" | ccClangBackend == "1" ]
359 ++
360 [ "#endif /* __GHCAUTOCONF_H__ */" ]
361 where
362 undefinePackage s
363 | "#define PACKAGE_" `isPrefixOf` s
364 = "/* #undef " ++ takeWhile (/=' ') (drop 8 s) ++ " */"
365 | otherwise = s
366
367 -- | Generate @ghc_boot_platform.h@ headers.
368 generateGhcBootPlatformH :: Expr String
369 generateGhcBootPlatformH = do
370 trackGenerateHs
371 stage <- getStage
372 let chooseSetting x y = getSetting $ if stage == Stage0 then x else y
373 buildPlatform <- chooseSetting BuildPlatform HostPlatform
374 buildArch <- chooseSetting BuildArch HostArch
375 buildOs <- chooseSetting BuildOs HostOs
376 buildVendor <- chooseSetting BuildVendor HostVendor
377 hostPlatform <- chooseSetting HostPlatform TargetPlatform
378 hostArch <- chooseSetting HostArch TargetArch
379 hostOs <- chooseSetting HostOs TargetOs
380 hostVendor <- chooseSetting HostVendor TargetVendor
381 targetPlatform <- getSetting TargetPlatform
382 targetArch <- getSetting TargetArch
383 llvmTarget <- getSetting LlvmTarget
384 targetOs <- getSetting TargetOs
385 targetVendor <- getSetting TargetVendor
386 return $ unlines
387 [ "#ifndef __PLATFORM_H__"
388 , "#define __PLATFORM_H__"
389 , ""
390 , "#define BuildPlatform_NAME " ++ show buildPlatform
391 , "#define HostPlatform_NAME " ++ show hostPlatform
392 , "#define TargetPlatform_NAME " ++ show targetPlatform
393 , ""
394 , "#define " ++ cppify buildPlatform ++ "_BUILD 1"
395 , "#define " ++ cppify hostPlatform ++ "_HOST 1"
396 , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
397 , ""
398 , "#define " ++ buildArch ++ "_BUILD_ARCH 1"
399 , "#define " ++ hostArch ++ "_HOST_ARCH 1"
400 , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
401 , "#define BUILD_ARCH " ++ show buildArch
402 , "#define HOST_ARCH " ++ show hostArch
403 , "#define TARGET_ARCH " ++ show targetArch
404 , "#define LLVM_TARGET " ++ show llvmTarget
405 , ""
406 , "#define " ++ buildOs ++ "_BUILD_OS 1"
407 , "#define " ++ hostOs ++ "_HOST_OS 1"
408 , "#define " ++ targetOs ++ "_TARGET_OS 1"
409 , "#define BUILD_OS " ++ show buildOs
410 , "#define HOST_OS " ++ show hostOs
411 , "#define TARGET_OS " ++ show targetOs
412 , ""
413 , "#define " ++ buildVendor ++ "_BUILD_VENDOR 1"
414 , "#define " ++ hostVendor ++ "_HOST_VENDOR 1"
415 , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1"
416 , "#define BUILD_VENDOR " ++ show buildVendor
417 , "#define HOST_VENDOR " ++ show hostVendor
418 , "#define TARGET_VENDOR " ++ show targetVendor
419 , ""
420 , "#endif /* __PLATFORM_H__ */" ]
421
422 -- | Generate @ghcversion.h@ header.
423 generateGhcVersionH :: Expr String
424 generateGhcVersionH = do
425 trackGenerateHs
426 version <- getSetting ProjectVersionInt
427 patchLevel1 <- getSetting ProjectPatchLevel1
428 patchLevel2 <- getSetting ProjectPatchLevel2
429 return . unlines $
430 [ "#ifndef __GHCVERSION_H__"
431 , "#define __GHCVERSION_H__"
432 , ""
433 , "#ifndef __GLASGOW_HASKELL__"
434 , "# define __GLASGOW_HASKELL__ " ++ version
435 , "#endif"
436 , ""]
437 ++
438 [ "#define __GLASGOW_HASKELL_PATCHLEVEL1__ " ++ patchLevel1 | patchLevel1 /= "" ]
439 ++
440 [ "#define __GLASGOW_HASKELL_PATCHLEVEL2__ " ++ patchLevel2 | patchLevel2 /= "" ]
441 ++
442 [ ""
443 , "#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\\"
444 , " ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \\"
445 , " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\"
446 , " && (pl1) < __GLASGOW_HASKELL_PATCHLEVEL1__ || \\"
447 , " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\"
448 , " && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \\"
449 , " && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )"
450 , ""
451 , "#endif /* __GHCVERSION_H__ */" ]
452
453 -- | Generate @Version.hs@ files.
454 generateVersionHs :: Expr String
455 generateVersionHs = do
456 trackGenerateHs
457 projectVersion <- getSetting ProjectVersion
458 targetOs <- getSetting TargetOs
459 targetArch <- getSetting TargetArch
460 return $ unlines
461 [ "module Version where"
462 , "version, targetOS, targetARCH :: String"
463 , "version = " ++ show projectVersion
464 , "targetOS = " ++ show targetOs
465 , "targetARCH = " ++ show targetArch ]