Refactor Libffi and RTS rules
[ghc.git] / hadrian / src / Rules / Rts.hs
1 module Rules.Rts (rtsRules, needRtsLibffiTargets, needRtsSymLinks) where
2
3 import Packages (rts, rtsBuildPath, libffiBuildPath, libffiLibraryName, rtsContext)
4 import Rules.Libffi
5 import Hadrian.Utilities
6 import Settings.Builders.Common
7
8 -- | This rule has priority 3 to override the general rule for generating shared
9 -- library files (see Rules.Library.libraryRules).
10 rtsRules :: Rules ()
11 rtsRules = priority 3 $ do
12 -- Dynamic RTS library files need symlinks without the dummy version number.
13 -- This is for backwards compatibility (the old make build system omitted the
14 -- dummy version number).
15 root <- buildRootRules
16 [ root -/- "//libHSrts_*-ghc*.so",
17 root -/- "//libHSrts_*-ghc*.dylib",
18 root -/- "//libHSrts-ghc*.so",
19 root -/- "//libHSrts-ghc*.dylib"]
20 |%> \ rtsLibFilePath' -> createFileLinkUntracked
21 (addRtsDummyVersion $ takeFileName rtsLibFilePath')
22 rtsLibFilePath'
23
24 -- Libffi
25 forM_ [Stage1 ..] $ \ stage -> do
26 let buildPath = root -/- buildDir (rtsContext stage)
27
28 -- Header files
29 (fmap (buildPath -/-) libffiHeaderFiles) &%> const (copyLibffiHeaders stage)
30
31 -- Static libraries.
32 buildPath -/- "libCffi*.a" %> copyLibffiStatic stage
33
34 -- Dynamic libraries
35 buildPath -/- "libffi*.dylib*" %> copyLibffiDynamicUnix stage ".dylib"
36 buildPath -/- "libffi*.so*" %> copyLibffiDynamicUnix stage ".so"
37 buildPath -/- "libffi*.dll*" %> copyLibffiDynamicWin stage
38
39 withLibffi :: Stage -> (FilePath -> FilePath -> Action a) -> Action a
40 withLibffi stage action = needLibffi stage
41 >> (join $ action <$> libffiBuildPath stage
42 <*> rtsBuildPath stage)
43
44 -- | Copy all header files wither from the system libffi or from the libffi
45 -- build dir to the rts build dir.
46 copyLibffiHeaders :: Stage -> Action ()
47 copyLibffiHeaders stage = do
48 rtsPath <- rtsBuildPath stage
49 useSystemFfi <- flag UseSystemFfi
50 (fromStr, headers) <- if useSystemFfi
51 then ("system",) <$> libffiSystemHeaders
52 else needLibffi stage
53 >> ("custom",) <$> libffiHeaders stage
54 forM_ headers $ \ header -> copyFile header
55 (rtsPath -/- takeFileName header)
56 putSuccess $ "| Successfully copied " ++ fromStr ++ " FFI library header "
57 ++ "files to RTS build directory."
58
59 -- | Copy a static library file from the libffi build dir to the rts build dir.
60 copyLibffiStatic :: Stage -> FilePath -> Action ()
61 copyLibffiStatic stage target = withLibffi stage $ \ libffiPath _ -> do
62 -- Copy the vanilla library, and symlink the rest to it.
63 vanillaLibFile <- rtsLibffiLibrary stage vanilla
64 if target == vanillaLibFile
65 then copyFile' (libffiPath -/- libffiLibrary) target
66 else createFileLink (takeFileName vanillaLibFile) target
67
68
69 -- | Copy a dynamic library file from the libffi build dir to the rts build dir.
70 copyLibffiDynamicUnix :: Stage -> String -> FilePath -> Action ()
71 copyLibffiDynamicUnix stage libSuf target = do
72 needLibffi stage
73 dynLibs <- askLibffilDynLibs stage
74
75 -- If no version number suffix, then copy else just symlink.
76 let versionlessSourceFilePath = fromMaybe
77 (error $ "Needed " ++ show target ++ " which is not any of " ++
78 "libffi's built shared libraries: " ++ show dynLibs)
79 (find (libSuf `isSuffixOf`) dynLibs)
80 let versionlessSourceFileName = takeFileName versionlessSourceFilePath
81 if versionlessSourceFileName == takeFileName target
82 then do
83 copyFile' versionlessSourceFilePath target
84
85 -- On OSX the dylib's id must be updated to a relative path.
86 osx <- osxHost
87 when osx $ cmd
88 [ "install_name_tool"
89 , "-id", "@rpath/" ++ takeFileName target
90 , target
91 ]
92 else createFileLink versionlessSourceFileName target
93
94 -- | Copy a dynamic library file from the libffi build dir to the rts build dir.
95 copyLibffiDynamicWin :: Stage -> FilePath -> Action ()
96 copyLibffiDynamicWin stage target = do
97 needLibffi stage
98 dynLibs <- askLibffilDynLibs stage
99 let source = fromMaybe
100 (error $ "Needed " ++ show target ++ " which is not any of " ++
101 "libffi's built shared libraries: " ++ show dynLibs)
102 (find (\ lib -> takeFileName target == takeFileName lib) dynLibs)
103 copyFile' source target
104
105 rtsLibffiLibrary :: Stage -> Way -> Action FilePath
106 rtsLibffiLibrary stage way = do
107 name <- libffiLibraryName
108 suf <- libsuf stage way
109 rtsPath <- rtsBuildPath stage
110 return $ rtsPath -/- "lib" ++ name ++ suf
111
112 -- | Get the libffi files bundled with the rts (header and library files).
113 -- Unless using the system libffi, this needs the libffi library. It must be
114 -- built before the targets can be calcuulated.
115 needRtsLibffiTargets :: Stage -> Action [FilePath]
116 needRtsLibffiTargets stage = do
117 rtsPath <- rtsBuildPath stage
118 useSystemFfi <- flag UseSystemFfi
119
120 -- Header files (in the rts build dir).
121 let headers = fmap (rtsPath -/-) libffiHeaderFiles
122
123 if useSystemFfi
124 then return headers
125 else do
126 -- Need Libffi
127 -- This returns the dynamic library files (in the Libffi build dir).
128 needLibffi stage
129 dynLibffSource <- askLibffilDynLibs stage
130
131 -- Header files (in the rts build dir).
132 let headers = fmap (rtsPath -/-) libffiHeaderFiles
133
134 -- Dynamic library files (in the rts build dir).
135 let dynLibffis = fmap (\ lib -> rtsPath -/- takeFileName lib)
136 dynLibffSource
137
138 -- Static Libffi files (in the rts build dir).
139 staticLibffis <- do
140 ways <- interpretInContext (stageContext stage)
141 (getLibraryWays <> getRtsWays)
142 let staticWays = filter (not . wayUnit Dynamic) ways
143 mapM (rtsLibffiLibrary stage) staticWays
144
145 return $ concat [ headers, dynLibffis, staticLibffis ]
146
147 -- Need symlinks generated by rtsRules.
148 needRtsSymLinks :: Stage -> [Way] -> Action ()
149 needRtsSymLinks stage rtsWays
150 = forM_ (filter (wayUnit Dynamic) rtsWays) $ \ way -> do
151 let ctx = Context stage rts way
152 libPath <- libPath ctx
153 distDir <- distDir stage
154 rtsLibFile <- takeFileName <$> pkgLibraryFile ctx
155 need [removeRtsDummyVersion (libPath </> distDir </> rtsLibFile)]
156
157 prefix, versionlessPrefix :: String
158 versionlessPrefix = "libHSrts"
159 prefix = versionlessPrefix ++ "-1.0"
160
161 -- removeRtsDummyVersion "a/libHSrts-1.0-ghc1.2.3.4.so"
162 -- == "a/libHSrts-ghc1.2.3.4.so"
163 removeRtsDummyVersion :: FilePath -> FilePath
164 removeRtsDummyVersion = replaceLibFilePrefix prefix versionlessPrefix
165
166 -- addRtsDummyVersion "a/libHSrts-ghc1.2.3.4.so"
167 -- == "a/libHSrts-1.0-ghc1.2.3.4.so"
168 addRtsDummyVersion :: FilePath -> FilePath
169 addRtsDummyVersion = replaceLibFilePrefix versionlessPrefix prefix
170
171 replaceLibFilePrefix :: String -> String -> FilePath -> FilePath
172 replaceLibFilePrefix oldPrefix newPrefix oldFilePath = let
173 oldFileName = takeFileName oldFilePath
174 newFileName = maybe
175 (error $ "Expected RTS library file to start with " ++ oldPrefix)
176 (newPrefix ++)
177 (stripPrefix oldPrefix oldFileName)
178 in replaceFileName oldFilePath newFileName