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