Hadrian: Generate GHC wrapper scripts
[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
174 (root -/- "ghc-stage1") <~ ghcWrapper Stage1
175 (root -/- "ghc-stage2") <~ ghcWrapper Stage2
176
177 priority 2.0 $ (root -/- generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH
178 priority 2.0 $ (root -/- generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH
179 priority 2.0 $ (root -/- generatedDir -/- "ghcversion.h") <~ generateGhcVersionH
180
181 -- TODO: simplify, get rid of fake rts context
182 root -/- generatedDir ++ "//*" %> \file -> do
183 withTempDir $ \dir -> build $
184 target (rtsContext Stage1) DeriveConstants [] [file, dir]
185 where
186 file <~ gen = file %> \out -> generate out emptyTarget gen
187
188 -- TODO: Use the Types, Luke! (drop partial function)
189 -- We sometimes need to evaluate expressions that do not require knowing all
190 -- information about the context. In this case, we don't want to know anything.
191 emptyTarget :: Context
192 emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
193 (error "Rules.Generate.emptyTarget: unknown package")
194
195 -- Generators
196
197 -- | GHC wrapper scripts used for passing the path to the right package database
198 -- when invoking in-tree GHC executables.
199 ghcWrapper :: Stage -> Expr String
200 ghcWrapper Stage0 = error "Stage0 GHC does not require a wrapper script to run."
201 ghcWrapper stage = do
202 dbPath <- expr $ packageDbPath stage
203 ghcPath <- expr $ programPath (vanillaContext (pred stage) ghc)
204 return $ unwords $ map show $ [ ghcPath ]
205 ++ [ "-package-db " ++ dbPath | stage == Stage1 ]
206 ++ [ "$@" ]
207
208 -- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
209 -- the resulting 'String' is a valid C preprocessor identifier.
210 cppify :: String -> String
211 cppify = replaceEq '-' '_' . replaceEq '.' '_'
212
213 -- | Generate @ghcplatform.h@ header.
214 generateGhcPlatformH :: Expr String
215 generateGhcPlatformH = do
216 trackGenerateHs
217 hostPlatform <- getSetting HostPlatform
218 hostArch <- getSetting HostArch
219 hostOs <- getSetting HostOs
220 hostVendor <- getSetting HostVendor
221 targetPlatform <- getSetting TargetPlatform
222 targetArch <- getSetting TargetArch
223 targetOs <- getSetting TargetOs
224 targetVendor <- getSetting TargetVendor
225 ghcUnreg <- getFlag GhcUnregisterised
226 return . unlines $
227 [ "#ifndef __GHCPLATFORM_H__"
228 , "#define __GHCPLATFORM_H__"
229 , ""
230 , "#define BuildPlatform_TYPE " ++ cppify hostPlatform
231 , "#define HostPlatform_TYPE " ++ cppify targetPlatform
232 , ""
233 , "#define " ++ cppify hostPlatform ++ "_BUILD 1"
234 , "#define " ++ cppify targetPlatform ++ "_HOST 1"
235 , ""
236 , "#define " ++ hostArch ++ "_BUILD_ARCH 1"
237 , "#define " ++ targetArch ++ "_HOST_ARCH 1"
238 , "#define BUILD_ARCH " ++ show hostArch
239 , "#define HOST_ARCH " ++ show targetArch
240 , ""
241 , "#define " ++ hostOs ++ "_BUILD_OS 1"
242 , "#define " ++ targetOs ++ "_HOST_OS 1"
243 , "#define BUILD_OS " ++ show hostOs
244 , "#define HOST_OS " ++ show targetOs
245 , ""
246 , "#define " ++ hostVendor ++ "_BUILD_VENDOR 1"
247 , "#define " ++ targetVendor ++ "_HOST_VENDOR 1"
248 , "#define BUILD_VENDOR " ++ show hostVendor
249 , "#define HOST_VENDOR " ++ show targetVendor
250 , ""
251 , "/* These TARGET macros are for backwards compatibility... DO NOT USE! */"
252 , "#define TargetPlatform_TYPE " ++ cppify targetPlatform
253 , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
254 , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
255 , "#define TARGET_ARCH " ++ show targetArch
256 , "#define " ++ targetOs ++ "_TARGET_OS 1"
257 , "#define TARGET_OS " ++ show targetOs
258 , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1" ]
259 ++
260 [ "#define UnregisterisedCompiler 1" | ghcUnreg ]
261 ++
262 [ "\n#endif /* __GHCPLATFORM_H__ */" ]
263
264 -- | Generate @Config.hs@ files.
265 generateConfigHs :: Expr String
266 generateConfigHs = do
267 trackGenerateHs
268 cProjectName <- getSetting ProjectName
269 cProjectGitCommitId <- getSetting ProjectGitCommitId
270 cProjectVersion <- getSetting ProjectVersion
271 cProjectVersionInt <- getSetting ProjectVersionInt
272 cProjectPatchLevel <- getSetting ProjectPatchLevel
273 cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
274 cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
275 cBooterVersion <- getSetting GhcVersion
276 intLib <- getIntegerPackage
277 debugged <- ghcDebugged <$> expr flavour
278 let cIntegerLibraryType
279 | intLib == integerGmp = "IntegerGMP"
280 | intLib == integerSimple = "IntegerSimple"
281 | otherwise = error $ "Unknown integer library: " ++ pkgName intLib
282 cGhcWithInterpreter <- expr $ yesNo <$> ghcWithInterpreter
283 cGhcWithNativeCodeGen <- expr $ yesNo <$> ghcWithNativeCodeGen
284 cGhcWithSMP <- expr $ yesNo <$> ghcWithSMP
285 cGhcEnableTablesNextToCode <- expr $ yesNo <$> ghcEnableTablesNextToCode
286 cLeadingUnderscore <- expr $ yesNo <$> flag LeadingUnderscore
287 cGHC_UNLIT_PGM <- fmap takeFileName $ getBuilderPath Unlit
288 cLibFFI <- expr useLibFFIForAdjustors
289 rtsWays <- getRtsWays
290 cGhcRtsWithLibdw <- getFlag WithLibdw
291 let cGhcRTSWays = unwords $ map show rtsWays
292 return $ unlines
293 [ "{-# LANGUAGE CPP #-}"
294 , "module Config where"
295 , ""
296 , "import GhcPrelude"
297 , ""
298 , "#include \"ghc_boot_platform.h\""
299 , ""
300 , "data IntegerLibrary = IntegerGMP"
301 , " | IntegerSimple"
302 , " deriving Eq"
303 , ""
304 , "cBuildPlatformString :: String"
305 , "cBuildPlatformString = BuildPlatform_NAME"
306 , "cHostPlatformString :: String"
307 , "cHostPlatformString = HostPlatform_NAME"
308 , "cTargetPlatformString :: String"
309 , "cTargetPlatformString = TargetPlatform_NAME"
310 , ""
311 , "cProjectName :: String"
312 , "cProjectName = " ++ show cProjectName
313 , "cProjectGitCommitId :: String"
314 , "cProjectGitCommitId = " ++ show cProjectGitCommitId
315 , "cProjectVersion :: String"
316 , "cProjectVersion = " ++ show cProjectVersion
317 , "cProjectVersionInt :: String"
318 , "cProjectVersionInt = " ++ show cProjectVersionInt
319 , "cProjectPatchLevel :: String"
320 , "cProjectPatchLevel = " ++ show cProjectPatchLevel
321 , "cProjectPatchLevel1 :: String"
322 , "cProjectPatchLevel1 = " ++ show cProjectPatchLevel1
323 , "cProjectPatchLevel2 :: String"
324 , "cProjectPatchLevel2 = " ++ show cProjectPatchLevel2
325 , "cBooterVersion :: String"
326 , "cBooterVersion = " ++ show cBooterVersion
327 , "cStage :: String"
328 , "cStage = show (STAGE :: Int)"
329 , "cIntegerLibrary :: String"
330 , "cIntegerLibrary = " ++ show (pkgName intLib)
331 , "cIntegerLibraryType :: IntegerLibrary"
332 , "cIntegerLibraryType = " ++ cIntegerLibraryType
333 , "cGhcWithInterpreter :: String"
334 , "cGhcWithInterpreter = " ++ show cGhcWithInterpreter
335 , "cGhcWithNativeCodeGen :: String"
336 , "cGhcWithNativeCodeGen = " ++ show cGhcWithNativeCodeGen
337 , "cGhcWithSMP :: String"
338 , "cGhcWithSMP = " ++ show cGhcWithSMP
339 , "cGhcRTSWays :: String"
340 , "cGhcRTSWays = " ++ show cGhcRTSWays
341 , "cGhcEnableTablesNextToCode :: String"
342 , "cGhcEnableTablesNextToCode = " ++ show cGhcEnableTablesNextToCode
343 , "cLeadingUnderscore :: String"
344 , "cLeadingUnderscore = " ++ show cLeadingUnderscore
345 , "cGHC_UNLIT_PGM :: String"
346 , "cGHC_UNLIT_PGM = " ++ show cGHC_UNLIT_PGM
347 , "cLibFFI :: Bool"
348 , "cLibFFI = " ++ show cLibFFI
349 , "cGhcThreaded :: Bool"
350 , "cGhcThreaded = " ++ show (any (wayUnit Threaded) rtsWays)
351 , "cGhcDebugged :: Bool"
352 , "cGhcDebugged = " ++ show debugged
353 , "cGhcRtsWithLibdw :: Bool"
354 , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
355
356 -- | Generate @ghcautoconf.h@ header.
357 generateGhcAutoconfH :: Expr String
358 generateGhcAutoconfH = do
359 trackGenerateHs
360 configHContents <- expr $ map undefinePackage <$> readFileLines configH
361 tablesNextToCode <- expr ghcEnableTablesNextToCode
362 ghcUnreg <- getFlag GhcUnregisterised
363 ccLlvmBackend <- getSetting CcLlvmBackend
364 ccClangBackend <- getSetting CcClangBackend
365 return . unlines $
366 [ "#ifndef __GHCAUTOCONF_H__"
367 , "#define __GHCAUTOCONF_H__" ]
368 ++ configHContents ++
369 [ "\n#define TABLES_NEXT_TO_CODE 1" | tablesNextToCode && not ghcUnreg ]
370 ++
371 [ "\n#define llvm_CC_FLAVOR 1" | ccLlvmBackend == "1" ]
372 ++
373 [ "\n#define clang_CC_FLAVOR 1" | ccClangBackend == "1" ]
374 ++
375 [ "#endif /* __GHCAUTOCONF_H__ */" ]
376 where
377 undefinePackage s
378 | "#define PACKAGE_" `isPrefixOf` s
379 = "/* #undef " ++ takeWhile (/=' ') (drop 8 s) ++ " */"
380 | otherwise = s
381
382 -- | Generate @ghc_boot_platform.h@ headers.
383 generateGhcBootPlatformH :: Expr String
384 generateGhcBootPlatformH = do
385 trackGenerateHs
386 stage <- getStage
387 let chooseSetting x y = getSetting $ if stage == Stage0 then x else y
388 buildPlatform <- chooseSetting BuildPlatform HostPlatform
389 buildArch <- chooseSetting BuildArch HostArch
390 buildOs <- chooseSetting BuildOs HostOs
391 buildVendor <- chooseSetting BuildVendor HostVendor
392 hostPlatform <- chooseSetting HostPlatform TargetPlatform
393 hostArch <- chooseSetting HostArch TargetArch
394 hostOs <- chooseSetting HostOs TargetOs
395 hostVendor <- chooseSetting HostVendor TargetVendor
396 targetPlatform <- getSetting TargetPlatform
397 targetArch <- getSetting TargetArch
398 llvmTarget <- getSetting LlvmTarget
399 targetOs <- getSetting TargetOs
400 targetVendor <- getSetting TargetVendor
401 return $ unlines
402 [ "#ifndef __PLATFORM_H__"
403 , "#define __PLATFORM_H__"
404 , ""
405 , "#define BuildPlatform_NAME " ++ show buildPlatform
406 , "#define HostPlatform_NAME " ++ show hostPlatform
407 , "#define TargetPlatform_NAME " ++ show targetPlatform
408 , ""
409 , "#define " ++ cppify buildPlatform ++ "_BUILD 1"
410 , "#define " ++ cppify hostPlatform ++ "_HOST 1"
411 , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
412 , ""
413 , "#define " ++ buildArch ++ "_BUILD_ARCH 1"
414 , "#define " ++ hostArch ++ "_HOST_ARCH 1"
415 , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
416 , "#define BUILD_ARCH " ++ show buildArch
417 , "#define HOST_ARCH " ++ show hostArch
418 , "#define TARGET_ARCH " ++ show targetArch
419 , "#define LLVM_TARGET " ++ show llvmTarget
420 , ""
421 , "#define " ++ buildOs ++ "_BUILD_OS 1"
422 , "#define " ++ hostOs ++ "_HOST_OS 1"
423 , "#define " ++ targetOs ++ "_TARGET_OS 1"
424 , "#define BUILD_OS " ++ show buildOs
425 , "#define HOST_OS " ++ show hostOs
426 , "#define TARGET_OS " ++ show targetOs
427 , ""
428 , "#define " ++ buildVendor ++ "_BUILD_VENDOR 1"
429 , "#define " ++ hostVendor ++ "_HOST_VENDOR 1"
430 , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1"
431 , "#define BUILD_VENDOR " ++ show buildVendor
432 , "#define HOST_VENDOR " ++ show hostVendor
433 , "#define TARGET_VENDOR " ++ show targetVendor
434 , ""
435 , "#endif /* __PLATFORM_H__ */" ]
436
437 -- | Generate @ghcversion.h@ header.
438 generateGhcVersionH :: Expr String
439 generateGhcVersionH = do
440 trackGenerateHs
441 version <- getSetting ProjectVersionInt
442 patchLevel1 <- getSetting ProjectPatchLevel1
443 patchLevel2 <- getSetting ProjectPatchLevel2
444 return . unlines $
445 [ "#ifndef __GHCVERSION_H__"
446 , "#define __GHCVERSION_H__"
447 , ""
448 , "#ifndef __GLASGOW_HASKELL__"
449 , "# define __GLASGOW_HASKELL__ " ++ version
450 , "#endif"
451 , ""]
452 ++
453 [ "#define __GLASGOW_HASKELL_PATCHLEVEL1__ " ++ patchLevel1 | patchLevel1 /= "" ]
454 ++
455 [ "#define __GLASGOW_HASKELL_PATCHLEVEL2__ " ++ patchLevel2 | patchLevel2 /= "" ]
456 ++
457 [ ""
458 , "#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\\"
459 , " ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \\"
460 , " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\"
461 , " && (pl1) < __GLASGOW_HASKELL_PATCHLEVEL1__ || \\"
462 , " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\"
463 , " && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \\"
464 , " && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )"
465 , ""
466 , "#endif /* __GHCVERSION_H__ */" ]
467
468 -- | Generate @Version.hs@ files.
469 generateVersionHs :: Expr String
470 generateVersionHs = do
471 trackGenerateHs
472 projectVersion <- getSetting ProjectVersion
473 targetOs <- getSetting TargetOs
474 targetArch <- getSetting TargetArch
475 return $ unlines
476 [ "module Version where"
477 , "version, targetOS, targetARCH :: String"
478 , "version = " ++ show projectVersion
479 , "targetOS = " ++ show targetOs
480 , "targetARCH = " ++ show targetArch ]