Refactor paths using Context.
[hadrian.git] / src / Rules / Generate.hs
1 module Rules.Generate (
2 generatePackageCode, generateRules, installTargets, copyRules,
3 includesDependencies, derivedConstantsPath, generatedDependencies
4 ) where
5
6 import qualified System.Directory as IO
7
8 import Base
9 import Context hiding (stage)
10 import Expression
11 import GHC
12 import Rules.Generators.ConfigHs
13 import Rules.Generators.GhcAutoconfH
14 import Rules.Generators.GhcBootPlatformH
15 import Rules.Generators.GhcPlatformH
16 import Rules.Generators.GhcSplit
17 import Rules.Generators.GhcVersionH
18 import Rules.Generators.VersionHs
19 import Oracles.ModuleFiles
20 import Rules.Actions
21 import Rules.Gmp
22 import Rules.Libffi
23 import Settings
24 import Target hiding (builder, context)
25
26 installTargets :: [FilePath]
27 installTargets = [ "inplace/lib/ghc-usage.txt"
28 , "inplace/lib/ghci-usage.txt"
29 , "inplace/lib/platformConstants"
30 , "inplace/lib/settings"
31 , "inplace/lib/template-hsc.h" ]
32
33 primopsSource :: FilePath
34 primopsSource = "compiler/prelude/primops.txt.pp"
35
36 primopsTxt :: Stage -> FilePath
37 primopsTxt stage =
38 contextPath (vanillaContext stage compiler) -/- "build/primops.txt"
39
40 platformH :: Stage -> FilePath
41 platformH stage =
42 contextPath (vanillaContext stage compiler) -/- "ghc_boot_platform.h"
43
44 -- TODO: move generated files to buildRootPath, see #113
45 includesDependencies :: [FilePath]
46 includesDependencies = ("includes" -/-) <$>
47 [ "ghcautoconf.h"
48 , "ghcplatform.h"
49 , "ghcversion.h" ]
50
51 ghcPrimDependencies :: Stage -> [FilePath]
52 ghcPrimDependencies stage =
53 ((contextPath (vanillaContext stage ghcPrim) -/- "build") -/-) <$>
54 [ "autogen/GHC/Prim.hs"
55 , "GHC/PrimopWrappers.hs" ]
56
57 derivedConstantsPath :: FilePath
58 derivedConstantsPath = "includes/dist-derivedconstants/header"
59
60 derivedConstantsDependencies :: [FilePath]
61 derivedConstantsDependencies = installTargets ++ fmap (derivedConstantsPath -/-)
62 [ "DerivedConstants.h"
63 , "GHCConstantsHaskellExports.hs"
64 , "GHCConstantsHaskellType.hs"
65 , "GHCConstantsHaskellWrappers.hs" ]
66
67 compilerDependencies :: Stage -> [FilePath]
68 compilerDependencies stage =
69 [ platformH stage ]
70 ++ includesDependencies
71 ++ [ gmpLibraryH | stage > Stage0 ]
72 ++ filter (const $ stage > Stage0) libffiDependencies
73 ++ derivedConstantsDependencies
74 ++ fmap ((contextPath (vanillaContext stage compiler) -/- "build") -/-)
75 [ "primop-can-fail.hs-incl"
76 , "primop-code-size.hs-incl"
77 , "primop-commutable.hs-incl"
78 , "primop-data-decl.hs-incl"
79 , "primop-fixity.hs-incl"
80 , "primop-has-side-effects.hs-incl"
81 , "primop-list.hs-incl"
82 , "primop-out-of-line.hs-incl"
83 , "primop-primop-info.hs-incl"
84 , "primop-strictness.hs-incl"
85 , "primop-tag.hs-incl"
86 , "primop-vector-tycons.hs-incl"
87 , "primop-vector-tys-exports.hs-incl"
88 , "primop-vector-tys.hs-incl"
89 , "primop-vector-uniques.hs-incl" ]
90
91 -- TODO: Turn this into a FilePaths expression
92 generatedDependencies :: Stage -> Package -> [FilePath]
93 generatedDependencies stage pkg
94 | pkg == compiler = compilerDependencies stage
95 | pkg == ghcPrim = ghcPrimDependencies stage
96 | pkg == rts = libffiDependencies ++ includesDependencies
97 ++ derivedConstantsDependencies
98 | stage == Stage0 = includesDependencies
99 | otherwise = []
100
101 -- The following generators and corresponding source extensions are supported:
102 knownGenerators :: [ (Builder, String) ]
103 knownGenerators = [ (Alex , ".x" )
104 , (Happy , ".y" )
105 , (Happy , ".ly" )
106 , (Hsc2Hs, ".hsc") ]
107
108 determineBuilder :: FilePath -> Maybe Builder
109 determineBuilder file = fmap fst $ find (\(_, e) -> e == ext) knownGenerators
110 where
111 ext = takeExtension file
112
113 generate :: FilePath -> Context -> Expr String -> Action ()
114 generate file context expr = do
115 contents <- interpretInContext context expr
116 writeFileChanged file contents
117 putSuccess $ "| Successfully generated '" ++ file ++ "'."
118
119 generatePackageCode :: Context -> Rules ()
120 generatePackageCode context @ (Context stage pkg _) =
121 let buildPath = contextPath context -/- "build"
122 dropBuild = drop (length buildPath + 1)
123 generated f = (buildPath ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
124 file <~ gen = generate file context gen
125 in do
126 generated ?> \file -> do
127 let srcFile = dropBuild file
128 pattern = "//" ++ srcFile -<.> "*"
129 files <- fmap (filter (pattern ?==)) $ moduleFiles context
130 let gens = [ (f, b) | f <- files, Just b <- [determineBuilder f] ]
131 when (length gens /= 1) . putError $
132 "Exactly one generator expected for " ++ file
133 ++ " (found: " ++ show gens ++ ")."
134 let (src, builder) = head gens
135 need [src]
136 build $ Target context builder [src] [file]
137 let srcBoot = src -<.> "hs-boot"
138 whenM (doesFileExist srcBoot) $
139 copyFile srcBoot $ file -<.> "hs-boot"
140
141 -- TODO: needing platformH is ugly and fragile
142 when (pkg == compiler) $ primopsTxt stage %> \file -> do
143 need $ [platformH stage, primopsSource] ++ includesDependencies
144 build $ Target context HsCpp [primopsSource] [file]
145
146 -- TODO: why different folders for generated files?
147 fmap (buildPath -/-)
148 [ "autogen/GHC/Prim.hs"
149 , "GHC/PrimopWrappers.hs"
150 , "*.hs-incl" ] |%> \file -> do
151 need [primopsTxt stage]
152 build $ Target context GenPrimopCode [primopsTxt stage] [file]
153 -- TODO: this is temporary hack, get rid of this (#113)
154 let oldPath = pkgPath pkg -/- contextDirectory context -/- "build"
155 newFile = oldPath ++ (drop (length buildPath) file)
156 createDirectory $ takeDirectory newFile
157 liftIO $ IO.copyFile file newFile
158 putSuccess $ "| Duplicate file " ++ file ++ " -> " ++ newFile
159
160 when (pkg == rts) $ buildPath -/- "AutoApply.cmm" %> \file -> do
161 build $ Target context GenApply [] [file]
162
163 priority 2.0 $ do
164 -- TODO: this is temporary hack, get rid of this (#113)
165 let oldPath = pkgPath pkg -/- contextDirectory context
166 olden f = oldPath ++ (drop (length (contextPath context)) f)
167
168 when (pkg == compiler) $ buildPath -/- "Config.hs" %> \file -> do
169 file <~ generateConfigHs
170 olden file <~ generateConfigHs -- TODO: get rid of this (#113)
171
172 when (pkg == compiler) $ platformH stage %> \file -> do
173 file <~ generateGhcBootPlatformH
174
175 when (pkg == ghcPkg) $ buildPath -/- "Version.hs" %> \file -> do
176 file <~ generateVersionHs
177 olden file <~ generateVersionHs -- TODO: get rid of this (#113)
178
179 when (pkg == runGhc) $ buildPath -/- "Main.hs" %> \file -> do
180 copyFileChanged (pkgPath pkg -/- "runghc.hs") file
181 putSuccess $ "| Successfully generated '" ++ file ++ "'."
182
183 copyRules :: Rules ()
184 copyRules = do
185 "inplace/lib/ghc-usage.txt" <~ "driver"
186 "inplace/lib/ghci-usage.txt" <~ "driver"
187 "inplace/lib/platformConstants" <~ derivedConstantsPath
188 "inplace/lib/settings" <~ "."
189 "inplace/lib/template-hsc.h" <~ pkgPath hsc2hs
190 where
191 file <~ dir = file %> \_ -> copyFile (dir -/- takeFileName file) file
192
193 generateRules :: Rules ()
194 generateRules = do
195 "includes/ghcautoconf.h" <~ generateGhcAutoconfH
196 "includes/ghcplatform.h" <~ generateGhcPlatformH
197 "includes/ghcversion.h" <~ generateGhcVersionH
198
199 ghcSplit %> \_ -> do
200 generate ghcSplit emptyTarget generateGhcSplit
201 makeExecutable ghcSplit
202
203 -- TODO: simplify, get rid of fake rts context
204 derivedConstantsPath ++ "//*" %> \file -> do
205 withTempDir $ \dir -> build $
206 Target rtsContext DeriveConstants [] [file, dir]
207
208 where
209 file <~ gen = file %> \out -> generate out emptyTarget gen
210
211 -- TODO: Use the Types, Luke! (drop partial function)
212 -- We sometimes need to evaluate expressions that do not require knowing all
213 -- information about the context. In this case, we don't want to know anything.
214 emptyTarget :: Context
215 emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
216 (error "Rules.Generate.emptyTarget: unknown package")