Rework how iOS does linking (#8127)
[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 (opts ++ args)
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                OSMinGW32 ->
685                  -- GHC doesn't support anything but GNU ld on Windows anyway.
686                  -- Process creation is also fairly expensive on win32, so
687                  -- we short-circuit here.
688                  return $ GnuLD $ map Option ["-Wl,--hash-size=31",
689                                               "-Wl,--reduce-memory-overheads"]
690                _ -> do
691                  -- In practice, we use the compiler as the linker here. Pass
692                  -- -Wl,--version to get linker version info.
693                  (exitc, stdo, stde) <- readProcessWithExitCode pgm
694                                         ["-Wl,--version"] ""
695                  -- Split the output by lines to make certain kinds
696                  -- of processing easier. In particular, 'clang' and 'gcc'
697                  -- have slightly different outputs for '-Wl,--version', but
698                  -- it's still easy to figure out.
699                  parseLinkerInfo (lines stdo) (lines stde) exitc
700             )
701             (\err -> do
702                 debugTraceMsg dflags 2
703                     (text "Error (figuring out linker information):" <+>
704                      text (show err))
705                 errorMsg dflags $ hang (text "Warning:") 9 $
706                   text "Couldn't figure out linker information!" $$
707                   text "Make sure you're using GNU ld, GNU gold" <+>
708                   text "or the built in OS X linker, etc."
709                 return UnknownLD)
710   return info
711
712 runLink :: DynFlags -> [Option] -> IO ()
713 runLink dflags args = do
714   -- See Note [Run-time linker info]
715   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
716   let (p,args0) = pgm_l dflags
717       args1     = map Option (getOpts dflags opt_l)
718       args2     = args0 ++ args1 ++ args ++ linkargs
719   mb_env <- getGccEnv args2
720   runSomethingFiltered dflags id "Linker" p args2 mb_env
721
722 runLibtool :: DynFlags -> [Option] -> IO ()
723 runLibtool dflags args = do
724   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
725   let args1      = map Option (getOpts dflags opt_l)
726       args2      = [Option "-static"] ++ args1 ++ args ++ linkargs
727       libtool    = pgm_libtool dflags    
728   mb_env <- getGccEnv args2
729   runSomethingFiltered dflags id "Linker" libtool args2 mb_env
730
731 runMkDLL :: DynFlags -> [Option] -> IO ()
732 runMkDLL dflags args = do
733   let (p,args0) = pgm_dll dflags
734       args1 = args0 ++ args
735   mb_env <- getGccEnv (args0++args)
736   runSomethingFiltered dflags id "Make DLL" p args1 mb_env
737
738 runWindres :: DynFlags -> [Option] -> IO ()
739 runWindres dflags args = do
740   let (gcc, gcc_args) = pgm_c dflags
741       windres = pgm_windres dflags
742       opts = map Option (getOpts dflags opt_windres)
743       quote x = "\"" ++ x ++ "\""
744       args' = -- If windres.exe and gcc.exe are in a directory containing
745               -- spaces then windres fails to run gcc. We therefore need
746               -- to tell it what command to use...
747               Option ("--preprocessor=" ++
748                       unwords (map quote (gcc :
749                                           map showOpt gcc_args ++
750                                           map showOpt opts ++
751                                           ["-E", "-xc", "-DRC_INVOKED"])))
752               -- ...but if we do that then if windres calls popen then
753               -- it can't understand the quoting, so we have to use
754               -- --use-temp-file so that it interprets it correctly.
755               -- See #1828.
756             : Option "--use-temp-file"
757             : args
758   mb_env <- getGccEnv gcc_args
759   runSomethingFiltered dflags id "Windres" windres args' mb_env
760
761 touch :: DynFlags -> String -> String -> IO ()
762 touch dflags purpose arg =
763   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
764
765 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
766 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
767
768 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
769                -> IO ()
770 copyWithHeader dflags purpose maybe_header from to = do
771   showPass dflags purpose
772
773   hout <- openBinaryFile to   WriteMode
774   hin  <- openBinaryFile from ReadMode
775   ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
776   maybe (return ()) (header hout) maybe_header
777   hPutStr hout ls
778   hClose hout
779   hClose hin
780  where
781   -- write the header string in UTF-8.  The header is something like
782   --   {-# LINE "foo.hs" #-}
783   -- and we want to make sure a Unicode filename isn't mangled.
784   header h str = do
785    hSetEncoding h utf8
786    hPutStr h str
787    hSetBinaryMode h True
788
789 -- | read the contents of the named section in an ELF object as a
790 -- String.
791 readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
792 readElfSection _dflags section exe = do
793   let
794      prog = "readelf"
795      args = [Option "-p", Option section, FileOption "" exe]
796   --
797   r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) ""
798   case r of
799     (ExitSuccess, out, _err) -> return (doFilter (lines out))
800     _ -> return Nothing
801  where
802   doFilter [] = Nothing
803   doFilter (s:r) = case readP_to_S parse s of
804                     [(p,"")] -> Just p
805                     _r       -> doFilter r
806    where parse = do
807            skipSpaces
808            _ <- R.char '['
809            skipSpaces
810            _ <- string "0]"
811            skipSpaces
812            munch (const True)
813 \end{code}
814
815 %************************************************************************
816 %*                                                                      *
817 \subsection{Managing temporary files
818 %*                                                                      *
819 %************************************************************************
820
821 \begin{code}
822 cleanTempDirs :: DynFlags -> IO ()
823 cleanTempDirs dflags
824    = unless (gopt Opt_KeepTmpFiles dflags)
825    $ do let ref = dirsToClean dflags
826         ds <- readIORef ref
827         removeTmpDirs dflags (Map.elems ds)
828         writeIORef ref Map.empty
829
830 cleanTempFiles :: DynFlags -> IO ()
831 cleanTempFiles dflags
832    = unless (gopt Opt_KeepTmpFiles dflags)
833    $ do let ref = filesToClean dflags
834         fs <- readIORef ref
835         removeTmpFiles dflags fs
836         writeIORef ref []
837
838 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
839 cleanTempFilesExcept dflags dont_delete
840    = unless (gopt Opt_KeepTmpFiles dflags)
841    $ do let ref = filesToClean dflags
842         files <- readIORef ref
843         let (to_keep, to_delete) = partition (`elem` dont_delete) files
844         writeIORef ref to_keep
845         removeTmpFiles dflags to_delete
846
847
848 -- find a temporary name that doesn't already exist.
849 newTempName :: DynFlags -> Suffix -> IO FilePath
850 newTempName dflags extn
851   = do d <- getTempDir dflags
852        x <- getProcessID
853        findTempName (d </> "ghc" ++ show x ++ "_") 0
854   where
855     findTempName :: FilePath -> Integer -> IO FilePath
856     findTempName prefix x
857       = do let filename = (prefix ++ show x) <.> extn
858            b  <- doesFileExist filename
859            if b then findTempName prefix (x+1)
860                 else do -- clean it up later
861                         consIORef (filesToClean dflags) filename
862                         return filename
863
864 -- return our temporary directory within tmp_dir, creating one if we
865 -- don't have one yet
866 getTempDir :: DynFlags -> IO FilePath
867 getTempDir dflags
868   = do let ref = dirsToClean dflags
869            tmp_dir = tmpDir dflags
870        mapping <- readIORef ref
871        case Map.lookup tmp_dir mapping of
872            Nothing ->
873                do x <- getProcessID
874                   let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
875                   let
876                       mkTempDir :: Integer -> IO FilePath
877                       mkTempDir x
878                        = let dirname = prefix ++ show x
879                          in do createDirectory dirname
880                                let mapping' = Map.insert tmp_dir dirname mapping
881                                writeIORef ref mapping'
882                                debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
883                                return dirname
884                             `catchIO` \e ->
885                                     if isAlreadyExistsError e
886                                     then mkTempDir (x+1)
887                                     else ioError e
888                   mkTempDir 0
889            Just d -> return d
890
891 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
892 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
893 addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
894
895 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
896 removeTmpDirs dflags ds
897   = traceCmd dflags "Deleting temp dirs"
898              ("Deleting: " ++ unwords ds)
899              (mapM_ (removeWith dflags removeDirectory) ds)
900
901 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
902 removeTmpFiles dflags fs
903   = warnNon $
904     traceCmd dflags "Deleting temp files"
905              ("Deleting: " ++ unwords deletees)
906              (mapM_ (removeWith dflags removeFile) deletees)
907   where
908      -- Flat out refuse to delete files that are likely to be source input
909      -- files (is there a worse bug than having a compiler delete your source
910      -- files?)
911      --
912      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
913      -- the condition.
914     warnNon act
915      | null non_deletees = act
916      | otherwise         = do
917         putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
918         act
919
920     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
921
922 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
923 removeWith dflags remover f = remover f `catchIO`
924   (\e ->
925    let msg = if isDoesNotExistError e
926              then ptext (sLit "Warning: deleting non-existent") <+> text f
927              else ptext (sLit "Warning: exception raised when deleting")
928                                             <+> text f <> colon
929                $$ text (show e)
930    in debugTraceMsg dflags 2 msg
931   )
932
933 -----------------------------------------------------------------------------
934 -- Running an external program
935
936 runSomething :: DynFlags
937              -> String          -- For -v message
938              -> String          -- Command name (possibly a full path)
939                                 --      assumed already dos-ified
940              -> [Option]        -- Arguments
941                                 --      runSomething will dos-ify them
942              -> IO ()
943
944 runSomething dflags phase_name pgm args =
945   runSomethingFiltered dflags id phase_name pgm args Nothing
946
947 runSomethingFiltered
948   :: DynFlags -> (String->String) -> String -> String -> [Option]
949   -> Maybe [(String,String)] -> IO ()
950
951 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
952     runSomethingWith dflags phase_name pgm args $ \real_args -> do
953         r <- builderMainLoop dflags filter_fn pgm real_args mb_env
954         return (r,())
955
956 runSomethingWith
957   :: DynFlags -> String -> String -> [Option]
958   -> ([String] -> IO (ExitCode, a))
959   -> IO a
960
961 runSomethingWith dflags phase_name pgm args io = do
962   let real_args = filter notNull (map showOpt args)
963       cmdLine = showCommandForUser pgm real_args
964   traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
965
966 handleProc :: String -> String -> IO (ExitCode, r) -> IO r
967 handleProc pgm phase_name proc = do
968     (rc, r) <- proc `catchIO` handler
969     case rc of
970       ExitSuccess{} -> return r
971       ExitFailure n
972         -- rawSystem returns (ExitFailure 127) if the exec failed for any
973         -- reason (eg. the program doesn't exist).  This is the only clue
974         -- we have, but we need to report something to the user because in
975         -- the case of a missing program there will otherwise be no output
976         -- at all.
977        | n == 127  -> does_not_exist
978        | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc)
979   where
980     handler err =
981        if IO.isDoesNotExistError err
982           then does_not_exist
983           else IO.ioError err
984
985     does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
986
987
988 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
989                 -> [String] -> Maybe [(String, String)]
990                 -> IO ExitCode
991 builderMainLoop dflags filter_fn pgm real_args mb_env = do
992   chan <- newChan
993   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
994
995   -- and run a loop piping the output from the compiler to the log_action in DynFlags
996   hSetBuffering hStdOut LineBuffering
997   hSetBuffering hStdErr LineBuffering
998   _ <- forkIO (readerProc chan hStdOut filter_fn)
999   _ <- forkIO (readerProc chan hStdErr filter_fn)
1000   -- we don't want to finish until 2 streams have been completed
1001   -- (stdout and stderr)
1002   -- nor until 1 exit code has been retrieved.
1003   rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
1004   -- after that, we're done here.
1005   hClose hStdIn
1006   hClose hStdOut
1007   hClose hStdErr
1008   return rc
1009   where
1010     -- status starts at zero, and increments each time either
1011     -- a reader process gets EOF, or the build proc exits.  We wait
1012     -- for all of these to happen (status==3).
1013     -- ToDo: we should really have a contingency plan in case any of
1014     -- the threads dies, such as a timeout.
1015     loop _    _        0 0 exitcode = return exitcode
1016     loop chan hProcess t p exitcode = do
1017       mb_code <- if p > 0
1018                    then getProcessExitCode hProcess
1019                    else return Nothing
1020       case mb_code of
1021         Just code -> loop chan hProcess t (p-1) code
1022         Nothing
1023           | t > 0 -> do
1024               msg <- readChan chan
1025               case msg of
1026                 BuildMsg msg -> do
1027                   log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
1028                   loop chan hProcess t p exitcode
1029                 BuildError loc msg -> do
1030                   log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
1031                   loop chan hProcess t p exitcode
1032                 EOF ->
1033                   loop chan hProcess (t-1) p exitcode
1034           | otherwise -> loop chan hProcess t p exitcode
1035
1036 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
1037 readerProc chan hdl filter_fn =
1038     (do str <- hGetContents hdl
1039         loop (linesPlatform (filter_fn str)) Nothing)
1040     `finally`
1041        writeChan chan EOF
1042         -- ToDo: check errors more carefully
1043         -- ToDo: in the future, the filter should be implemented as
1044         -- a stream transformer.
1045     where
1046         loop []     Nothing    = return ()
1047         loop []     (Just err) = writeChan chan err
1048         loop (l:ls) in_err     =
1049                 case in_err of
1050                   Just err@(BuildError srcLoc msg)
1051                     | leading_whitespace l -> do
1052                         loop ls (Just (BuildError srcLoc (msg $$ text l)))
1053                     | otherwise -> do
1054                         writeChan chan err
1055                         checkError l ls
1056                   Nothing -> do
1057                         checkError l ls
1058                   _ -> panic "readerProc/loop"
1059
1060         checkError l ls
1061            = case parseError l of
1062                 Nothing -> do
1063                     writeChan chan (BuildMsg (text l))
1064                     loop ls Nothing
1065                 Just (file, lineNum, colNum, msg) -> do
1066                     let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
1067                     loop ls (Just (BuildError srcLoc (text msg)))
1068
1069         leading_whitespace []    = False
1070         leading_whitespace (x:_) = isSpace x
1071
1072 parseError :: String -> Maybe (String, Int, Int, String)
1073 parseError s0 = case breakColon s0 of
1074                 Just (filename, s1) ->
1075                     case breakIntColon s1 of
1076                     Just (lineNum, s2) ->
1077                         case breakIntColon s2 of
1078                         Just (columnNum, s3) ->
1079                             Just (filename, lineNum, columnNum, s3)
1080                         Nothing ->
1081                             Just (filename, lineNum, 0, s2)
1082                     Nothing -> Nothing
1083                 Nothing -> Nothing
1084
1085 breakColon :: String -> Maybe (String, String)
1086 breakColon xs = case break (':' ==) xs of
1087                     (ys, _:zs) -> Just (ys, zs)
1088                     _ -> Nothing
1089
1090 breakIntColon :: String -> Maybe (Int, String)
1091 breakIntColon xs = case break (':' ==) xs of
1092                        (ys, _:zs)
1093                         | not (null ys) && all isAscii ys && all isDigit ys ->
1094                            Just (read ys, zs)
1095                        _ -> Nothing
1096
1097 data BuildMessage
1098   = BuildMsg   !SDoc
1099   | BuildError !SrcLoc !SDoc
1100   | EOF
1101
1102 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
1103 -- trace the command (at two levels of verbosity)
1104 traceCmd dflags phase_name cmd_line action
1105  = do   { let verb = verbosity dflags
1106         ; showPass dflags phase_name
1107         ; debugTraceMsg dflags 3 (text cmd_line)
1108         ; case flushErr dflags of
1109               FlushErr io -> io
1110
1111            -- And run it!
1112         ; action `catchIO` handle_exn verb
1113         }
1114   where
1115     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
1116                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
1117                               ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
1118 \end{code}
1119
1120 %************************************************************************
1121 %*                                                                      *
1122 \subsection{Support code}
1123 %*                                                                      *
1124 %************************************************************************
1125
1126 \begin{code}
1127 -----------------------------------------------------------------------------
1128 -- Define       getBaseDir     :: IO (Maybe String)
1129
1130 getBaseDir :: IO (Maybe String)
1131 #if defined(mingw32_HOST_OS)
1132 -- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
1133 -- return the path $(stuff)/lib.
1134 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1135   where
1136     try_size size = allocaArray (fromIntegral size) $ \buf -> do
1137         ret <- c_GetModuleFileName nullPtr buf size
1138         case ret of
1139           0 -> return Nothing
1140           _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
1141             | otherwise  -> try_size (size * 2)
1142     
1143     rootDir s = case splitFileName $ normalise s of
1144                 (d, ghc_exe)
1145                  | lower ghc_exe `elem` ["ghc.exe",
1146                                          "ghc-stage1.exe",
1147                                          "ghc-stage2.exe",
1148                                          "ghc-stage3.exe"] ->
1149                     case splitFileName $ takeDirectory d of
1150                     -- ghc is in $topdir/bin/ghc.exe
1151                     (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
1152                     _ -> fail
1153                 _ -> fail
1154         where fail = panic ("can't decompose ghc.exe path: " ++ show s)
1155               lower = map toLower
1156
1157 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1158   c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1159 #else
1160 getBaseDir = return Nothing
1161 #endif
1162
1163 #ifdef mingw32_HOST_OS
1164 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
1165 #else
1166 getProcessID :: IO Int
1167 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
1168 #endif
1169
1170 -- Divvy up text stream into lines, taking platform dependent
1171 -- line termination into account.
1172 linesPlatform :: String -> [String]
1173 #if !defined(mingw32_HOST_OS)
1174 linesPlatform ls = lines ls
1175 #else
1176 linesPlatform "" = []
1177 linesPlatform xs =
1178   case lineBreak xs of
1179     (as,xs1) -> as : linesPlatform xs1
1180   where
1181    lineBreak "" = ("","")
1182    lineBreak ('\r':'\n':xs) = ([],xs)
1183    lineBreak ('\n':xs) = ([],xs)
1184    lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
1185
1186 #endif
1187
1188 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1189 linkDynLib dflags0 o_files dep_packages
1190  = do
1191     let -- This is a rather ugly hack to fix dynamically linked
1192         -- GHC on Windows. If GHC is linked with -threaded, then
1193         -- it links against libHSrts_thr. But if base is linked
1194         -- against libHSrts, then both end up getting loaded,
1195         -- and things go wrong. We therefore link the libraries
1196         -- with the same RTS flags that we link GHC with.
1197         dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0
1198                                   else                     dflags0
1199         dflags2 = if cGhcDebugged then addWay' WayDebug dflags1
1200                                   else                  dflags1
1201         dflags = updateWays dflags2
1202
1203         verbFlags = getVerbFlags dflags
1204         o_file = outputFile dflags
1205
1206     pkgs <- getPreloadPackagesAnd dflags dep_packages
1207
1208     let pkg_lib_paths = collectLibraryPaths pkgs
1209     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1210         get_pkg_lib_path_opts l
1211          | osElfTarget (platformOS (targetPlatform dflags)) &&
1212            dynLibLoader dflags == SystemDependent &&
1213            not (gopt Opt_Static dflags)
1214             = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1215          | otherwise = ["-L" ++ l]
1216
1217     let lib_paths = libraryPaths dflags
1218     let lib_path_opts = map ("-L"++) lib_paths
1219
1220     -- We don't want to link our dynamic libs against the RTS package,
1221     -- because the RTS lib comes in several flavours and we want to be
1222     -- able to pick the flavour when a binary is linked.
1223     -- On Windows we need to link the RTS import lib as Windows does
1224     -- not allow undefined symbols.
1225     -- The RTS library path is still added to the library search path
1226     -- above in case the RTS is being explicitly linked in (see #3807).
1227     let platform = targetPlatform dflags
1228         os = platformOS platform
1229         pkgs_no_rts = case os of
1230                       OSMinGW32 ->
1231                           pkgs
1232                       _ ->
1233                           filter ((/= rtsPackageId) . packageConfigId) pkgs
1234     let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
1235                         in  package_hs_libs ++ extra_libs ++ other_flags
1236
1237         -- probably _stub.o files
1238     let extra_ld_inputs = ldInputs dflags
1239
1240     case os of
1241         OSMinGW32 -> do
1242             -------------------------------------------------------------
1243             -- Making a DLL
1244             -------------------------------------------------------------
1245             let output_fn = case o_file of
1246                             Just s -> s
1247                             Nothing -> "HSdll.dll"
1248
1249             runLink dflags (
1250                     map Option verbFlags
1251                  ++ [ Option "-o"
1252                     , FileOption "" output_fn
1253                     , Option "-shared"
1254                     ] ++
1255                     [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1256                     | gopt Opt_SharedImplib dflags
1257                     ]
1258                  ++ map (FileOption "") o_files
1259
1260                  -- Permit the linker to auto link _symbol to _imp_symbol
1261                  -- This lets us link against DLLs without needing an "import library"
1262                  ++ [Option "-Wl,--enable-auto-import"]
1263
1264                  ++ extra_ld_inputs
1265                  ++ map Option (
1266                     lib_path_opts
1267                  ++ pkg_lib_path_opts
1268                  ++ pkg_link_opts
1269                 ))
1270         OSDarwin -> do
1271             -------------------------------------------------------------------
1272             -- Making a darwin dylib
1273             -------------------------------------------------------------------
1274             -- About the options used for Darwin:
1275             -- -dynamiclib
1276             --   Apple's way of saying -shared
1277             -- -undefined dynamic_lookup:
1278             --   Without these options, we'd have to specify the correct
1279             --   dependencies for each of the dylibs. Note that we could
1280             --   (and should) do without this for all libraries except
1281             --   the RTS; all we need to do is to pass the correct
1282             --   HSfoo_dyn.dylib files to the link command.
1283             --   This feature requires Mac OS X 10.3 or later; there is
1284             --   a similar feature, -flat_namespace -undefined suppress,
1285             --   which works on earlier versions, but it has other
1286             --   disadvantages.
1287             -- -single_module
1288             --   Build the dynamic library as a single "module", i.e. no
1289             --   dynamic binding nonsense when referring to symbols from
1290             --   within the library. The NCG assumes that this option is
1291             --   specified (on i386, at least).
1292             -- -install_name
1293             --   Mac OS/X stores the path where a dynamic library is (to
1294             --   be) installed in the library itself.  It's called the
1295             --   "install name" of the library. Then any library or
1296             --   executable that links against it before it's installed
1297             --   will search for it in its ultimate install location.
1298             --   By default we set the install name to the absolute path
1299             --   at build time, but it can be overridden by the
1300             --   -dylib-install-name option passed to ghc. Cabal does
1301             --   this.
1302             -------------------------------------------------------------------
1303
1304             let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1305
1306             instName <- case dylibInstallName dflags of
1307                 Just n -> return n
1308                 Nothing -> do
1309                     pwd <- getCurrentDirectory
1310                     return $ pwd `combine` output_fn
1311             runLink dflags (
1312                     map Option verbFlags
1313                  ++ [ Option "-dynamiclib"
1314                     , Option "-o"
1315                     , FileOption "" output_fn
1316                     ]
1317                  ++ map Option o_files
1318                  ++ [ Option "-undefined",
1319                       Option "dynamic_lookup",
1320                       Option "-single_module" ]
1321                  ++ (if platformArch platform == ArchX86_64
1322                      then [ ]
1323                      else [ Option "-Wl,-read_only_relocs,suppress" ])
1324                  ++ [ Option "-install_name", Option instName ]
1325                  ++ map Option lib_path_opts
1326                  ++ extra_ld_inputs
1327                  ++ map Option pkg_lib_path_opts
1328                  ++ map Option pkg_link_opts
1329               )
1330         OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target")
1331         _ -> do
1332             -------------------------------------------------------------------
1333             -- Making a DSO
1334             -------------------------------------------------------------------
1335
1336             let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1337             let buildingRts = thisPackage dflags == rtsPackageId
1338             let bsymbolicFlag = if buildingRts
1339                                 then -- -Bsymbolic breaks the way we implement
1340                                      -- hooks in the RTS
1341                                      []
1342                                 else -- we need symbolic linking to resolve
1343                                      -- non-PIC intra-package-relocations
1344                                      ["-Wl,-Bsymbolic"]
1345
1346             runLink dflags (
1347                     map Option verbFlags
1348                  ++ [ Option "-o"
1349                     , FileOption "" output_fn
1350                     ]
1351                  ++ map Option o_files
1352                  ++ [ Option "-shared" ]
1353                  ++ map Option bsymbolicFlag
1354                     -- Set the library soname. We use -h rather than -soname as
1355                     -- Solaris 10 doesn't support the latter:
1356                  ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
1357                  ++ map Option lib_path_opts
1358                  ++ extra_ld_inputs
1359                  ++ map Option pkg_lib_path_opts
1360                  ++ map Option pkg_link_opts
1361               )
1362 \end{code}