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