Update Trac ticket URLs to point to GitLab
[ghc.git] / utils / gen-dll / Main.hs
1 {-# LANGUAGE Safe #-}
2 {-# LANGUAGE CPP #-}
3
4 {-
5 gen-dll is a replacement for dll-split which aims to solve a simple problem
6 during the building of stage2. The issue is that the PE image format only has
7 a 16-bit field for the symbol count. This means we can't have more than 2^16-1
8 symbols in a single PE file. See #5987.
9
10 gen-dll solves this issue by partitioning the object files in such a way that
11 a single dll never has more than the allowed amount of symbols. The general
12 workflow of gen-dll is:
13
14 1) use nm -g to dump the symbols defined in each object file, from this dump
15 we collect three key pieces information:
16 a) the object file the symbol belongs to
17 b) the symbol's kind (e.g data or function)
18 c) the symbol name.
19
20 2) If the amount of symbols is lower than the maximum, we're done and we'll
21 just link the entire list of symbols and move on.
22
23 If however we have too many symbols we'll partition the symbols using a
24 per object file granularity. This is because we can't split the content of
25 an object file. An oc belongs to one and only one image file.
26
27 3) Once we have the partitioning, we sub partition these into two groups for
28 each partition:
29 a) data
30 b) function
31
32 The reason for this is that data exports are directly accessed, whereas
33 functions generally go through a trampoline. The trampolines are there to
34 allow for extra functionality such as delay loading (if requested) and to
35 cover for memory model changes due to linking all the object code in on
36 PE image.
37
38 Data is usually accessed direct, so we don't want the trampoline otherwise
39 extern int foo;
40 would point to executable code instead of data.
41
42 4) Once we have everything correctly tagged, the partitions are dumped into a
43 module definition file (def). Each file is named <dll-name>-pt<num>.<ext>
44 which is also the partitioning scheme used for all other files including
45 the resulting dlls.
46
47 From the .def file we use libtool or genlib (when available) to generate
48 an import library. In this case we generate a GNU style import library
49 See Note [BFD import library].
50
51 These import libraries are used to break the cyclic dependencies that may
52 exist between the symbols due to the random partitioning. e.g. A may
53 require B, but A and B can be in different dlls. With the import libraries
54 we promise A that at runtime it'll have B, and vice versa. The Windows
55 runtime linker and loader will take care of breaking this cycle at runtime.
56
57 5) Once we have an import library for each partition, we start linking the
58 final dlls. if e.g. we have 3 dlls, linking dll 1 means passing import
59 libraries 2 and 3 as an argument to the linking of dll 1. This allows it
60 to find all symbols since PE image files can't have dangling symbols.
61
62 6) After creating the dlls the final step is to create one top level import
63 library that is named after the original dll that we were supposed to link.
64
65 To continue the 3 split example. say we were supposed to make libfoo.dll,
66 instead we created libfoo-pt1.dll, libfoo-pt2.dll and libfoo-pt3.dll.
67 Obviously using -lfoo would no longer locate the dlls.
68
69 This is solved by using import libraries again. GNU style import libraries
70 are just plain AR archives where each object file essentially contains
71 only 1 symbol and the dll in which to find this symbol.
72
73 A proper linker processes all the object files in this AR file (lld, ld and
74 ghci do this.) and so while genlib and libtool don't allow you to create
75 import libraries with multiple dll pointers, it is trivial to do.
76
77 We use ar to merge together the import libraries into a large complete one.
78 e.g. libfoo-pt1.dll.a, libfoo-pt2.dll.a and libfoo-pt3.dll.a are merged
79 into libfoo.dll.a. The name isn't coincidental. On Windows you don't link
80 directly against a dll, instead you link against an import library that
81 then tells you how to get to the dll functions.
82
83 In this case by creating a correctly named merged import library we solve
84 the -lfoo problem.
85
86 In the end we end up with libfoo-pt1.dll, libfoo-pt2.dll and libfoo-pt3.dll
87 along with libfoo.dll.a. To the rest of the pipeline the split is
88 completely transparent as -lfoo will just continue to work, and the linker
89 is responsible for populating the IAT (Import Address Table) with the
90 actual dlls we need.
91
92 This scheme is fully scalable and will not need manual maintenance or
93 intervention like dll-split needed. If we ever do switch to compiling using
94 Microsoft compilers, we need to use a custom tool to modify the PE import
95 libraries lib.exe creates. This is slightly more work but for now we can just
96 rely on the GNU import libraries.
97
98 If supported by the stage1 compiler, we'll create dll's which can be used as
99 SxS assemblies, but in order for us to do so, we have to give GHC some extra
100 information such as the stable abi name for the dll and the version of the
101 dll being created. This is purely a deployment thing and does not really
102 affect the workings of this tool.
103 -}
104 module Main(main) where
105
106 import Control.Arrow ((***))
107 import Control.Monad (when, forM_)
108 import Control.Exception (bracket)
109
110 import Data.Char (toLower, isSpace)
111 import Data.List (isPrefixOf, nub, sort, (\\))
112 import qualified Data.Map as M (Map(), alter, empty, toList)
113
114 import System.Environment (getArgs)
115 import System.Exit (ExitCode(..), exitWith)
116 import System.Directory (findFilesWith, getCurrentDirectory)
117 import System.FilePath (takeBaseName, takeDirectory, dropExtension, (<.>)
118 ,takeFileName)
119 import System.IO (hClose, hGetContents, withFile, IOMode(..), hPutStrLn, openFile)
120 import System.Process (proc, createProcess_, StdStream (..), CreateProcess(..)
121 ,waitForProcess)
122
123 import Foreign.C.Types (CInt(..), )
124 import Foreign.C.String (withCWString, peekCWString, CWString)
125 import Foreign.Ptr (Ptr)
126 import Foreign.Storable (peek)
127 import Foreign.Marshal.Array (peekArray)
128 import Foreign.Marshal.Alloc (alloca)
129
130 #if defined(i386_HOST_ARCH)
131 # define WINDOWS_CCONV stdcall
132 #elif defined(x86_64_HOST_ARCH)
133 # define WINDOWS_CCONV ccall
134 #else
135 # error Unknown mingw32 arch
136 #endif
137
138 -- Setup some standard program names.
139 nm :: FilePath
140 nm = NM_TOOL_BIN
141
142 libexe :: FilePath
143 libexe = LIB_TOOL_BIN
144
145 genlib :: FilePath
146 genlib = GENLIB_TOOL_BIN
147
148 ar :: FilePath
149 ar = AR_TOOL_BIN
150
151 -- Technically speaking the limit for the amount of symbols you can have in a
152 -- dll is 2^16-1, however Microsoft's lib.exe for some reason refuses to link
153 -- up to this amount. The reason is likely that it adds some extra symbols in
154 -- the generated dll, such as dllmain etc. So we reserve some space in the
155 -- symbol table to accomodate this. This number is just purely randomly chosen.
156 #define SYMBOL_PADDING 10
157
158 usage :: IO ()
159 usage = putStrLn $ unlines [ " -= Split a dll if required and perform the linking =- "
160 , ""
161 , " Usage: gen-dll <action>"
162 , ""
163 , " Where <action> is one of:"
164 , " link perform a real link of dll, "
165 , " arguments: dir distdir way flags libs objs out link_cmd delay name version"
166 ]
167
168 main :: IO ()
169 main = do
170 args <- getArgs
171 if null args
172 then usage
173 else case (head args) of
174 "link" -> let (dir:distdir:way:extra_flags:extra_libs:objs:output:
175 command:delayed:abi_name:abi_version:_) = tail args
176 in process_dll_link dir distdir way extra_flags extra_libs
177 objs output command delayed abi_name
178 abi_version
179 _ -> usage
180
181 type Symbol = String
182 type Symbols = [Symbol]
183 type SymbolType = Char
184 data Obj
185 = Obj { objName :: String
186 , objCount :: Int
187 , objItems :: [(SymbolType, Symbol)]
188 }
189 deriving Show
190 type Objs = [Obj]
191
192 -- | Create the final DLL by using the provided arguments
193 -- This also creates the resulting special import library.
194 process_dll_link :: String -- ^ dir
195 -> String -- ^ distdir
196 -> String -- ^ way
197 -> String -- ^ extra flags
198 -> String -- ^ extra libraries to link
199 -> String -- ^ object files to link
200 -> String -- ^ output filename
201 -> String -- ^ link command
202 -> String -- ^ create delay load import libs
203 -> String -- ^ SxS Name
204 -> String -- ^ SxS version
205 -> IO ()
206 process_dll_link _dir _distdir _way extra_flags extra_libs objs_files output
207 link_cmd delay_imp sxs_name sxs_version
208 = do let base = dropExtension output
209 -- We need to know how many symbols came from other static archives
210 -- So take the total number of symbols and remove those we know came
211 -- from the object files. Use this to lower the max amount of symbols.
212 --
213 -- This granularity is the best we can do without --print-map like info.
214 raw_exports <- execProg nm Nothing ["-g", "--defined-only", objs_files]
215 putStrLn $ "Processing symbols.."
216
217 let objs = collectObjs raw_exports
218 num_sym = foldr (\a b -> b + objCount a) 0 objs
219 exports = base <.> "lst"
220
221 putStrLn $ "Number of symbols in object files for " ++ output ++ ": " ++ show num_sym
222
223 _ <- withFile exports WriteMode $ \hExports ->
224 mapM_ (hPutStrLn hExports . unlines . map snd . objItems) objs
225
226 #if defined(GEN_SXS)
227 -- Side-by-Side assembly generation flags for GHC. Pass these along so the DLLs
228 -- get the proper manifests generated.
229 let sxs_opts = [ "-fgen-sxs-assembly"
230 , "-dylib-abi-name"
231 , show sxs_name
232 , "-dylib-abi-version"
233 , show sxs_version
234 ]
235 #else
236 let sxs_opts = []
237 #endif
238
239 -- Now check that the DLL doesn't have too many symbols. See trac #5987.
240 case num_sym > dll_max_symbols of
241 False -> do putStrLn $ "DLL " ++ output ++ " OK, no need to split."
242 let defFile = base <.> "def"
243 dll_import = base <.> "dll.a"
244
245 build_import_lib base (takeFileName output) defFile objs
246
247 _ <- execProg link_cmd Nothing
248 $ concat [[objs_files
249 ,extra_libs
250 ,extra_flags
251 ]
252 ,sxs_opts
253 ,["-fno-shared-implib"
254 ,"-optl-Wl,--retain-symbols-file=" ++ exports
255 ,"-o"
256 ,output
257 ]
258 ]
259
260 build_delay_import_lib defFile dll_import delay_imp
261
262 True -> do putStrLn $ "Too many symbols for a single DLL " ++ output
263 putStrLn "We'll have to split the dll..."
264 putStrLn $ "OK, we only have space for "
265 ++ show dll_max_symbols
266 ++ " symbols from object files when building "
267 ++ output
268
269 -- First split the dlls up by whole object files
270 -- To do this, we iterate over all object file and
271 -- generate a the partitions based on allowing a
272 -- maximum of $DLL_MAX_SYMBOLS in one DLL.
273 let spl_objs = groupObjs objs
274 n_spl_objs = length spl_objs
275 base' = base ++ "-pt"
276
277 mapM_ (\(n, _) -> putStrLn $ ">> DLL split at " ++ show n ++ " symbols.") spl_objs
278 putStrLn $ "OK, based on the amount of symbols we'll split the DLL into " ++ show n_spl_objs ++ " pieces."
279
280 -- Start off by creating the import libraries to break the
281 -- mutual dependency chain.
282 forM_ (zip [(1::Int)..] spl_objs) $ \(i, (n, o)) ->
283 do putStrLn $ "Processing file " ++ show i ++ " of "
284 ++ show n_spl_objs ++ " with " ++ show n
285 ++ " symbols."
286 let base_pt = base' ++ show i
287 file = base_pt <.> "def"
288 dll = base_pt <.> "dll"
289 lst = base_pt <.> "lst"
290
291 _ <- withFile lst WriteMode $ \hExports ->
292 mapM_ (hPutStrLn hExports . unlines . map snd . objItems) o
293
294 build_import_lib base_pt (takeFileName dll) file o
295
296 -- Now create the actual DLLs by using the import libraries
297 -- to break the mutual recursion.
298 forM_ (zip [1..] spl_objs) $ \(i, (n, _)) ->
299 do putStrLn $ "Creating DLL " ++ show i ++ " of "
300 ++ show n_spl_objs ++ " with " ++ show n
301 ++ " symbols."
302 let base_pt = base' ++ show i
303 file = base_pt <.> "def"
304 dll = base_pt <.> "dll"
305 lst = base_pt <.> "lst"
306 imp_lib = base_pt <.> "dll.a"
307 indexes = [1..(length spl_objs)]\\[i]
308 libs = map (\ix -> (base' ++ show ix) <.> "dll.a") indexes
309
310 _ <- execProg link_cmd Nothing
311 $ concat [[objs_files
312 ,extra_libs
313 ,extra_flags
314 ,file
315 ]
316 ,libs
317 ,sxs_opts
318 ,["-fno-shared-implib"
319 ,"-optl-Wl,--retain-symbols-file=" ++ lst
320 ,"-o"
321 ,dll
322 ]
323 ]
324
325 -- build_delay_import_lib file imp_lib delay_imp
326 putStrLn $ "Created " ++ dll ++ "."
327
328 -- And finally, merge the individual import libraries into
329 -- one with the name of the original library we were
330 -- supposed to make. This means that nothing has to really
331 -- know how we split up the DLLs, for everything else it'so
332 -- as if it's still one large assembly.
333 create_merged_archive base base' (length spl_objs)
334
335
336 collectObjs :: [String] -> Objs
337 collectObjs = map snd . M.toList . foldr collectObjs' M.empty
338
339 collectObjs' :: String -> M.Map String Obj -> M.Map String Obj
340 collectObjs' [] m = m
341 collectObjs' str_in m
342 = let clean = dropWhile isSpace
343 str = clean str_in
344 (file, rest) = ((takeWhile (/=':') . clean) *** clean) $
345 break isSpace str
346 (typ , sym ) = (id *** clean) $ break isSpace rest
347 obj = Obj { objName = file
348 , objCount = 1
349 , objItems = [(head typ, sym)]
350 }
351 upd value
352 = if length typ /= 1
353 then value
354 else Just $ maybe obj
355 (\o -> o { objCount = objCount o + 1
356 , objItems = (head typ, sym) : objItems o
357 })
358 value
359 in M.alter upd file m
360
361 -- Split a list of objects into globals and functions
362 splitObjs :: Objs -> (Symbols, Symbols)
363 splitObjs [] = ([], [])
364 splitObjs (y:ys) = group_ (objItems y) (splitObjs ys)
365 where globals = "DdGgrRSsbBC"
366 group_ :: [(Char, Symbol)] -> (Symbols, Symbols) -> (Symbols, Symbols)
367 group_ [] x = x
368 group_ (x:xs) (g, f) | fst x `elem` globals = group_ xs (snd x:g, f)
369 | otherwise = group_ xs (g, snd x:f)
370
371 -- Determine how to split the objects up.
372 groupObjs :: Objs -> [(Int, Objs)]
373 groupObjs = binObjs 0 []
374 where binObjs :: Int -> Objs -> Objs -> [(Int, Objs)]
375 binObjs n l [] = [(n, l)]
376 binObjs n l (o:os)
377 = let nx = objCount o
378 n' = n + nx
379 in if n' > dll_max_symbols
380 then (n, l) : binObjs 0 [] os
381 else binObjs n' (o:l) os
382
383 -- Maximum number of symbols to allow into
384 -- one DLL. This is the split factor used.
385 dll_max_symbols :: Int
386 dll_max_symbols = 65535 - SYMBOL_PADDING -- Some padding for required symbols.
387
388 isTrue :: String -> Bool
389 isTrue s = let s' = map toLower s
390 in case () of
391 () | s' == "yes" -> True
392 | s' == "no" -> False
393 | otherwise -> error $ "Expected yes/no but got '" ++ s ++ "'"
394
395 foreign import WINDOWS_CCONV unsafe "Shellapi.h CommandLineToArgvW"
396 c_CommandLineToArgvW :: CWString -> Ptr CInt -> IO (Ptr CWString)
397
398 foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"
399 localFree :: Ptr a -> IO (Ptr a)
400
401 mkArgs :: String -> IO [String]
402 mkArgs [] = return []
403 mkArgs arg =
404 do withCWString arg $ \c_arg -> do
405 alloca $ \c_size -> do
406 res <- c_CommandLineToArgvW c_arg c_size
407 size <- peek c_size
408 args <- peekArray (fromIntegral size) res
409 values <- mapM peekCWString args
410 _ <- localFree res
411 return values
412
413 execProg :: String -> Maybe FilePath -> [String] -> IO [String]
414 execProg prog m_stdin args =
415 do args' <- fmap concat $ mapM mkArgs args
416 prog' <- mkArgs prog
417 let full@(c_prog:c_args) = prog' ++ args'
418 -- print the commands we're executing for debugging and transparency
419 putStrLn $ unwords $ full ++ [maybe "" ("< " ++) m_stdin]
420 cwdir <- getCurrentDirectory
421 let cp = (proc c_prog c_args)
422 { std_out = CreatePipe, cwd = Just cwdir }
423 cp' <- case m_stdin of
424 Nothing -> return cp
425 Just path -> do h <- openFile path ReadMode
426 return cp{ std_in = UseHandle h}
427 bracket
428 (createProcess_ ("execProg: " ++ prog) cp')
429 (\(_, Just hout, _, ph) -> do
430 hClose hout
431 code <- waitForProcess ph
432 case std_in cp' of
433 UseHandle h -> hClose h
434 _ -> return ()
435 case code of
436 ExitFailure _ -> exitWith code
437 ExitSuccess -> return ())
438 (\(_, Just hout, _, _) -> do
439 results <- hGetContents hout
440 length results `seq` return $ lines results)
441
442 -- | Mingw-w64's genlib.exe is generally a few order of magnitudes faster than
443 -- libtool which is BFD based. So we prefer it, but it's not standard so
444 -- support both. We're talking a difference of 45 minutes in build time here.
445 execLibTool :: String -> String -> IO [String]
446 execLibTool input_def output_lib =
447 do if HAS_GENLIB
448 then execProg genlib Nothing [input_def, "-o", output_lib]
449 else execProg libexe Nothing ["-d", input_def, "-l", output_lib]
450
451 -- Builds a delay import lib at the very end which is used to
452 -- be able to delay the picking of a DLL on Windows.
453 -- This function is called always and decided internally
454 -- what to do.
455 build_delay_import_lib :: String -- ^ input def file
456 -> String -- ^ ouput import delayed import lib
457 -> String -- ^ flag to indicate if delay import
458 -- lib should be created
459 -> IO ()
460 build_delay_import_lib input_def output_lib create_delayed
461 = when (isTrue create_delayed) $
462 execLibTool input_def output_lib >> return ()
463
464 -- Build a normal import library from the object file definitions
465 build_import_lib :: FilePath -> FilePath -> FilePath -> Objs -> IO ()
466 build_import_lib base dll_name defFile objs
467 = do -- Create a def file hiding symbols not in original object files
468 -- because --export-all is re-exporting things from static libs
469 -- we need to separate out data from functions. So first create two temporaries
470 let (globals, functions) = splitObjs objs
471
472 -- This split is important because for DATA entries the compiler should not generate
473 -- a trampoline since CONTS DATA is directly referenced and not executed. This is not very
474 -- important for mingw-w64 which would generate both the trampoline and direct referecne
475 -- by default, but for libtool is it and even for mingw-w64 we can trim the output.
476 _ <- withFile defFile WriteMode $ \hDef -> do
477 hPutStrLn hDef $ unlines $ ["LIBRARY " ++ show dll_name
478 ,"EXPORTS"
479 ]
480 mapM_ (\v -> hPutStrLn hDef $ " " ++ show v ++ " DATA") globals
481 mapM_ (\v -> hPutStrLn hDef $ " " ++ show v ) functions
482
483 let dll_import = base <.> "dll.a"
484 _ <- execLibTool defFile dll_import
485 return ()
486
487 -- Do some cleanup and create merged lib.
488 -- Because we have no split the DLL we need
489 -- to provide a way for the linker to know about the split
490 -- DLL. Also the compile was supposed to produce a DLL
491 -- foo.dll and import library foo.lib. However we've actually
492 -- produced foo-pt1.dll, foo-pt2.dll etc. What we don't want is to have
493 -- To somehow convey back to the compiler that we split the DLL in x pieces
494 -- as this would require a lot of changes.
495 --
496 -- Instead we produce a merged import library which contains the union of
497 -- all the import libraries produced. This works because import libraries contain
498 -- only .idata section which point to the right dlls. So LD will do the right thing.
499 -- And this means we don't have to do any special handling for the rest of the pipeline.
500 create_merged_archive :: FilePath -> String -> Int -> IO ()
501 create_merged_archive base prefix count
502 = do let ar_script = base <.> "mri"
503 imp_lib = base <.> "dll.a"
504 imp_libs = map (\i -> prefix ++ show i <.> "dll.a") [1..count]
505 let script = [ "create " ++ imp_lib ] ++
506 map ("addlib " ++) imp_libs ++
507 [ "save", "end" ]
508 writeFile ar_script (unlines script)
509 _ <- execProg ar (Just ar_script) ["-M"]
510 return ()