Re-order preprocessor args to agree with User Guide (fixes #8602)
[ghc.git] / compiler / main / SysTools.lhs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2001-2003
4 --
5 -- Access to system tools: gcc, cp, rm etc
6 --
7 -----------------------------------------------------------------------------
8
9 \begin{code}
10 module SysTools (
11         -- Initialisation
12         initSysTools,
13
14         -- Interface to system tools
15         runUnlit, runCpp, runCc, -- [Option] -> IO ()
16         runPp,                   -- [Option] -> IO ()
17         runSplit,                -- [Option] -> IO ()
18         runAs, runLink, runLibtool, -- [Option] -> IO ()
19         runMkDLL,
20         runWindres,
21         runLlvmOpt,
22         runLlvmLlc,
23         runClang,
24         figureLlvmVersion,
25         readElfSection,
26
27         getLinkerInfo,
28
29         linkDynLib,
30
31         askCc,
32
33         touch,                  -- String -> String -> IO ()
34         copy,
35         copyWithHeader,
36
37         -- Temporary-file management
38         setTmpDir,
39         newTempName,
40         cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
41         addFilesToClean,
42
43         Option(..)
44
45  ) where
46
47 #include "HsVersions.h"
48
49 import DriverPhases
50 import Module
51 import Packages
52 import Config
53 import Outputable
54 import ErrUtils
55 import Panic
56 import Platform
57 import Util
58 import DynFlags
59 import Exception
60
61 import Data.IORef
62 import Control.Monad
63 import System.Exit
64 import System.Environment
65 import System.FilePath
66 import System.IO
67 import System.IO.Error as IO
68 import System.Directory
69 import Data.Char
70 import Data.List
71 import qualified Data.Map as Map
72 import Text.ParserCombinators.ReadP hiding (char)
73 import qualified Text.ParserCombinators.ReadP as R
74
75 #ifndef mingw32_HOST_OS
76 import qualified System.Posix.Internals
77 #else /* Must be Win32 */
78 import Foreign
79 import Foreign.C.String
80 #endif
81
82 import System.Process
83 import Control.Concurrent
84 import FastString
85 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
86
87 #ifdef mingw32_HOST_OS
88 # if defined(i386_HOST_ARCH)
89 #  define WINDOWS_CCONV stdcall
90 # elif defined(x86_64_HOST_ARCH)
91 #  define WINDOWS_CCONV ccall
92 # else
93 #  error Unknown mingw32 arch
94 # endif
95 #endif
96 \end{code}
97
98 How GHC finds its files
99 ~~~~~~~~~~~~~~~~~~~~~~~
100
101 [Note topdir]
102
103 GHC needs various support files (library packages, RTS etc), plus
104 various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,
105 the root of GHC's support files
106
107 On Unix:
108   - ghc always has a shell wrapper that passes a -B<dir> option
109
110 On Windows:
111   - ghc never has a shell wrapper.
112   - we can find the location of the ghc binary, which is
113         $topdir/bin/<something>.exe
114     where <something> may be "ghc", "ghc-stage2", or similar
115   - we strip off the "bin/<something>.exe" to leave $topdir.
116
117 from topdir we can find package.conf, ghc-asm, etc.
118
119
120 SysTools.initSysProgs figures out exactly where all the auxiliary programs
121 are, and initialises mutable variables to make it easy to call them.
122 To to this, it makes use of definitions in Config.hs, which is a Haskell
123 file containing variables whose value is figured out by the build system.
124
125 Config.hs contains two sorts of things
126
127   cGCC,         The *names* of the programs
128   cCPP            e.g.  cGCC = gcc
129   cUNLIT                cCPP = gcc -E
130   etc           They do *not* include paths
131
132
133   cUNLIT_DIR   The *path* to the directory containing unlit, split etc
134   cSPLIT_DIR   *relative* to the root of the build tree,
135                    for use when running *in-place* in a build tree (only)
136
137
138
139 ---------------------------------------------
140 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
141
142 Another hair-brained scheme for simplifying the current tool location
143 nightmare in GHC: Simon originally suggested using another
144 configuration file along the lines of GCC's specs file - which is fine
145 except that it means adding code to read yet another configuration
146 file.  What I didn't notice is that the current package.conf is
147 general enough to do this:
148
149 Package
150     {name = "tools",    import_dirs = [],  source_dirs = [],
151      library_dirs = [], hs_libraries = [], extra_libraries = [],
152      include_dirs = [], c_includes = [],   package_deps = [],
153      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
154      extra_cc_opts = [], extra_ld_opts = []}
155
156 Which would have the advantage that we get to collect together in one
157 place the path-specific package stuff with the path-specific tool
158 stuff.
159                 End of NOTES
160 ---------------------------------------------
161
162 %************************************************************************
163 %*                                                                      *
164 \subsection{Initialisation}
165 %*                                                                      *
166 %************************************************************************
167
168 \begin{code}
169 initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
170              -> IO Settings     -- Set all the mutable variables above, holding
171                                 --      (a) the system programs
172                                 --      (b) the package-config file
173                                 --      (c) the GHC usage message
174 initSysTools mbMinusB
175   = do top_dir <- findTopDir mbMinusB
176              -- see [Note topdir]
177              -- NB: top_dir is assumed to be in standard Unix
178              -- format, '/' separated
179
180        let settingsFile = top_dir </> "settings"
181            platformConstantsFile = top_dir </> "platformConstants"
182            installed :: FilePath -> FilePath
183            installed file = top_dir </> file
184
185        settingsStr <- readFile settingsFile
186        platformConstantsStr <- readFile platformConstantsFile
187        mySettings <- case maybeReadFuzzy settingsStr of
188                      Just s ->
189                          return s
190                      Nothing ->
191                          pgmError ("Can't parse " ++ show settingsFile)
192        platformConstants <- case maybeReadFuzzy platformConstantsStr of
193                             Just s ->
194                                 return s
195                             Nothing ->
196                                 pgmError ("Can't parse " ++
197                                           show platformConstantsFile)
198        let getSetting key = case lookup key mySettings of
199                             Just xs ->
200                                 return $ case stripPrefix "$topdir" xs of
201                                          Just [] ->
202                                              top_dir
203                                          Just xs'@(c:_)
204                                           | isPathSeparator c ->
205                                              top_dir ++ xs'
206                                          _ ->
207                                              xs
208                             Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
209            getBooleanSetting key = case lookup key mySettings of
210                                    Just "YES" -> return True
211                                    Just "NO" -> return False
212                                    Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)
213                                    Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
214            readSetting key = case lookup key mySettings of
215                              Just xs ->
216                                  case maybeRead xs of
217                                  Just v -> return v
218                                  Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
219                              Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
220        targetArch <- readSetting "target arch"
221        targetOS <- readSetting "target os"
222        targetWordSize <- readSetting "target word size"
223        targetUnregisterised <- getBooleanSetting "Unregisterised"
224        targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
225        targetHasIdentDirective <- readSetting "target has .ident directive"
226        targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
227        myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
228        -- On Windows, mingw is distributed with GHC,
229        -- so we look in TopDir/../mingw/bin
230        -- It would perhaps be nice to be able to override this
231        -- with the settings file, but it would be a little fiddly
232        -- to make that possible, so for now you can't.
233        gcc_prog <- getSetting "C compiler command"
234        gcc_args_str <- getSetting "C compiler flags"
235        let unreg_gcc_args = if targetUnregisterised
236                             then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
237                             else []
238            -- TABLES_NEXT_TO_CODE affects the info table layout.
239            tntc_gcc_args
240             | mkTablesNextToCode targetUnregisterised
241                = ["-DTABLES_NEXT_TO_CODE"]
242             | otherwise = []
243            gcc_args = map Option (words gcc_args_str
244                                ++ unreg_gcc_args
245                                ++ tntc_gcc_args)
246        ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
247        ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
248        ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"
249        ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
250        perl_path <- getSetting "perl command"
251
252        let pkgconfig_path = installed "package.conf.d"
253            ghc_usage_msg_path  = installed "ghc-usage.txt"
254            ghci_usage_msg_path = installed "ghci-usage.txt"
255
256              -- For all systems, unlit, split, mangle are GHC utilities
257              -- architecture-specific stuff is done when building Config.hs
258            unlit_path = installed cGHC_UNLIT_PGM
259
260              -- split is a Perl script
261            split_script  = installed cGHC_SPLIT_PGM
262
263        windres_path <- getSetting "windres command"
264        libtool_path <- getSetting "libtool command"
265
266        tmpdir <- getTemporaryDirectory
267
268        touch_path <- getSetting "touch command"
269
270        let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
271            -- a call to Perl to get the invocation of split.
272            -- On Unix, scripts are invoked using the '#!' method.  Binary
273            -- installations of GHC on Unix place the correct line on the
274            -- front of the script at installation time, so we don't want
275            -- to wire-in our knowledge of $(PERL) on the host system here.
276            (split_prog,  split_args)
277              | isWindowsHost = (perl_path,    [Option split_script])
278              | otherwise     = (split_script, [])
279        mkdll_prog <- getSetting "dllwrap command"
280        let mkdll_args = []
281
282        -- cpp is derived from gcc on all platforms
283        -- HACK, see setPgmP below. We keep 'words' here to remember to fix
284        -- Config.hs one day.
285        let cpp_prog  = gcc_prog
286            cpp_args  = Option "-E"
287                      : map Option (words cRAWCPP_FLAGS)
288                     ++ gcc_args
289
290        -- Other things being equal, as and ld are simply gcc
291        gcc_link_args_str <- getSetting "C compiler link flags"
292        let   as_prog  = gcc_prog
293              as_args  = gcc_args
294              ld_prog  = gcc_prog
295              ld_args  = gcc_args ++ map Option (words gcc_link_args_str)
296
297        -- We just assume on command line
298        lc_prog <- getSetting "LLVM llc command"
299        lo_prog <- getSetting "LLVM opt command"
300
301        let platform = Platform {
302                           platformArch = targetArch,
303                           platformOS   = targetOS,
304                           platformWordSize = targetWordSize,
305                           platformUnregisterised = targetUnregisterised,
306                           platformHasGnuNonexecStack = targetHasGnuNonexecStack,
307                           platformHasIdentDirective = targetHasIdentDirective,
308                           platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
309                       }
310
311        return $ Settings {
312                     sTargetPlatform = platform,
313                     sTmpDir         = normalise tmpdir,
314                     sGhcUsagePath   = ghc_usage_msg_path,
315                     sGhciUsagePath  = ghci_usage_msg_path,
316                     sTopDir         = top_dir,
317                     sRawSettings    = mySettings,
318                     sExtraGccViaCFlags = words myExtraGccViaCFlags,
319                     sSystemPackageConfig = pkgconfig_path,
320                     sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
321                     sLdSupportsBuildId       = ldSupportsBuildId,
322                     sLdSupportsFilelist      = ldSupportsFilelist,
323                     sLdIsGnuLd               = ldIsGnuLd,
324                     sPgm_L   = unlit_path,
325                     sPgm_P   = (cpp_prog, cpp_args),
326                     sPgm_F   = "",
327                     sPgm_c   = (gcc_prog, gcc_args),
328                     sPgm_s   = (split_prog,split_args),
329                     sPgm_a   = (as_prog, as_args),
330                     sPgm_l   = (ld_prog, ld_args),
331                     sPgm_dll = (mkdll_prog,mkdll_args),
332                     sPgm_T   = touch_path,
333                     sPgm_sysman  = top_dir ++ "/ghc/rts/parallel/SysMan",
334                     sPgm_windres = windres_path,
335                     sPgm_libtool = libtool_path,
336                     sPgm_lo  = (lo_prog,[]),
337                     sPgm_lc  = (lc_prog,[]),
338                     -- Hans: this isn't right in general, but you can
339                     -- elaborate it in the same way as the others
340                     sOpt_L       = [],
341                     sOpt_P       = [],
342                     sOpt_F       = [],
343                     sOpt_c       = [],
344                     sOpt_a       = [],
345                     sOpt_l       = [],
346                     sOpt_windres = [],
347                     sOpt_lo      = [],
348                     sOpt_lc      = [],
349                     sPlatformConstants = platformConstants
350              }
351 \end{code}
352
353 \begin{code}
354 -- returns a Unix-format path (relying on getBaseDir to do so too)
355 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
356            -> IO String    -- TopDir (in Unix format '/' separated)
357 findTopDir (Just minusb) = return (normalise minusb)
358 findTopDir Nothing
359     = do -- Get directory of executable
360          maybe_exec_dir <- getBaseDir
361          case maybe_exec_dir of
362              -- "Just" on Windows, "Nothing" on unix
363              Nothing  -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
364              Just dir -> return dir
365 \end{code}
366
367
368 %************************************************************************
369 %*                                                                      *
370 \subsection{Running an external program}
371 %*                                                                      *
372 %************************************************************************
373
374
375 \begin{code}
376 runUnlit :: DynFlags -> [Option] -> IO ()
377 runUnlit dflags args = do
378   let prog = pgm_L dflags
379       opts = getOpts dflags opt_L
380   runSomething dflags "Literate pre-processor" prog
381                (map Option opts ++ args)
382
383 runCpp :: DynFlags -> [Option] -> IO ()
384 runCpp dflags args =   do
385   let (p,args0) = pgm_P dflags
386       args1 = map Option (getOpts dflags opt_P)
387       args2 = if gopt Opt_WarnIsError dflags
388                  then [Option "-Werror"]
389                  else []
390   mb_env <- getGccEnv args2
391   runSomethingFiltered dflags id  "C pre-processor" p
392                        (args0 ++ args1 ++ args2 ++ args) mb_env
393
394 runPp :: DynFlags -> [Option] -> IO ()
395 runPp dflags args =   do
396   let prog = pgm_F dflags
397       opts = map Option (getOpts dflags opt_F)
398   runSomething dflags "Haskell pre-processor" prog (args ++ opts)
399
400 runCc :: DynFlags -> [Option] -> IO ()
401 runCc dflags args =   do
402   let (p,args0) = pgm_c dflags
403       args1 = map Option (getOpts dflags opt_c)
404       args2 = args0 ++ args1 ++ args
405   mb_env <- getGccEnv args2
406   runSomethingFiltered dflags cc_filter "C Compiler" p args2 mb_env
407  where
408   -- discard some harmless warnings from gcc that we can't turn off
409   cc_filter = unlines . doFilter . lines
410
411   {-
412   gcc gives warnings in chunks like so:
413       In file included from /foo/bar/baz.h:11,
414                        from /foo/bar/baz2.h:22,
415                        from wibble.c:33:
416       /foo/flibble:14: global register variable ...
417       /foo/flibble:15: warning: call-clobbered r...
418   We break it up into its chunks, remove any call-clobbered register
419   warnings from each chunk, and then delete any chunks that we have
420   emptied of warnings.
421   -}
422   doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
423   -- We can't assume that the output will start with an "In file inc..."
424   -- line, so we start off expecting a list of warnings rather than a
425   -- location stack.
426   chunkWarnings :: [String] -- The location stack to use for the next
427                             -- list of warnings
428                 -> [String] -- The remaining lines to look at
429                 -> [([String], [String])]
430   chunkWarnings loc_stack [] = [(loc_stack, [])]
431   chunkWarnings loc_stack xs
432       = case break loc_stack_start xs of
433         (warnings, lss:xs') ->
434             case span loc_start_continuation xs' of
435             (lsc, xs'') ->
436                 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
437         _ -> [(loc_stack, xs)]
438
439   filterWarnings :: [([String], [String])] -> [([String], [String])]
440   filterWarnings [] = []
441   -- If the warnings are already empty then we are probably doing
442   -- something wrong, so don't delete anything
443   filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
444   filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
445                                        [] -> filterWarnings zs
446                                        ys' -> (xs, ys') : filterWarnings zs
447
448   unChunkWarnings :: [([String], [String])] -> [String]
449   unChunkWarnings [] = []
450   unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
451
452   loc_stack_start        s = "In file included from " `isPrefixOf` s
453   loc_start_continuation s = "                 from " `isPrefixOf` s
454   wantedWarning w
455    | "warning: call-clobbered register used" `isContainedIn` w = False
456    | otherwise = True
457
458 isContainedIn :: String -> String -> Bool
459 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
460
461 askCc :: DynFlags -> [Option] -> IO String
462 askCc dflags args = do
463   let (p,args0) = pgm_c dflags
464       args1 = map Option (getOpts dflags opt_c)
465       args2 = args0 ++ args1 ++ args
466   mb_env <- getGccEnv args2
467   runSomethingWith dflags "gcc" p args2 $ \real_args ->
468     readCreateProcess (proc p real_args){ env = mb_env }
469
470 -- Version of System.Process.readProcessWithExitCode that takes an environment
471 readCreateProcess
472     :: CreateProcess
473     -> IO (ExitCode, String)    -- ^ stdout
474 readCreateProcess proc = do
475     (_, Just outh, _, pid) <-
476         createProcess proc{ std_out = CreatePipe }
477
478     -- fork off a thread to start consuming the output
479     output  <- hGetContents outh
480     outMVar <- newEmptyMVar
481     _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
482
483     -- wait on the output
484     takeMVar outMVar
485     hClose outh
486
487     -- wait on the process
488     ex <- waitForProcess pid
489
490     return (ex, output)
491
492
493 -- If the -B<dir> option is set, add <dir> to PATH.  This works around
494 -- a bug in gcc on Windows Vista where it can't find its auxiliary
495 -- binaries (see bug #1110).
496 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
497 getGccEnv opts =
498   if null b_dirs
499      then return Nothing
500      else do env <- getEnvironment
501              return (Just (map mangle_path env))
502  where
503   (b_dirs, _) = partitionWith get_b_opt opts
504
505   get_b_opt (Option ('-':'B':dir)) = Left dir
506   get_b_opt other = Right other
507
508   mangle_path (path,paths) | map toUpper path == "PATH"
509         = (path, '\"' : head b_dirs ++ "\";" ++ paths)
510   mangle_path other = other
511
512 runSplit :: DynFlags -> [Option] -> IO ()
513 runSplit dflags args = do
514   let (p,args0) = pgm_s dflags
515   runSomething dflags "Splitter" p (args0++args)
516
517 runAs :: DynFlags -> [Option] -> IO ()
518 runAs dflags args = do
519   let (p,args0) = pgm_a dflags
520       args1 = map Option (getOpts dflags opt_a)
521       args2 = args0 ++ args1 ++ args
522   mb_env <- getGccEnv args2
523   runSomethingFiltered dflags id "Assembler" p args2 mb_env
524
525 -- | Run the LLVM Optimiser
526 runLlvmOpt :: DynFlags -> [Option] -> IO ()
527 runLlvmOpt dflags args = do
528   let (p,args0) = pgm_lo dflags
529       args1 = map Option (getOpts dflags opt_lo)
530   runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args)
531
532 -- | Run the LLVM Compiler
533 runLlvmLlc :: DynFlags -> [Option] -> IO ()
534 runLlvmLlc dflags args = do
535   let (p,args0) = pgm_lc dflags
536       args1 = map Option (getOpts dflags opt_lc)
537   runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
538
539 -- | Run the clang compiler (used as an assembler for the LLVM
540 -- backend on OS X as LLVM doesn't support the OS X system
541 -- assembler)
542 runClang :: DynFlags -> [Option] -> IO ()
543 runClang dflags args = do
544   -- we simply assume its available on the PATH
545   let clang = "clang"
546       -- be careful what options we call clang with
547       -- see #5903 and #7617 for bugs caused by this.
548       (_,args0) = pgm_a dflags
549       args1 = map Option (getOpts dflags opt_a)
550       args2 = args0 ++ args1 ++ args
551   mb_env <- getGccEnv args2
552   Exception.catch (do
553         runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env
554     )
555     (\(err :: SomeException) -> do
556         errorMsg dflags $
557             text ("Error running clang! you need clang installed to use the" ++
558                 "LLVM backend") $+$
559             text "(or GHC tried to execute clang incorrectly)"
560         throwIO err
561     )
562
563 -- | Figure out which version of LLVM we are running this session
564 figureLlvmVersion :: DynFlags -> IO (Maybe Int)
565 figureLlvmVersion dflags = do
566   let (pgm,opts) = pgm_lc dflags
567       args = filter notNull (map showOpt opts)
568       -- we grab the args even though they should be useless just in
569       -- case the user is using a customised 'llc' that requires some
570       -- of the options they've specified. llc doesn't care what other
571       -- options are specified when '-version' is used.
572       args' = args ++ ["-version"]
573   ver <- catchIO (do
574              (pin, pout, perr, _) <- runInteractiveProcess pgm args'
575                                              Nothing Nothing
576              {- > llc -version
577                   Low Level Virtual Machine (http://llvm.org/):
578                     llvm version 2.8 (Ubuntu 2.8-0Ubuntu1)
579                     ...
580              -}
581              hSetBinaryMode pout False
582              _     <- hGetLine pout
583              vline <- hGetLine pout
584              v     <- case filter isDigit vline of
585                             []      -> fail "no digits!"
586                             [x]     -> fail $ "only 1 digit! (" ++ show x ++ ")"
587                             (x:y:_) -> return ((read [x,y]) :: Int)
588              hClose pin
589              hClose pout
590              hClose perr
591              return $ Just v
592             )
593             (\err -> do
594                 debugTraceMsg dflags 2
595                     (text "Error (figuring out LLVM version):" <+>
596                      text (show err))
597                 errorMsg dflags $ vcat
598                     [ text "Warning:", nest 9 $
599                           text "Couldn't figure out LLVM version!" $$
600                           text "Make sure you have installed LLVM"]
601                 return Nothing)
602   return ver
603
604
605 {- Note [Run-time linker info]
606
607 See also: Trac #5240, Trac #6063
608
609 Before 'runLink', we need to be sure to get the relevant information
610 about the linker we're using at runtime to see if we need any extra
611 options. For example, GNU ld requires '--reduce-memory-overheads' and
612 '--hash-size=31' in order to use reasonable amounts of memory (see
613 trac #5240.) But this isn't supported in GNU gold.
614
615 Generally, the linker changing from what was detected at ./configure
616 time has always been possible using -pgml, but on Linux it can happen
617 'transparently' by installing packages like binutils-gold, which
618 change what /usr/bin/ld actually points to.
619
620 Clang vs GCC notes:
621
622 For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
623 invoke the linker before the version information string. For 'clang',
624 the version information for 'ld' is all that's output. For this
625 reason, we typically need to slurp up all of the standard error output
626 and look through it.
627
628 Other notes:
629
630 We cache the LinkerInfo inside DynFlags, since clients may link
631 multiple times. The definition of LinkerInfo is there to avoid a
632 circular dependency.
633
634 -}
635
636
637 neededLinkArgs :: LinkerInfo -> [Option]
638 neededLinkArgs (GnuLD o)     = o
639 neededLinkArgs (GnuGold o)   = o
640 neededLinkArgs (DarwinLD o)  = o
641 neededLinkArgs UnknownLD     = []
642
643 -- Grab linker info and cache it in DynFlags.
644 getLinkerInfo :: DynFlags -> IO LinkerInfo
645 getLinkerInfo dflags = do
646   info <- readIORef (rtldFlags dflags)
647   case info of
648     Just v  -> return v
649     Nothing -> do
650       v <- getLinkerInfo' dflags
651       writeIORef (rtldFlags dflags) (Just v)
652       return v
653
654 -- See Note [Run-time linker info].
655 getLinkerInfo' :: DynFlags -> IO LinkerInfo
656 getLinkerInfo' dflags = do
657   let platform = targetPlatform dflags
658       os = platformOS platform
659       (pgm,_) = pgm_l dflags
660
661       -- Try to grab the info from the process output.
662       parseLinkerInfo stdo _stde _exitc
663         | any ("GNU ld" `isPrefixOf`) stdo =
664           -- GNU ld specifically needs to use less memory. This especially
665           -- hurts on small object files. Trac #5240.
666           return (GnuLD $ map Option ["-Wl,--hash-size=31",
667                                       "-Wl,--reduce-memory-overheads"])
668
669         | any ("GNU gold" `isPrefixOf`) stdo =
670           -- GNU gold does not require any special arguments.
671           return (GnuGold [])
672
673          -- Unknown linker.
674         | otherwise = fail "invalid --version output, or linker is unsupported"
675
676   -- Process the executable call
677   info <- catchIO (do
678              case os of
679                OSDarwin ->
680                  -- Darwin has neither GNU Gold or GNU LD, but a strange linker
681                  -- that doesn't support --version. We can just assume that's
682                  -- what we're using.
683                  return $ DarwinLD []
684                OSiOS -> 
685                  -- Ditto for iOS
686                  return $ DarwinLD []
687                OSMinGW32 ->
688                  -- GHC doesn't support anything but GNU ld on Windows anyway.
689                  -- Process creation is also fairly expensive on win32, so
690                  -- we short-circuit here.
691                  return $ GnuLD $ map Option ["-Wl,--hash-size=31",
692                                               "-Wl,--reduce-memory-overheads"]
693                _ -> do
694                  -- In practice, we use the compiler as the linker here. Pass
695                  -- -Wl,--version to get linker version info.
696                  (exitc, stdo, stde) <- readProcessWithExitCode pgm
697                                         ["-Wl,--version"] ""
698                  -- Split the output by lines to make certain kinds
699                  -- of processing easier. In particular, 'clang' and 'gcc'
700                  -- have slightly different outputs for '-Wl,--version', but
701                  -- it's still easy to figure out.
702                  parseLinkerInfo (lines stdo) (lines stde) exitc
703             )
704             (\err -> do
705                 debugTraceMsg dflags 2
706                     (text "Error (figuring out linker information):" <+>
707                      text (show err))
708                 errorMsg dflags $ hang (text "Warning:") 9 $
709                   text "Couldn't figure out linker information!" $$
710                   text "Make sure you're using GNU ld, GNU gold" <+>
711                   text "or the built in OS X linker, etc."
712                 return UnknownLD)
713   return info
714
715 runLink :: DynFlags -> [Option] -> IO ()
716 runLink dflags args = do
717   -- See Note [Run-time linker info]
718   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
719   let (p,args0) = pgm_l dflags
720       args1     = map Option (getOpts dflags opt_l)
721       args2     = args0 ++ args1 ++ args ++ linkargs
722   mb_env <- getGccEnv args2
723   runSomethingFiltered dflags id "Linker" p args2 mb_env
724
725 runLibtool :: DynFlags -> [Option] -> IO ()
726 runLibtool dflags args = do
727   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
728   let args1      = map Option (getOpts dflags opt_l)
729       args2      = [Option "-static"] ++ args1 ++ args ++ linkargs
730       libtool    = pgm_libtool dflags    
731   mb_env <- getGccEnv args2
732   runSomethingFiltered dflags id "Linker" libtool args2 mb_env
733
734 runMkDLL :: DynFlags -> [Option] -> IO ()
735 runMkDLL dflags args = do
736   let (p,args0) = pgm_dll dflags
737       args1 = args0 ++ args
738   mb_env <- getGccEnv (args0++args)
739   runSomethingFiltered dflags id "Make DLL" p args1 mb_env
740
741 runWindres :: DynFlags -> [Option] -> IO ()
742 runWindres dflags args = do
743   let (gcc, gcc_args) = pgm_c dflags
744       windres = pgm_windres dflags
745       opts = map Option (getOpts dflags opt_windres)
746       quote x = "\"" ++ x ++ "\""
747       args' = -- If windres.exe and gcc.exe are in a directory containing
748               -- spaces then windres fails to run gcc. We therefore need
749               -- to tell it what command to use...
750               Option ("--preprocessor=" ++
751                       unwords (map quote (gcc :
752                                           map showOpt gcc_args ++
753                                           map showOpt opts ++
754                                           ["-E", "-xc", "-DRC_INVOKED"])))
755               -- ...but if we do that then if windres calls popen then
756               -- it can't understand the quoting, so we have to use
757               -- --use-temp-file so that it interprets it correctly.
758               -- See #1828.
759             : Option "--use-temp-file"
760             : args
761   mb_env <- getGccEnv gcc_args
762   runSomethingFiltered dflags id "Windres" windres args' mb_env
763
764 touch :: DynFlags -> String -> String -> IO ()
765 touch dflags purpose arg =
766   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
767
768 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
769 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
770
771 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
772                -> IO ()
773 copyWithHeader dflags purpose maybe_header from to = do
774   showPass dflags purpose
775
776   hout <- openBinaryFile to   WriteMode
777   hin  <- openBinaryFile from ReadMode
778   ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
779   maybe (return ()) (header hout) maybe_header
780   hPutStr hout ls
781   hClose hout
782   hClose hin
783  where
784   -- write the header string in UTF-8.  The header is something like
785   --   {-# LINE "foo.hs" #-}
786   -- and we want to make sure a Unicode filename isn't mangled.
787   header h str = do
788    hSetEncoding h utf8
789    hPutStr h str
790    hSetBinaryMode h True
791
792 -- | read the contents of the named section in an ELF object as a
793 -- String.
794 readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
795 readElfSection _dflags section exe = do
796   let
797      prog = "readelf"
798      args = [Option "-p", Option section, FileOption "" exe]
799   --
800   r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) ""
801   case r of
802     (ExitSuccess, out, _err) -> return (doFilter (lines out))
803     _ -> return Nothing
804  where
805   doFilter [] = Nothing
806   doFilter (s:r) = case readP_to_S parse s of
807                     [(p,"")] -> Just p
808                     _r       -> doFilter r
809    where parse = do
810            skipSpaces
811            _ <- R.char '['
812            skipSpaces
813            _ <- string "0]"
814            skipSpaces
815            munch (const True)
816 \end{code}
817
818 %************************************************************************
819 %*                                                                      *
820 \subsection{Managing temporary files
821 %*                                                                      *
822 %************************************************************************
823
824 \begin{code}
825 cleanTempDirs :: DynFlags -> IO ()
826 cleanTempDirs dflags
827    = unless (gopt Opt_KeepTmpFiles dflags)
828    $ mask_
829    $ do let ref = dirsToClean dflags
830         ds <- atomicModifyIORef ref $ \ds -> (Map.empty, ds)
831         removeTmpDirs dflags (Map.elems ds)
832
833 cleanTempFiles :: DynFlags -> IO ()
834 cleanTempFiles dflags
835    = unless (gopt Opt_KeepTmpFiles dflags)
836    $ mask_
837    $ do let ref = filesToClean dflags
838         fs <- atomicModifyIORef ref $ \fs -> ([],fs)
839         removeTmpFiles dflags fs
840
841 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
842 cleanTempFilesExcept dflags dont_delete
843    = unless (gopt Opt_KeepTmpFiles dflags)
844    $ mask_
845    $ do let ref = filesToClean dflags
846         to_delete <- atomicModifyIORef ref $ \files ->
847             let (to_keep,to_delete) = partition (`elem` dont_delete) files
848             in  (to_keep,to_delete)
849         removeTmpFiles dflags to_delete
850
851
852 -- Return a unique numeric temp file suffix
853 newTempSuffix :: DynFlags -> IO Int
854 newTempSuffix dflags = atomicModifyIORef (nextTempSuffix dflags) $ \n -> (n+1,n)
855
856 -- Find a temporary name that doesn't already exist.
857 newTempName :: DynFlags -> Suffix -> IO FilePath
858 newTempName dflags extn
859   = do d <- getTempDir dflags
860        x <- getProcessID
861        findTempName (d </> "ghc" ++ show x ++ "_")
862   where
863     findTempName :: FilePath -> IO FilePath
864     findTempName prefix
865       = do n <- newTempSuffix dflags
866            let filename = prefix ++ show n <.> extn
867            b <- doesFileExist filename
868            if b then findTempName prefix
869                 else do -- clean it up later
870                         consIORef (filesToClean dflags) filename
871                         return filename
872
873 -- Return our temporary directory within tmp_dir, creating one if we
874 -- don't have one yet.
875 getTempDir :: DynFlags -> IO FilePath
876 getTempDir dflags = do
877     mapping <- readIORef dir_ref
878     case Map.lookup tmp_dir mapping of
879         Nothing -> do
880             pid <- getProcessID
881             let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
882             mask_ $ mkTempDir prefix
883         Just dir -> return dir
884   where
885     tmp_dir = tmpDir dflags
886     dir_ref = dirsToClean dflags
887
888     mkTempDir :: FilePath -> IO FilePath
889     mkTempDir prefix = do
890         n <- newTempSuffix dflags
891         let our_dir = prefix ++ show n
892
893         -- 1. Speculatively create our new directory.
894         createDirectory our_dir
895
896         -- 2. Update the dirsToClean mapping unless an entry already exists
897         -- (i.e. unless another thread beat us to it).
898         their_dir <- atomicModifyIORef dir_ref $ \mapping ->
899             case Map.lookup tmp_dir mapping of
900                 Just dir -> (mapping, Just dir)
901                 Nothing  -> (Map.insert tmp_dir our_dir mapping, Nothing)
902
903         -- 3. If there was an existing entry, return it and delete the
904         -- directory we created.  Otherwise return the directory we created.
905         case their_dir of
906             Nothing  -> do
907                 debugTraceMsg dflags 2 $
908                     text "Created temporary directory:" <+> text our_dir
909                 return our_dir
910             Just dir -> do
911                 removeDirectory our_dir
912                 return dir
913       `catchIO` \e -> if isAlreadyExistsError e
914                       then mkTempDir prefix else ioError e
915
916 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
917 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
918 addFilesToClean dflags new_files
919     = atomicModifyIORef (filesToClean dflags) $ \files -> (new_files++files, ())
920
921 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
922 removeTmpDirs dflags ds
923   = traceCmd dflags "Deleting temp dirs"
924              ("Deleting: " ++ unwords ds)
925              (mapM_ (removeWith dflags removeDirectory) ds)
926
927 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
928 removeTmpFiles dflags fs
929   = warnNon $
930     traceCmd dflags "Deleting temp files"
931              ("Deleting: " ++ unwords deletees)
932              (mapM_ (removeWith dflags removeFile) deletees)
933   where
934      -- Flat out refuse to delete files that are likely to be source input
935      -- files (is there a worse bug than having a compiler delete your source
936      -- files?)
937      --
938      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
939      -- the condition.
940     warnNon act
941      | null non_deletees = act
942      | otherwise         = do
943         putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
944         act
945
946     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
947
948 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
949 removeWith dflags remover f = remover f `catchIO`
950   (\e ->
951    let msg = if isDoesNotExistError e
952              then ptext (sLit "Warning: deleting non-existent") <+> text f
953              else ptext (sLit "Warning: exception raised when deleting")
954                                             <+> text f <> colon
955                $$ text (show e)
956    in debugTraceMsg dflags 2 msg
957   )
958
959 -----------------------------------------------------------------------------
960 -- Running an external program
961
962 runSomething :: DynFlags
963              -> String          -- For -v message
964              -> String          -- Command name (possibly a full path)
965                                 --      assumed already dos-ified
966              -> [Option]        -- Arguments
967                                 --      runSomething will dos-ify them
968              -> IO ()
969
970 runSomething dflags phase_name pgm args =
971   runSomethingFiltered dflags id phase_name pgm args Nothing
972
973 runSomethingFiltered
974   :: DynFlags -> (String->String) -> String -> String -> [Option]
975   -> Maybe [(String,String)] -> IO ()
976
977 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
978     runSomethingWith dflags phase_name pgm args $ \real_args -> do
979         r <- builderMainLoop dflags filter_fn pgm real_args mb_env
980         return (r,())
981
982 runSomethingWith
983   :: DynFlags -> String -> String -> [Option]
984   -> ([String] -> IO (ExitCode, a))
985   -> IO a
986
987 runSomethingWith dflags phase_name pgm args io = do
988   let real_args = filter notNull (map showOpt args)
989       cmdLine = showCommandForUser pgm real_args
990   traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
991
992 handleProc :: String -> String -> IO (ExitCode, r) -> IO r
993 handleProc pgm phase_name proc = do
994     (rc, r) <- proc `catchIO` handler
995     case rc of
996       ExitSuccess{} -> return r
997       ExitFailure n
998         -- rawSystem returns (ExitFailure 127) if the exec failed for any
999         -- reason (eg. the program doesn't exist).  This is the only clue
1000         -- we have, but we need to report something to the user because in
1001         -- the case of a missing program there will otherwise be no output
1002         -- at all.
1003        | n == 127  -> does_not_exist
1004        | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc)
1005   where
1006     handler err =
1007        if IO.isDoesNotExistError err
1008           then does_not_exist
1009           else IO.ioError err
1010
1011     does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
1012
1013
1014 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
1015                 -> [String] -> Maybe [(String, String)]
1016                 -> IO ExitCode
1017 builderMainLoop dflags filter_fn pgm real_args mb_env = do
1018   chan <- newChan
1019   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
1020
1021   -- and run a loop piping the output from the compiler to the log_action in DynFlags
1022   hSetBuffering hStdOut LineBuffering
1023   hSetBuffering hStdErr LineBuffering
1024   _ <- forkIO (readerProc chan hStdOut filter_fn)
1025   _ <- forkIO (readerProc chan hStdErr filter_fn)
1026   -- we don't want to finish until 2 streams have been completed
1027   -- (stdout and stderr)
1028   -- nor until 1 exit code has been retrieved.
1029   rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
1030   -- after that, we're done here.
1031   hClose hStdIn
1032   hClose hStdOut
1033   hClose hStdErr
1034   return rc
1035   where
1036     -- status starts at zero, and increments each time either
1037     -- a reader process gets EOF, or the build proc exits.  We wait
1038     -- for all of these to happen (status==3).
1039     -- ToDo: we should really have a contingency plan in case any of
1040     -- the threads dies, such as a timeout.
1041     loop _    _        0 0 exitcode = return exitcode
1042     loop chan hProcess t p exitcode = do
1043       mb_code <- if p > 0
1044                    then getProcessExitCode hProcess
1045                    else return Nothing
1046       case mb_code of
1047         Just code -> loop chan hProcess t (p-1) code
1048         Nothing
1049           | t > 0 -> do
1050               msg <- readChan chan
1051               case msg of
1052                 BuildMsg msg -> do
1053                   log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
1054                   loop chan hProcess t p exitcode
1055                 BuildError loc msg -> do
1056                   log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
1057                   loop chan hProcess t p exitcode
1058                 EOF ->
1059                   loop chan hProcess (t-1) p exitcode
1060           | otherwise -> loop chan hProcess t p exitcode
1061
1062 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
1063 readerProc chan hdl filter_fn =
1064     (do str <- hGetContents hdl
1065         loop (linesPlatform (filter_fn str)) Nothing)
1066     `finally`
1067        writeChan chan EOF
1068         -- ToDo: check errors more carefully
1069         -- ToDo: in the future, the filter should be implemented as
1070         -- a stream transformer.
1071     where
1072         loop []     Nothing    = return ()
1073         loop []     (Just err) = writeChan chan err
1074         loop (l:ls) in_err     =
1075                 case in_err of
1076                   Just err@(BuildError srcLoc msg)
1077                     | leading_whitespace l -> do
1078                         loop ls (Just (BuildError srcLoc (msg $$ text l)))
1079                     | otherwise -> do
1080                         writeChan chan err
1081                         checkError l ls
1082                   Nothing -> do
1083                         checkError l ls
1084                   _ -> panic "readerProc/loop"
1085
1086         checkError l ls
1087            = case parseError l of
1088                 Nothing -> do
1089                     writeChan chan (BuildMsg (text l))
1090                     loop ls Nothing
1091                 Just (file, lineNum, colNum, msg) -> do
1092                     let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
1093                     loop ls (Just (BuildError srcLoc (text msg)))
1094
1095         leading_whitespace []    = False
1096         leading_whitespace (x:_) = isSpace x
1097
1098 parseError :: String -> Maybe (String, Int, Int, String)
1099 parseError s0 = case breakColon s0 of
1100                 Just (filename, s1) ->
1101                     case breakIntColon s1 of
1102                     Just (lineNum, s2) ->
1103                         case breakIntColon s2 of
1104                         Just (columnNum, s3) ->
1105                             Just (filename, lineNum, columnNum, s3)
1106                         Nothing ->
1107                             Just (filename, lineNum, 0, s2)
1108                     Nothing -> Nothing
1109                 Nothing -> Nothing
1110
1111 breakColon :: String -> Maybe (String, String)
1112 breakColon xs = case break (':' ==) xs of
1113                     (ys, _:zs) -> Just (ys, zs)
1114                     _ -> Nothing
1115
1116 breakIntColon :: String -> Maybe (Int, String)
1117 breakIntColon xs = case break (':' ==) xs of
1118                        (ys, _:zs)
1119                         | not (null ys) && all isAscii ys && all isDigit ys ->
1120                            Just (read ys, zs)
1121                        _ -> Nothing
1122
1123 data BuildMessage
1124   = BuildMsg   !SDoc
1125   | BuildError !SrcLoc !SDoc
1126   | EOF
1127
1128 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
1129 -- trace the command (at two levels of verbosity)
1130 traceCmd dflags phase_name cmd_line action
1131  = do   { let verb = verbosity dflags
1132         ; showPass dflags phase_name
1133         ; debugTraceMsg dflags 3 (text cmd_line)
1134         ; case flushErr dflags of
1135               FlushErr io -> io
1136
1137            -- And run it!
1138         ; action `catchIO` handle_exn verb
1139         }
1140   where
1141     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
1142                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
1143                               ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
1144 \end{code}
1145
1146 %************************************************************************
1147 %*                                                                      *
1148 \subsection{Support code}
1149 %*                                                                      *
1150 %************************************************************************
1151
1152 \begin{code}
1153 -----------------------------------------------------------------------------
1154 -- Define       getBaseDir     :: IO (Maybe String)
1155
1156 getBaseDir :: IO (Maybe String)
1157 #if defined(mingw32_HOST_OS)
1158 -- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
1159 -- return the path $(stuff)/lib.
1160 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1161   where
1162     try_size size = allocaArray (fromIntegral size) $ \buf -> do
1163         ret <- c_GetModuleFileName nullPtr buf size
1164         case ret of
1165           0 -> return Nothing
1166           _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
1167             | otherwise  -> try_size (size * 2)
1168     
1169     rootDir s = case splitFileName $ normalise s of
1170                 (d, ghc_exe)
1171                  | lower ghc_exe `elem` ["ghc.exe",
1172                                          "ghc-stage1.exe",
1173                                          "ghc-stage2.exe",
1174                                          "ghc-stage3.exe"] ->
1175                     case splitFileName $ takeDirectory d of
1176                     -- ghc is in $topdir/bin/ghc.exe
1177                     (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
1178                     _ -> fail
1179                 _ -> fail
1180         where fail = panic ("can't decompose ghc.exe path: " ++ show s)
1181               lower = map toLower
1182
1183 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1184   c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1185 #else
1186 getBaseDir = return Nothing
1187 #endif
1188
1189 #ifdef mingw32_HOST_OS
1190 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
1191 #else
1192 getProcessID :: IO Int
1193 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
1194 #endif
1195
1196 -- Divvy up text stream into lines, taking platform dependent
1197 -- line termination into account.
1198 linesPlatform :: String -> [String]
1199 #if !defined(mingw32_HOST_OS)
1200 linesPlatform ls = lines ls
1201 #else
1202 linesPlatform "" = []
1203 linesPlatform xs =
1204   case lineBreak xs of
1205     (as,xs1) -> as : linesPlatform xs1
1206   where
1207    lineBreak "" = ("","")
1208    lineBreak ('\r':'\n':xs) = ([],xs)
1209    lineBreak ('\n':xs) = ([],xs)
1210    lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
1211
1212 #endif
1213
1214 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1215 linkDynLib dflags0 o_files dep_packages
1216  = do
1217     let -- This is a rather ugly hack to fix dynamically linked
1218         -- GHC on Windows. If GHC is linked with -threaded, then
1219         -- it links against libHSrts_thr. But if base is linked
1220         -- against libHSrts, then both end up getting loaded,
1221         -- and things go wrong. We therefore link the libraries
1222         -- with the same RTS flags that we link GHC with.
1223         dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0
1224                                   else                     dflags0
1225         dflags2 = if cGhcDebugged then addWay' WayDebug dflags1
1226                                   else                  dflags1
1227         dflags = updateWays dflags2
1228
1229         verbFlags = getVerbFlags dflags
1230         o_file = outputFile dflags
1231
1232     pkgs <- getPreloadPackagesAnd dflags dep_packages
1233
1234     let pkg_lib_paths = collectLibraryPaths pkgs
1235     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1236         get_pkg_lib_path_opts l
1237          | osElfTarget (platformOS (targetPlatform dflags)) &&
1238            dynLibLoader dflags == SystemDependent &&
1239            not (gopt Opt_Static dflags)
1240             = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1241          | otherwise = ["-L" ++ l]
1242
1243     let lib_paths = libraryPaths dflags
1244     let lib_path_opts = map ("-L"++) lib_paths
1245
1246     -- We don't want to link our dynamic libs against the RTS package,
1247     -- because the RTS lib comes in several flavours and we want to be
1248     -- able to pick the flavour when a binary is linked.
1249     -- On Windows we need to link the RTS import lib as Windows does
1250     -- not allow undefined symbols.
1251     -- The RTS library path is still added to the library search path
1252     -- above in case the RTS is being explicitly linked in (see #3807).
1253     let platform = targetPlatform dflags
1254         os = platformOS platform
1255         pkgs_no_rts = case os of
1256                       OSMinGW32 ->
1257                           pkgs
1258                       _ ->
1259                           filter ((/= rtsPackageId) . packageConfigId) pkgs
1260     let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
1261                         in  package_hs_libs ++ extra_libs ++ other_flags
1262
1263         -- probably _stub.o files
1264     let extra_ld_inputs = ldInputs dflags
1265
1266     case os of
1267         OSMinGW32 -> do
1268             -------------------------------------------------------------
1269             -- Making a DLL
1270             -------------------------------------------------------------
1271             let output_fn = case o_file of
1272                             Just s -> s
1273                             Nothing -> "HSdll.dll"
1274
1275             runLink dflags (
1276                     map Option verbFlags
1277                  ++ [ Option "-o"
1278                     , FileOption "" output_fn
1279                     , Option "-shared"
1280                     ] ++
1281                     [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1282                     | gopt Opt_SharedImplib dflags
1283                     ]
1284                  ++ map (FileOption "") o_files
1285
1286                  -- Permit the linker to auto link _symbol to _imp_symbol
1287                  -- This lets us link against DLLs without needing an "import library"
1288                  ++ [Option "-Wl,--enable-auto-import"]
1289
1290                  ++ extra_ld_inputs
1291                  ++ map Option (
1292                     lib_path_opts
1293                  ++ pkg_lib_path_opts
1294                  ++ pkg_link_opts
1295                 ))
1296         OSDarwin -> do
1297             -------------------------------------------------------------------
1298             -- Making a darwin dylib
1299             -------------------------------------------------------------------
1300             -- About the options used for Darwin:
1301             -- -dynamiclib
1302             --   Apple's way of saying -shared
1303             -- -undefined dynamic_lookup:
1304             --   Without these options, we'd have to specify the correct
1305             --   dependencies for each of the dylibs. Note that we could
1306             --   (and should) do without this for all libraries except
1307             --   the RTS; all we need to do is to pass the correct
1308             --   HSfoo_dyn.dylib files to the link command.
1309             --   This feature requires Mac OS X 10.3 or later; there is
1310             --   a similar feature, -flat_namespace -undefined suppress,
1311             --   which works on earlier versions, but it has other
1312             --   disadvantages.
1313             -- -single_module
1314             --   Build the dynamic library as a single "module", i.e. no
1315             --   dynamic binding nonsense when referring to symbols from
1316             --   within the library. The NCG assumes that this option is
1317             --   specified (on i386, at least).
1318             -- -install_name
1319             --   Mac OS/X stores the path where a dynamic library is (to
1320             --   be) installed in the library itself.  It's called the
1321             --   "install name" of the library. Then any library or
1322             --   executable that links against it before it's installed
1323             --   will search for it in its ultimate install location.
1324             --   By default we set the install name to the absolute path
1325             --   at build time, but it can be overridden by the
1326             --   -dylib-install-name option passed to ghc. Cabal does
1327             --   this.
1328             -------------------------------------------------------------------
1329
1330             let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1331
1332             instName <- case dylibInstallName dflags of
1333                 Just n -> return n
1334                 Nothing -> do
1335                     pwd <- getCurrentDirectory
1336                     return $ pwd `combine` output_fn
1337             runLink dflags (
1338                     map Option verbFlags
1339                  ++ [ Option "-dynamiclib"
1340                     , Option "-o"
1341                     , FileOption "" output_fn
1342                     ]
1343                  ++ map Option o_files
1344                  ++ [ Option "-undefined",
1345                       Option "dynamic_lookup",
1346                       Option "-single_module" ]
1347                  ++ (if platformArch platform == ArchX86_64
1348                      then [ ]
1349                      else [ Option "-Wl,-read_only_relocs,suppress" ])
1350                  ++ [ Option "-install_name", Option instName ]
1351                  ++ map Option lib_path_opts
1352                  ++ extra_ld_inputs
1353                  ++ map Option pkg_lib_path_opts
1354                  ++ map Option pkg_link_opts
1355               )
1356         OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target")
1357         _ -> do
1358             -------------------------------------------------------------------
1359             -- Making a DSO
1360             -------------------------------------------------------------------
1361
1362             let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1363             let buildingRts = thisPackage dflags == rtsPackageId
1364             let bsymbolicFlag = if buildingRts
1365                                 then -- -Bsymbolic breaks the way we implement
1366                                      -- hooks in the RTS
1367                                      []
1368                                 else -- we need symbolic linking to resolve
1369                                      -- non-PIC intra-package-relocations
1370                                      ["-Wl,-Bsymbolic"]
1371
1372             runLink dflags (
1373                     map Option verbFlags
1374                  ++ [ Option "-o"
1375                     , FileOption "" output_fn
1376                     ]
1377                  ++ map Option o_files
1378                  ++ [ Option "-shared" ]
1379                  ++ map Option bsymbolicFlag
1380                     -- Set the library soname. We use -h rather than -soname as
1381                     -- Solaris 10 doesn't support the latter:
1382                  ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
1383                  ++ map Option lib_path_opts
1384                  ++ extra_ld_inputs
1385                  ++ map Option pkg_lib_path_opts
1386                  ++ map Option pkg_link_opts
1387               )
1388 \end{code}