1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
module Rules.Gmp (gmpRules, gmpBuildPath, gmpObjects) where
import Base
import Context
import Oracles.Setting
import Oracles.Flag
import Packages
import Target
import Utilities
import Hadrian.BuildPath
-- | Build GMP library objects and return their paths.
gmpObjects :: Stage -> Action [FilePath]
gmpObjects s = do
isInTree <- flag GmpInTree
if not isInTree
then return []
else do
-- Indirectly ensure object creation
let ctx = vanillaContext s integerGmp
integerGmpPath <- buildPath ctx
need [integerGmpPath -/- "include/ghc-gmp.h"]
-- The line below causes a Shake Lint failure on Windows, which forced
-- us to disable Lint by default. See more details here:
-- https://gitlab.haskell.org/ghc/ghc/issues/15971.
gmpPath <- gmpIntreePath s
map (unifyPath . (gmpPath -/-)) <$>
liftIO (getDirectoryFilesIO gmpPath [gmpObjectsDir -/- "*.o"])
gmpBase :: FilePath
gmpBase = pkgPath integerGmp -/- "gmp"
-- | GMP is considered a Stage1 package. This determines GMP build directory.
gmpContext :: Context
gmpContext = vanillaContext Stage1 integerGmp
-- | Build directory for in-tree GMP library.
gmpBuildPath :: Stage -> Action FilePath
gmpBuildPath s = gmpIntreePath s <&> (-/- "gmpbuild")
gmpIntreePath :: Stage -> Action FilePath
gmpIntreePath s = buildRoot <&> (-/- stageString s -/- "gmp")
-- | Directory for GMP library object files, relative to 'gmpIntreePath'.
gmpObjectsDir :: FilePath
gmpObjectsDir = "objs"
configureEnvironment :: Stage -> Action [CmdOption]
configureEnvironment s = sequence [ builderEnvironment "CC" $ Cc CompileC s
, builderEnvironment "AR" (Ar Unpack s)
, builderEnvironment "NM" Nm ]
gmpRules :: Rules ()
gmpRules = do
root <- buildRootRules
-- Build in-tree gmp if necessary
-- Produce: integer-gmp/build/include/ghc-gmp.h
-- In-tree: copy gmp.h from in-tree build
-- External: copy ghc-gmp.h from base sources
root -/- "stage*/libraries/integer-gmp/build/include/ghc-gmp.h" %> \header -> do
let includeP = takeDirectory header
buildP = takeDirectory includeP
packageP = takeDirectory buildP
librariesP = takeDirectory packageP
stageP = takeDirectory librariesP
isInTree <- flag GmpInTree
if windowsHost || isInTree -- TODO: We don't use system GMP on Windows. Fix?
then do
putBuild "| No GMP library/framework detected; in tree GMP will be built"
let intreeHeader = stageP -/- "gmp/gmp.h"
need [intreeHeader]
copyFile intreeHeader header
else do
putBuild "| GMP library/framework detected and will be used"
copyFile (gmpBase -/- "ghc-gmp.h") header
-- Build in-tree GMP library for the current stage, prioritised so that it
-- matches "before" the generic @.a@ library rule in 'Rules.Library'.
priority 2.0 $ do
let
-- parse a path of the form "//stage*/gmp/xxx" and returns a vanilla
-- context from it for integer-gmp package.
makeGmpPathContext gmpP = do
let
stageP = takeDirectory gmpP
stageS = takeFileName stageP
stage <- parsePath parseStage "<stage>" stageS
pure (vanillaContext stage integerGmp)
gmpPath = root -/- "stage*/gmp"
-- Build in-tree gmp. Produce:
-- - <root>/stageN/gmp/gmp.h
-- - <root>/stageN/gmp/libgmp.a
-- - <root>/stageN/gmp/objs/*.o (unpacked objects from libgmp.a)
[gmpPath -/- "libgmp.a", gmpPath -/- "gmp.h"] &%> \[lib,header] -> do
let gmpP = takeDirectory lib
ctx <- makeGmpPathContext gmpP
-- build libgmp.a via gmp's Makefile
build $ target ctx (Make (gmpP -/- "gmpbuild")) [gmpP -/- "gmpbuild/Makefile"] []
-- copy header and lib to their final destination
copyFileUntracked (gmpP -/- "gmpbuild/.libs/libgmp.a") lib
copyFileUntracked (gmpP -/- "gmpbuild/gmp.h") header
-- we also unpack objects from libgmp.a into "objs" directory
createDirectory (gmpP -/- gmpObjectsDir)
top <- topDirectory
build $ target ctx (Ar Unpack (stage ctx))
[top -/- gmpP -/- "libgmp.a"] [gmpP -/- gmpObjectsDir]
objs <- liftIO $ getDirectoryFilesIO "." [gmpP -/- gmpObjectsDir -/- "*"]
produces objs
putSuccess "| Successfully built custom library 'gmp'"
-- Run GMP's configure script. Produce:
-- - <root>/stageN/gmp/gmpbuild/Makefile
gmpPath -/- "gmpbuild/Makefile" %> \mk -> do
let gmpBuildP = takeDirectory mk
gmpP = takeDirectory gmpBuildP
ctx <- makeGmpPathContext gmpP
env <- configureEnvironment (stage ctx)
need [mk <.> "in"]
buildWithCmdOptions env $
target gmpContext (Configure gmpBuildP) [mk <.> "in"] [mk]
-- Extract in-tree GMP sources and apply patches. Produce
-- - <root>/stageN/gmp/gmpbuild/Makefile.in
-- - <root>/stageN/gmp/gmpbuild/configure
[gmpPath -/- "gmpbuild/Makefile.in", gmpPath -/- "gmpbuild/configure"] &%> \[mkIn,_] -> do
top <- topDirectory
let destPath = takeDirectory mkIn
removeDirectory destPath
-- Note: We use a tarball like gmp-4.2.4-nodoc.tar.bz2, which is
-- gmp-4.2.4.tar.bz2 repacked without the doc/ directory contents.
-- That's because the doc/ directory contents are under the GFDL,
-- which causes problems for Debian.
tarball <- unifyPath . fromSingleton "Exactly one GMP tarball is expected"
<$> getDirectoryFiles top [gmpBase -/- "gmp-tarballs/gmp*.tar.bz2"]
withTempDir $ \dir -> do
let tmp = unifyPath dir
need [top -/- tarball]
build $ target gmpContext (Tar Extract) [top -/- tarball] [tmp]
let patch = gmpBase -/- "gmpsrc.patch"
patchName = takeFileName patch
copyFile patch $ tmp -/- patchName
applyPatch tmp patchName
let name = dropExtension . dropExtension $ takeFileName tarball
unpack = fromMaybe . error $ "gmpRules: expected suffix "
++ "-nodoc (found: " ++ name ++ ")."
libName = unpack $ stripSuffix "-nodoc" name
moveDirectory (tmp -/- libName) destPath
|
