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