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