0c35e85dd7ab34490968247906308603691585be
[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 , ("unlit command", ("$topdir/bin/" <>) . takeFileName <$> builderPath Unlit)
294 , ("cross compiling", flag' CrossCompiling)
295 , ("target os", lookupValueOrError configFile "haskell-target-os")
296 , ("target arch", lookupValueOrError configFile "haskell-target-arch")
297 , ("target word size", lookupValueOrError configFile "target-word-size")
298 , ("target has GNU nonexec stack", lookupValueOrError configFile "haskell-have-gnu-nonexec-stack")
299 , ("target has .ident directive", lookupValueOrError configFile "haskell-have-ident-directive")
300 , ("target has subsections via symbols", lookupValueOrError configFile "haskell-have-subsections-via-symbols")
301 , ("target has RTS linker", lookupValueOrError configFile "haskell-have-rts-linker")
302 , ("Unregisterised", flag' GhcUnregisterised)
303 , ("LLVM llc command", settingsFileSetting SettingsFileSetting_LlcCommand)
304 , ("LLVM opt command", settingsFileSetting SettingsFileSetting_OptCommand)
305 , ("LLVM clang command", settingsFileSetting SettingsFileSetting_ClangCommand)
306 ]
307 let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"
308 pure $ case settings of
309 [] -> "[]"
310 s : ss -> unlines $
311 ("[" ++ showTuple s)
312 : ((\s' -> "," ++ showTuple s') <$> ss)
313 ++ ["]"]
314
315
316 -- | Generate @Config.hs@ files.
317 generateConfigHs :: Expr String
318 generateConfigHs = do
319 trackGenerateHs
320 cProjectName <- getSetting ProjectName
321 cProjectGitCommitId <- getSetting ProjectGitCommitId
322 cProjectVersion <- getSetting ProjectVersion
323 cProjectVersionInt <- getSetting ProjectVersionInt
324 cProjectPatchLevel <- getSetting ProjectPatchLevel
325 cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
326 cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
327 cBooterVersion <- getSetting GhcVersion
328 intLib <- getIntegerPackage
329 debugged <- ghcDebugged <$> expr flavour
330 let cIntegerLibraryType
331 | intLib == integerGmp = "IntegerGMP"
332 | intLib == integerSimple = "IntegerSimple"
333 | otherwise = error $ "Unknown integer library: " ++ pkgName intLib
334 cGhcWithInterpreter <- expr $ yesNo <$> ghcWithInterpreter
335 cGhcWithNativeCodeGen <- expr $ yesNo <$> ghcWithNativeCodeGen
336 cGhcWithSMP <- expr $ yesNo <$> ghcWithSMP
337 cGhcEnableTablesNextToCode <- expr $ yesNo <$> ghcEnableTablesNextToCode
338 cLeadingUnderscore <- expr $ yesNo <$> flag LeadingUnderscore
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 , "cLibFFI :: Bool"
397 , "cLibFFI = " ++ show cLibFFI
398 , "cGhcThreaded :: Bool"
399 , "cGhcThreaded = " ++ show (any (wayUnit Threaded) rtsWays)
400 , "cGhcDebugged :: Bool"
401 , "cGhcDebugged = " ++ show debugged
402 , "cGhcRtsWithLibdw :: Bool"
403 , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
404
405 -- | Generate @ghcautoconf.h@ header.
406 generateGhcAutoconfH :: Expr String
407 generateGhcAutoconfH = do
408 trackGenerateHs
409 configHContents <- expr $ map undefinePackage <$> readFileLines configH
410 tablesNextToCode <- expr ghcEnableTablesNextToCode
411 ghcUnreg <- getFlag GhcUnregisterised
412 ccLlvmBackend <- getSetting CcLlvmBackend
413 ccClangBackend <- getSetting CcClangBackend
414 return . unlines $
415 [ "#ifndef __GHCAUTOCONF_H__"
416 , "#define __GHCAUTOCONF_H__" ]
417 ++ configHContents ++
418 [ "\n#define TABLES_NEXT_TO_CODE 1" | tablesNextToCode && not ghcUnreg ]
419 ++
420 [ "\n#define llvm_CC_FLAVOR 1" | ccLlvmBackend == "1" ]
421 ++
422 [ "\n#define clang_CC_FLAVOR 1" | ccClangBackend == "1" ]
423 ++
424 [ "#endif /* __GHCAUTOCONF_H__ */" ]
425 where
426 undefinePackage s
427 | "#define PACKAGE_" `isPrefixOf` s
428 = "/* #undef " ++ takeWhile (/=' ') (drop 8 s) ++ " */"
429 | otherwise = s
430
431 -- | Generate @ghc_boot_platform.h@ headers.
432 generateGhcBootPlatformH :: Expr String
433 generateGhcBootPlatformH = do
434 trackGenerateHs
435 stage <- getStage
436 let chooseSetting x y = getSetting $ if stage == Stage0 then x else y
437 buildPlatform <- chooseSetting BuildPlatform HostPlatform
438 buildArch <- chooseSetting BuildArch HostArch
439 buildOs <- chooseSetting BuildOs HostOs
440 buildVendor <- chooseSetting BuildVendor HostVendor
441 hostPlatform <- chooseSetting HostPlatform TargetPlatform
442 hostArch <- chooseSetting HostArch TargetArch
443 hostOs <- chooseSetting HostOs TargetOs
444 hostVendor <- chooseSetting HostVendor TargetVendor
445 targetPlatform <- getSetting TargetPlatform
446 targetArch <- getSetting TargetArch
447 llvmTarget <- getSetting LlvmTarget
448 targetOs <- getSetting TargetOs
449 targetVendor <- getSetting TargetVendor
450 return $ unlines
451 [ "#ifndef __PLATFORM_H__"
452 , "#define __PLATFORM_H__"
453 , ""
454 , "#define BuildPlatform_NAME " ++ show buildPlatform
455 , "#define HostPlatform_NAME " ++ show hostPlatform
456 , "#define TargetPlatform_NAME " ++ show targetPlatform
457 , ""
458 , "#define " ++ cppify buildPlatform ++ "_BUILD 1"
459 , "#define " ++ cppify hostPlatform ++ "_HOST 1"
460 , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
461 , ""
462 , "#define " ++ buildArch ++ "_BUILD_ARCH 1"
463 , "#define " ++ hostArch ++ "_HOST_ARCH 1"
464 , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
465 , "#define BUILD_ARCH " ++ show buildArch
466 , "#define HOST_ARCH " ++ show hostArch
467 , "#define TARGET_ARCH " ++ show targetArch
468 , "#define LLVM_TARGET " ++ show llvmTarget
469 , ""
470 , "#define " ++ buildOs ++ "_BUILD_OS 1"
471 , "#define " ++ hostOs ++ "_HOST_OS 1"
472 , "#define " ++ targetOs ++ "_TARGET_OS 1"
473 , "#define BUILD_OS " ++ show buildOs
474 , "#define HOST_OS " ++ show hostOs
475 , "#define TARGET_OS " ++ show targetOs
476 , ""
477 , "#define " ++ buildVendor ++ "_BUILD_VENDOR 1"
478 , "#define " ++ hostVendor ++ "_HOST_VENDOR 1"
479 , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1"
480 , "#define BUILD_VENDOR " ++ show buildVendor
481 , "#define HOST_VENDOR " ++ show hostVendor
482 , "#define TARGET_VENDOR " ++ show targetVendor
483 , ""
484 , "#endif /* __PLATFORM_H__ */" ]
485
486 -- | Generate @ghcversion.h@ header.
487 generateGhcVersionH :: Expr String
488 generateGhcVersionH = do
489 trackGenerateHs
490 version <- getSetting ProjectVersionInt
491 patchLevel1 <- getSetting ProjectPatchLevel1
492 patchLevel2 <- getSetting ProjectPatchLevel2
493 return . unlines $
494 [ "#ifndef __GHCVERSION_H__"
495 , "#define __GHCVERSION_H__"
496 , ""
497 , "#ifndef __GLASGOW_HASKELL__"
498 , "# define __GLASGOW_HASKELL__ " ++ version
499 , "#endif"
500 , ""]
501 ++
502 [ "#define __GLASGOW_HASKELL_PATCHLEVEL1__ " ++ patchLevel1 | patchLevel1 /= "" ]
503 ++
504 [ "#define __GLASGOW_HASKELL_PATCHLEVEL2__ " ++ patchLevel2 | patchLevel2 /= "" ]
505 ++
506 [ ""
507 , "#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\\"
508 , " ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \\"
509 , " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\"
510 , " && (pl1) < __GLASGOW_HASKELL_PATCHLEVEL1__ || \\"
511 , " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\"
512 , " && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \\"
513 , " && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )"
514 , ""
515 , "#endif /* __GHCVERSION_H__ */" ]
516
517 -- | Generate @Version.hs@ files.
518 generateVersionHs :: Expr String
519 generateVersionHs = do
520 trackGenerateHs
521 projectVersion <- getSetting ProjectVersion
522 targetOs <- getSetting TargetOs
523 targetArch <- getSetting TargetArch
524 return $ unlines
525 [ "module Version where"
526 , "version, targetOS, targetARCH :: String"
527 , "version = " ++ show projectVersion
528 , "targetOS = " ++ show targetOs
529 , "targetARCH = " ++ show targetArch ]