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