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