Make PackageName into a proper newtype
[hadrian.git] / src / Rules / Generate.hs
1 module Rules.Generate (generatePackageCode) where
2
3 import Expression
4 import GHC
5 import Oracles
6 import Oracles.ModuleFiles
7 import Rules.Actions
8 import Rules.Resources (Resources)
9 import Settings
10
11 primopsSource :: FilePath
12 primopsSource = "compiler/prelude/primops.txt.pp"
13
14 -- The following generators and corresponding source extensions are supported:
15 knownGenerators :: [ (Builder, String) ]
16 knownGenerators = [ (Alex , ".x" )
17 , (Happy , ".y" )
18 , (Happy , ".ly" )
19 , (Hsc2Hs , ".hsc") ]
20
21 determineBuilder :: FilePath -> Maybe Builder
22 determineBuilder file = fmap fst $ find (\(_, e) -> e == ext) knownGenerators
23 where
24 ext = takeExtension file
25
26 generatePackageCode :: Resources -> PartialTarget -> Rules ()
27 generatePackageCode _ target @ (PartialTarget stage pkg) =
28 let path = targetPath stage pkg
29 buildPath = path -/- "build"
30 primopsTxt = targetPath stage compiler -/- "build/primops.txt"
31 platformH = targetPath stage compiler -/- "ghc_boot_platform.h"
32 generated f = (buildPath ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
33 in do
34 generated ?> \file -> do
35 let pattern = "//" ++ takeBaseName file <.> "*"
36 files <- fmap (filter (pattern ?==)) $ moduleFiles stage pkg
37 let gens = [ (f, b) | f <- files, Just b <- [determineBuilder f] ]
38 when (length gens /= 1) . putError $
39 "Exactly one generator expected for " ++ file
40 ++ " (found: " ++ show gens ++ ")."
41 let (src, builder) = head gens
42 need [src]
43 build $ fullTarget target builder [src] [file]
44 let srcBoot = src -<.> "hs-boot"
45 whenM (doesFileExist srcBoot) $
46 copyFileChanged srcBoot $ file -<.> "hs-boot"
47
48 when (pkg == compiler) $ primopsTxt %> \file -> do
49 need [platformH, primopsSource]
50 build $ fullTarget target HsCpp [primopsSource] [file]
51
52 -- TODO: why different folders for generated files?
53 -- TODO: needing platformH is ugly and fragile
54 fmap (buildPath -/-)
55 [ "GHC/PrimopWrappers.hs"
56 , "autogen/GHC/Prim.hs"
57 , "*.hs-incl" ] |%> \file -> do
58 need [primopsTxt]
59 build $ fullTarget target GenPrimopCode [primopsTxt] [file]
60
61 priority 2.0 $ buildPath -/- "Config.hs" %> \file -> do
62 contents <- interpretPartial target generateConfigHs
63 writeFileChanged file contents
64 putBuild $ "| Successfully generated '" ++ file ++ "'."
65
66 when (pkg == compiler) $ platformH %> \file -> do
67 contents <- interpretPartial target generatePlatformH
68 writeFileChanged file contents
69 putBuild $ "| Successfully generated '" ++ file ++ "'."
70
71 priority 2.0 $
72 when (pkg == ghcPkg) $ buildPath -/- "Version.hs" %> \file -> do
73 contents <- interpretPartial target generateGhcPkgVersionHs
74 writeFileChanged file contents
75 putBuild $ "| Successfully generated '" ++ file ++ "'."
76
77 priority 2.0 $
78 when (pkg == runghc) $ buildPath -/- "Main.hs" %> \file -> do
79 copyFileChanged (pkgPath pkg -/- "runghc.hs") file
80 putBuild $ "| Successfully generated '" ++ file ++ "'."
81
82 quote :: String -> String
83 quote s = "\"" ++ s ++ "\""
84
85 -- TODO: do we need ghc-split? Always or is it platform specific?
86 -- TODO: add tracking by moving these functions to separate tracked files
87 generateConfigHs :: Expr String
88 generateConfigHs = do
89 cProjectName <- getSetting ProjectName
90 cProjectGitCommitId <- getSetting ProjectGitCommitId
91 cProjectVersion <- getSetting ProjectVersion
92 cProjectVersionInt <- getSetting ProjectVersionInt
93 cProjectPatchLevel <- getSetting ProjectPatchLevel
94 cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
95 cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
96 cBooterVersion <- getSetting GhcVersion
97 let cIntegerLibraryType | integerLibrary == integerGmp = "IntegerGMP"
98 | integerLibrary == integerSimple = "IntegerSimple"
99 | otherwise = error $ "Unknown integer library: "
100 ++ show integerLibrary ++ "."
101 yesNo = lift . fmap (\x -> if x then "YES" else "NO")
102 cSupportsSplitObjs <- yesNo supportsSplitObjects
103 cGhcWithInterpreter <- yesNo ghcWithInterpreter
104 cGhcWithNativeCodeGen <- yesNo ghcWithNativeCodeGen
105 cGhcWithSMP <- yesNo ghcWithSMP
106 cGhcEnableTablesNextToCode <- yesNo ghcEnableTablesNextToCode
107 cLeadingUnderscore <- yesNo $ flag LeadingUnderscore
108 cGHC_UNLIT_PGM <- fmap takeFileName $ getBuilderPath Unlit
109 cGHC_SPLIT_PGM <- fmap takeBaseName $ getBuilderPath GhcSplit
110 cLibFFI <- lift useLibFFIForAdjustors
111 rtsWays <- getRtsWays
112 cGhcRtsWithLibdw <- getFlag WithLibdw
113 let cGhcRTSWays = unwords $ map show rtsWays
114 return $ unlines
115 [ "{-# LANGUAGE CPP #-}"
116 , "module Config where"
117 , ""
118 , "#include \"ghc_boot_platform.h\""
119 , ""
120 , "data IntegerLibrary = IntegerGMP"
121 , " | IntegerSimple"
122 , " deriving Eq"
123 , ""
124 , "cBuildPlatformString :: String"
125 , "cBuildPlatformString = BuildPlatform_NAME"
126 , "cHostPlatformString :: String"
127 , "cHostPlatformString = HostPlatform_NAME"
128 , "cTargetPlatformString :: String"
129 , "cTargetPlatformString = TargetPlatform_NAME"
130 , ""
131 , "cProjectName :: String"
132 , "cProjectName = " ++ quote cProjectName
133 , "cProjectGitCommitId :: String"
134 , "cProjectGitCommitId = " ++ quote cProjectGitCommitId
135 , "cProjectVersion :: String"
136 , "cProjectVersion = " ++ quote cProjectVersion
137 , "cProjectVersionInt :: String"
138 , "cProjectVersionInt = " ++ quote cProjectVersionInt
139 , "cProjectPatchLevel :: String"
140 , "cProjectPatchLevel = " ++ quote cProjectPatchLevel
141 , "cProjectPatchLevel1 :: String"
142 , "cProjectPatchLevel1 = " ++ quote cProjectPatchLevel1
143 , "cProjectPatchLevel2 :: String"
144 , "cProjectPatchLevel2 = " ++ quote cProjectPatchLevel2
145 , "cBooterVersion :: String"
146 , "cBooterVersion = " ++ quote cBooterVersion
147 , "cStage :: String"
148 , "cStage = show (STAGE :: Int)"
149 , "cIntegerLibrary :: String"
150 , "cIntegerLibrary = " ++ quote (pkgNameString integerLibrary)
151 , "cIntegerLibraryType :: IntegerLibrary"
152 , "cIntegerLibraryType = " ++ cIntegerLibraryType
153 , "cSupportsSplitObjs :: String"
154 , "cSupportsSplitObjs = " ++ quote cSupportsSplitObjs
155 , "cGhcWithInterpreter :: String"
156 , "cGhcWithInterpreter = " ++ quote cGhcWithInterpreter
157 , "cGhcWithNativeCodeGen :: String"
158 , "cGhcWithNativeCodeGen = " ++ quote cGhcWithNativeCodeGen
159 , "cGhcWithSMP :: String"
160 , "cGhcWithSMP = " ++ quote cGhcWithSMP
161 , "cGhcRTSWays :: String"
162 , "cGhcRTSWays = " ++ quote cGhcRTSWays
163 , "cGhcEnableTablesNextToCode :: String"
164 , "cGhcEnableTablesNextToCode = " ++ quote cGhcEnableTablesNextToCode
165 , "cLeadingUnderscore :: String"
166 , "cLeadingUnderscore = " ++ quote cLeadingUnderscore
167 , "cGHC_UNLIT_PGM :: String"
168 , "cGHC_UNLIT_PGM = " ++ quote cGHC_UNLIT_PGM
169 , "cGHC_SPLIT_PGM :: String"
170 , "cGHC_SPLIT_PGM = " ++ quote cGHC_SPLIT_PGM
171 , "cLibFFI :: Bool"
172 , "cLibFFI = " ++ show cLibFFI
173 , "cGhcThreaded :: Bool"
174 , "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
175 , "cGhcDebugged :: Bool"
176 , "cGhcDebugged = " ++ show ghcDebugged
177 , "cGhcRtsWithLibdw :: Bool"
178 , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
179
180 generatePlatformH :: Expr String
181 generatePlatformH = do
182 stage <- getStage
183 let cppify = replaceEq '-' '_' . replaceEq '.' '_'
184 chooseSetting x y = getSetting $ if stage == Stage0 then x else y
185 buildPlatform <- chooseSetting BuildPlatform HostPlatform
186 buildArch <- chooseSetting BuildArch HostArch
187 buildOs <- chooseSetting BuildOs HostOs
188 buildVendor <- chooseSetting BuildVendor HostVendor
189 hostPlatform <- chooseSetting HostPlatform TargetPlatform
190 hostArch <- chooseSetting HostArch TargetArch
191 hostOs <- chooseSetting HostOs TargetOs
192 hostVendor <- chooseSetting HostVendor TargetVendor
193 targetPlatform <- getSetting TargetPlatform
194 targetArch <- getSetting TargetArch
195 targetOs <- getSetting TargetOs
196 targetVendor <- getSetting TargetVendor
197 return $ unlines
198 [ "#ifndef __PLATFORM_H__"
199 , "#define __PLATFORM_H__"
200 , ""
201 , "#define BuildPlatform_NAME " ++ quote buildPlatform
202 , "#define HostPlatform_NAME " ++ quote hostPlatform
203 , "#define TargetPlatform_NAME " ++ quote targetPlatform
204 , ""
205 , "#define " ++ cppify buildPlatform ++ "_BUILD 1"
206 , "#define " ++ cppify hostPlatform ++ "_HOST 1"
207 , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
208 , ""
209 , "#define " ++ buildArch ++ "_BUILD_ARCH 1"
210 , "#define " ++ hostArch ++ "_HOST_ARCH 1"
211 , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
212 , "#define BUILD_ARCH " ++ quote buildArch
213 , "#define HOST_ARCH " ++ quote hostArch
214 , "#define TARGET_ARCH " ++ quote targetArch
215 , ""
216 , "#define " ++ buildOs ++ "_BUILD_OS 1"
217 , "#define " ++ hostOs ++ "_HOST_OS 1"
218 , "#define " ++ targetOs ++ "_TARGET_OS 1"
219 , "#define BUILD_OS " ++ quote buildOs
220 , "#define HOST_OS " ++ quote hostOs
221 , "#define TARGET_OS " ++ quote targetOs
222 , ""
223 , "#define " ++ buildVendor ++ "_BUILD_VENDOR 1"
224 , "#define " ++ hostVendor ++ "_HOST_VENDOR 1"
225 , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1"
226 , "#define BUILD_VENDOR " ++ quote buildVendor
227 , "#define HOST_VENDOR " ++ quote hostVendor
228 , "#define TARGET_VENDOR " ++ quote targetVendor
229 , ""
230 , "#endif /* __PLATFORM_H__ */" ]
231
232 generateGhcPkgVersionHs :: Expr String
233 generateGhcPkgVersionHs = do
234 projectVersion <- getSetting ProjectVersion
235 targetOs <- getSetting TargetOs
236 targetArch <- getSetting TargetArch
237 return $ unlines
238 [ "module Version where"
239 , "version, targetOS, targetARCH :: String"
240 , "version = " ++ quote projectVersion
241 , "targetOS = " ++ quote targetOs
242 , "targetARCH = " ++ quote targetArch ]