Make GHC aware of OSAIX and AixLD
[ghc.git] / compiler / main / SysTools.hs
1 {-
2 -----------------------------------------------------------------------------
3 --
4 -- (c) The University of Glasgow 2001-2003
5 --
6 -- Access to system tools: gcc, cp, rm etc
7 --
8 -----------------------------------------------------------------------------
9 -}
10
11 {-# LANGUAGE CPP, ScopedTypeVariables #-}
12
13 module SysTools (
14 -- Initialisation
15 initSysTools,
16
17 -- Interface to system tools
18 runUnlit, runCpp, runCc, -- [Option] -> IO ()
19 runPp, -- [Option] -> IO ()
20 runSplit, -- [Option] -> IO ()
21 runAs, runLink, runLibtool, -- [Option] -> IO ()
22 runMkDLL,
23 runWindres,
24 runLlvmOpt,
25 runLlvmLlc,
26 runClang,
27 figureLlvmVersion,
28
29 getLinkerInfo,
30 getCompilerInfo,
31
32 linkDynLib,
33
34 askCc,
35
36 touch, -- String -> String -> IO ()
37 copy,
38 copyWithHeader,
39
40 -- Temporary-file management
41 setTmpDir,
42 newTempName, newTempLibName,
43 cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
44 addFilesToClean,
45
46 Option(..),
47
48 -- frameworks
49 getPkgFrameworkOpts,
50 getFrameworkOpts
51
52
53 ) where
54
55 #include "HsVersions.h"
56
57 import DriverPhases
58 import Module
59 import Packages
60 import Config
61 import Outputable
62 import ErrUtils
63 import Panic
64 import Platform
65 import Util
66 import DynFlags
67 import Exception
68
69 import Data.IORef
70 import Control.Monad
71 import System.Exit
72 import System.Environment
73 import System.FilePath
74 import System.IO
75 import System.IO.Error as IO
76 import System.Directory
77 import Data.Char
78 import Data.List
79 import qualified Data.Map as Map
80
81 #ifndef mingw32_HOST_OS
82 import qualified System.Posix.Internals
83 #else /* Must be Win32 */
84 import Foreign
85 import Foreign.C.String
86 #endif
87
88 import System.Process
89 import Control.Concurrent
90 import FastString
91 import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
92
93 #ifdef mingw32_HOST_OS
94 # if defined(i386_HOST_ARCH)
95 # define WINDOWS_CCONV stdcall
96 # elif defined(x86_64_HOST_ARCH)
97 # define WINDOWS_CCONV ccall
98 # else
99 # error Unknown mingw32 arch
100 # endif
101 #endif
102
103 {-
104 How GHC finds its files
105 ~~~~~~~~~~~~~~~~~~~~~~~
106
107 [Note topdir]
108
109 GHC needs various support files (library packages, RTS etc), plus
110 various auxiliary programs (cp, gcc, etc). It starts by finding topdir,
111 the root of GHC's support files
112
113 On Unix:
114 - ghc always has a shell wrapper that passes a -B<dir> option
115
116 On Windows:
117 - ghc never has a shell wrapper.
118 - we can find the location of the ghc binary, which is
119 $topdir/bin/<something>.exe
120 where <something> may be "ghc", "ghc-stage2", or similar
121 - we strip off the "bin/<something>.exe" to leave $topdir.
122
123 from topdir we can find package.conf, ghc-asm, etc.
124
125
126 SysTools.initSysProgs figures out exactly where all the auxiliary programs
127 are, and initialises mutable variables to make it easy to call them.
128 To to this, it makes use of definitions in Config.hs, which is a Haskell
129 file containing variables whose value is figured out by the build system.
130
131 Config.hs contains two sorts of things
132
133 cGCC, The *names* of the programs
134 cCPP e.g. cGCC = gcc
135 cUNLIT cCPP = gcc -E
136 etc They do *not* include paths
137
138
139 cUNLIT_DIR The *path* to the directory containing unlit, split etc
140 cSPLIT_DIR *relative* to the root of the build tree,
141 for use when running *in-place* in a build tree (only)
142
143
144
145 ---------------------------------------------
146 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
147
148 Another hair-brained scheme for simplifying the current tool location
149 nightmare in GHC: Simon originally suggested using another
150 configuration file along the lines of GCC's specs file - which is fine
151 except that it means adding code to read yet another configuration
152 file. What I didn't notice is that the current package.conf is
153 general enough to do this:
154
155 Package
156 {name = "tools", import_dirs = [], source_dirs = [],
157 library_dirs = [], hs_libraries = [], extra_libraries = [],
158 include_dirs = [], c_includes = [], package_deps = [],
159 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
160 extra_cc_opts = [], extra_ld_opts = []}
161
162 Which would have the advantage that we get to collect together in one
163 place the path-specific package stuff with the path-specific tool
164 stuff.
165 End of NOTES
166 ---------------------------------------------
167
168 ************************************************************************
169 * *
170 \subsection{Initialisation}
171 * *
172 ************************************************************************
173 -}
174
175 initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
176 -> IO Settings -- Set all the mutable variables above, holding
177 -- (a) the system programs
178 -- (b) the package-config file
179 -- (c) the GHC usage message
180 initSysTools mbMinusB
181 = do top_dir <- findTopDir mbMinusB
182 -- see [Note topdir]
183 -- NB: top_dir is assumed to be in standard Unix
184 -- format, '/' separated
185
186 let settingsFile = top_dir </> "settings"
187 platformConstantsFile = top_dir </> "platformConstants"
188 installed :: FilePath -> FilePath
189 installed file = top_dir </> file
190
191 settingsStr <- readFile settingsFile
192 platformConstantsStr <- readFile platformConstantsFile
193 mySettings <- case maybeReadFuzzy settingsStr of
194 Just s ->
195 return s
196 Nothing ->
197 pgmError ("Can't parse " ++ show settingsFile)
198 platformConstants <- case maybeReadFuzzy platformConstantsStr of
199 Just s ->
200 return s
201 Nothing ->
202 pgmError ("Can't parse " ++
203 show platformConstantsFile)
204 let getSetting key = case lookup key mySettings of
205 Just xs ->
206 return $ case stripPrefix "$topdir" xs of
207 Just [] ->
208 top_dir
209 Just xs'@(c:_)
210 | isPathSeparator c ->
211 top_dir ++ xs'
212 _ ->
213 xs
214 Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
215 getBooleanSetting key = case lookup key mySettings of
216 Just "YES" -> return True
217 Just "NO" -> return False
218 Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)
219 Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
220 readSetting key = case lookup key mySettings of
221 Just xs ->
222 case maybeRead xs of
223 Just v -> return v
224 Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
225 Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
226 crossCompiling <- getBooleanSetting "cross compiling"
227 targetArch <- readSetting "target arch"
228 targetOS <- readSetting "target os"
229 targetWordSize <- readSetting "target word size"
230 targetUnregisterised <- getBooleanSetting "Unregisterised"
231 targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
232 targetHasIdentDirective <- readSetting "target has .ident directive"
233 targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
234 myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
235 -- On Windows, mingw is distributed with GHC,
236 -- so we look in TopDir/../mingw/bin
237 -- It would perhaps be nice to be able to override this
238 -- with the settings file, but it would be a little fiddly
239 -- to make that possible, so for now you can't.
240 gcc_prog <- getSetting "C compiler command"
241 gcc_args_str <- getSetting "C compiler flags"
242 cpp_prog <- getSetting "Haskell CPP command"
243 cpp_args_str <- getSetting "Haskell CPP flags"
244 let unreg_gcc_args = if targetUnregisterised
245 then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
246 else []
247 -- TABLES_NEXT_TO_CODE affects the info table layout.
248 tntc_gcc_args
249 | mkTablesNextToCode targetUnregisterised
250 = ["-DTABLES_NEXT_TO_CODE"]
251 | otherwise = []
252 cpp_args= map Option (words cpp_args_str)
253 gcc_args = map Option (words gcc_args_str
254 ++ unreg_gcc_args
255 ++ tntc_gcc_args)
256 ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
257 ldSupportsBuildId <- getBooleanSetting "ld supports build-id"
258 ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
259 ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
260 perl_path <- getSetting "perl command"
261
262 let pkgconfig_path = installed "package.conf.d"
263 ghc_usage_msg_path = installed "ghc-usage.txt"
264 ghci_usage_msg_path = installed "ghci-usage.txt"
265
266 -- For all systems, unlit, split, mangle are GHC utilities
267 -- architecture-specific stuff is done when building Config.hs
268 unlit_path = installed cGHC_UNLIT_PGM
269
270 -- split is a Perl script
271 split_script = installed cGHC_SPLIT_PGM
272
273 windres_path <- getSetting "windres command"
274 libtool_path <- getSetting "libtool command"
275
276 tmpdir <- getTemporaryDirectory
277
278 touch_path <- getSetting "touch command"
279
280 let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
281 -- a call to Perl to get the invocation of split.
282 -- On Unix, scripts are invoked using the '#!' method. Binary
283 -- installations of GHC on Unix place the correct line on the
284 -- front of the script at installation time, so we don't want
285 -- to wire-in our knowledge of $(PERL) on the host system here.
286 (split_prog, split_args)
287 | isWindowsHost = (perl_path, [Option split_script])
288 | otherwise = (split_script, [])
289 mkdll_prog <- getSetting "dllwrap command"
290 let mkdll_args = []
291
292 -- cpp is derived from gcc on all platforms
293 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
294 -- Config.hs one day.
295
296
297 -- Other things being equal, as and ld are simply gcc
298 gcc_link_args_str <- getSetting "C compiler link flags"
299 let as_prog = gcc_prog
300 as_args = gcc_args
301 ld_prog = gcc_prog
302 ld_args = gcc_args ++ map Option (words gcc_link_args_str)
303
304 -- We just assume on command line
305 lc_prog <- getSetting "LLVM llc command"
306 lo_prog <- getSetting "LLVM opt command"
307
308 let platform = Platform {
309 platformArch = targetArch,
310 platformOS = targetOS,
311 platformWordSize = targetWordSize,
312 platformUnregisterised = targetUnregisterised,
313 platformHasGnuNonexecStack = targetHasGnuNonexecStack,
314 platformHasIdentDirective = targetHasIdentDirective,
315 platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,
316 platformIsCrossCompiling = crossCompiling
317 }
318
319 return $ Settings {
320 sTargetPlatform = platform,
321 sTmpDir = normalise tmpdir,
322 sGhcUsagePath = ghc_usage_msg_path,
323 sGhciUsagePath = ghci_usage_msg_path,
324 sTopDir = top_dir,
325 sRawSettings = mySettings,
326 sExtraGccViaCFlags = words myExtraGccViaCFlags,
327 sSystemPackageConfig = pkgconfig_path,
328 sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
329 sLdSupportsBuildId = ldSupportsBuildId,
330 sLdSupportsFilelist = ldSupportsFilelist,
331 sLdIsGnuLd = ldIsGnuLd,
332 sProgramName = "ghc",
333 sProjectVersion = cProjectVersion,
334 sPgm_L = unlit_path,
335 sPgm_P = (cpp_prog, cpp_args),
336 sPgm_F = "",
337 sPgm_c = (gcc_prog, gcc_args),
338 sPgm_s = (split_prog,split_args),
339 sPgm_a = (as_prog, as_args),
340 sPgm_l = (ld_prog, ld_args),
341 sPgm_dll = (mkdll_prog,mkdll_args),
342 sPgm_T = touch_path,
343 sPgm_windres = windres_path,
344 sPgm_libtool = libtool_path,
345 sPgm_lo = (lo_prog,[]),
346 sPgm_lc = (lc_prog,[]),
347 sOpt_L = [],
348 sOpt_P = [],
349 sOpt_F = [],
350 sOpt_c = [],
351 sOpt_a = [],
352 sOpt_l = [],
353 sOpt_windres = [],
354 sOpt_lo = [],
355 sOpt_lc = [],
356 sPlatformConstants = platformConstants
357 }
358
359 -- returns a Unix-format path (relying on getBaseDir to do so too)
360 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
361 -> IO String -- TopDir (in Unix format '/' separated)
362 findTopDir (Just minusb) = return (normalise minusb)
363 findTopDir Nothing
364 = do -- Get directory of executable
365 maybe_exec_dir <- getBaseDir
366 case maybe_exec_dir of
367 -- "Just" on Windows, "Nothing" on unix
368 Nothing -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
369 Just dir -> return dir
370
371 {-
372 ************************************************************************
373 * *
374 \subsection{Running an external program}
375 * *
376 ************************************************************************
377 -}
378
379 runUnlit :: DynFlags -> [Option] -> IO ()
380 runUnlit dflags args = do
381 let prog = pgm_L dflags
382 opts = getOpts dflags opt_L
383 runSomething dflags "Literate pre-processor" prog
384 (map Option opts ++ args)
385
386 runCpp :: DynFlags -> [Option] -> IO ()
387 runCpp dflags args = do
388 let (p,args0) = pgm_P dflags
389 args1 = map Option (getOpts dflags opt_P)
390 args2 = if gopt Opt_WarnIsError dflags
391 then [Option "-Werror"]
392 else []
393 mb_env <- getGccEnv args2
394 runSomethingFiltered dflags id "C pre-processor" p
395 (args0 ++ args1 ++ args2 ++ args) mb_env
396
397 runPp :: DynFlags -> [Option] -> IO ()
398 runPp dflags args = do
399 let prog = pgm_F dflags
400 opts = map Option (getOpts dflags opt_F)
401 runSomething dflags "Haskell pre-processor" prog (args ++ opts)
402
403 runCc :: DynFlags -> [Option] -> IO ()
404 runCc dflags args = do
405 let (p,args0) = pgm_c dflags
406 args1 = map Option (getOpts dflags opt_c)
407 args2 = args0 ++ args1 ++ args
408 mb_env <- getGccEnv args2
409 runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env
410 where
411 -- discard some harmless warnings from gcc that we can't turn off
412 cc_filter = unlines . doFilter . lines
413
414 {-
415 gcc gives warnings in chunks like so:
416 In file included from /foo/bar/baz.h:11,
417 from /foo/bar/baz2.h:22,
418 from wibble.c:33:
419 /foo/flibble:14: global register variable ...
420 /foo/flibble:15: warning: call-clobbered r...
421 We break it up into its chunks, remove any call-clobbered register
422 warnings from each chunk, and then delete any chunks that we have
423 emptied of warnings.
424 -}
425 doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
426 -- We can't assume that the output will start with an "In file inc..."
427 -- line, so we start off expecting a list of warnings rather than a
428 -- location stack.
429 chunkWarnings :: [String] -- The location stack to use for the next
430 -- list of warnings
431 -> [String] -- The remaining lines to look at
432 -> [([String], [String])]
433 chunkWarnings loc_stack [] = [(loc_stack, [])]
434 chunkWarnings loc_stack xs
435 = case break loc_stack_start xs of
436 (warnings, lss:xs') ->
437 case span loc_start_continuation xs' of
438 (lsc, xs'') ->
439 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
440 _ -> [(loc_stack, xs)]
441
442 filterWarnings :: [([String], [String])] -> [([String], [String])]
443 filterWarnings [] = []
444 -- If the warnings are already empty then we are probably doing
445 -- something wrong, so don't delete anything
446 filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
447 filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
448 [] -> filterWarnings zs
449 ys' -> (xs, ys') : filterWarnings zs
450
451 unChunkWarnings :: [([String], [String])] -> [String]
452 unChunkWarnings [] = []
453 unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
454
455 loc_stack_start s = "In file included from " `isPrefixOf` s
456 loc_start_continuation s = " from " `isPrefixOf` s
457 wantedWarning w
458 | "warning: call-clobbered register used" `isContainedIn` w = False
459 | otherwise = True
460
461 isContainedIn :: String -> String -> Bool
462 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
463
464 askCc :: DynFlags -> [Option] -> IO String
465 askCc dflags args = do
466 let (p,args0) = pgm_c dflags
467 args1 = map Option (getOpts dflags opt_c)
468 args2 = args0 ++ args1 ++ args
469 mb_env <- getGccEnv args2
470 runSomethingWith dflags "gcc" p args2 $ \real_args ->
471 readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
472
473 -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
474 -- inherited from the parent process, and output to stderr is not captured.
475 readCreateProcessWithExitCode'
476 :: CreateProcess
477 -> IO (ExitCode, String) -- ^ stdout
478 readCreateProcessWithExitCode' proc = do
479 (_, Just outh, _, pid) <-
480 createProcess proc{ std_out = CreatePipe }
481
482 -- fork off a thread to start consuming the output
483 output <- hGetContents outh
484 outMVar <- newEmptyMVar
485 _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
486
487 -- wait on the output
488 takeMVar outMVar
489 hClose outh
490
491 -- wait on the process
492 ex <- waitForProcess pid
493
494 return (ex, output)
495
496 readProcessEnvWithExitCode
497 :: String -- ^ program path
498 -> [String] -- ^ program args
499 -> [(String, String)] -- ^ environment to override
500 -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
501 readProcessEnvWithExitCode prog args env_update = do
502 current_env <- getEnvironment
503 let new_env = env_update ++ [ (k, v)
504 | let overriden_keys = map fst env_update
505 , (k, v) <- current_env
506 , k `notElem` overriden_keys
507 ]
508 p = proc prog args
509
510 (_stdin, Just stdoh, Just stdeh, pid) <-
511 createProcess p{ std_out = CreatePipe
512 , std_err = CreatePipe
513 , env = Just new_env
514 }
515
516 outMVar <- newEmptyMVar
517 errMVar <- newEmptyMVar
518
519 _ <- forkIO $ do
520 stdo <- hGetContents stdoh
521 _ <- evaluate (length stdo)
522 putMVar outMVar stdo
523
524 _ <- forkIO $ do
525 stde <- hGetContents stdeh
526 _ <- evaluate (length stde)
527 putMVar errMVar stde
528
529 out <- takeMVar outMVar
530 hClose stdoh
531 err <- takeMVar errMVar
532 hClose stdeh
533
534 ex <- waitForProcess pid
535
536 return (ex, out, err)
537
538 -- Don't let gcc localize version info string, #8825
539 en_locale_env :: [(String, String)]
540 en_locale_env = [("LANGUAGE", "en")]
541
542 -- If the -B<dir> option is set, add <dir> to PATH. This works around
543 -- a bug in gcc on Windows Vista where it can't find its auxiliary
544 -- binaries (see bug #1110).
545 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
546 getGccEnv opts =
547 if null b_dirs
548 then return Nothing
549 else do env <- getEnvironment
550 return (Just (map mangle_path env))
551 where
552 (b_dirs, _) = partitionWith get_b_opt opts
553
554 get_b_opt (Option ('-':'B':dir)) = Left dir
555 get_b_opt other = Right other
556
557 mangle_path (path,paths) | map toUpper path == "PATH"
558 = (path, '\"' : head b_dirs ++ "\";" ++ paths)
559 mangle_path other = other
560
561 runSplit :: DynFlags -> [Option] -> IO ()
562 runSplit dflags args = do
563 let (p,args0) = pgm_s dflags
564 runSomething dflags "Splitter" p (args0++args)
565
566 runAs :: DynFlags -> [Option] -> IO ()
567 runAs dflags args = do
568 let (p,args0) = pgm_a dflags
569 args1 = map Option (getOpts dflags opt_a)
570 args2 = args0 ++ args1 ++ args
571 mb_env <- getGccEnv args2
572 runSomethingFiltered dflags id "Assembler" p args2 mb_env
573
574 -- | Run the LLVM Optimiser
575 runLlvmOpt :: DynFlags -> [Option] -> IO ()
576 runLlvmOpt dflags args = do
577 let (p,args0) = pgm_lo dflags
578 args1 = map Option (getOpts dflags opt_lo)
579 runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args)
580
581 -- | Run the LLVM Compiler
582 runLlvmLlc :: DynFlags -> [Option] -> IO ()
583 runLlvmLlc dflags args = do
584 let (p,args0) = pgm_lc dflags
585 args1 = map Option (getOpts dflags opt_lc)
586 runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
587
588 -- | Run the clang compiler (used as an assembler for the LLVM
589 -- backend on OS X as LLVM doesn't support the OS X system
590 -- assembler)
591 runClang :: DynFlags -> [Option] -> IO ()
592 runClang dflags args = do
593 -- we simply assume its available on the PATH
594 let clang = "clang"
595 -- be careful what options we call clang with
596 -- see #5903 and #7617 for bugs caused by this.
597 (_,args0) = pgm_a dflags
598 args1 = map Option (getOpts dflags opt_a)
599 args2 = args0 ++ args1 ++ args
600 mb_env <- getGccEnv args2
601 Exception.catch (do
602 runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env
603 )
604 (\(err :: SomeException) -> do
605 errorMsg dflags $
606 text ("Error running clang! you need clang installed to use the" ++
607 " LLVM backend") $+$
608 text "(or GHC tried to execute clang incorrectly)"
609 throwIO err
610 )
611
612 -- | Figure out which version of LLVM we are running this session
613 figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))
614 figureLlvmVersion dflags = do
615 let (pgm,opts) = pgm_lc dflags
616 args = filter notNull (map showOpt opts)
617 -- we grab the args even though they should be useless just in
618 -- case the user is using a customised 'llc' that requires some
619 -- of the options they've specified. llc doesn't care what other
620 -- options are specified when '-version' is used.
621 args' = args ++ ["-version"]
622 ver <- catchIO (do
623 (pin, pout, perr, _) <- runInteractiveProcess pgm args'
624 Nothing Nothing
625 {- > llc -version
626 LLVM (http://llvm.org/):
627 LLVM version 3.5.2
628 ...
629 -}
630 hSetBinaryMode pout False
631 _ <- hGetLine pout
632 vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
633 v <- case span (/= '.') vline of
634 ("",_) -> fail "no digits!"
635 (x,y) -> return (read x
636 , read $ takeWhile isDigit $ drop 1 y)
637
638 hClose pin
639 hClose pout
640 hClose perr
641 return $ Just v
642 )
643 (\err -> do
644 debugTraceMsg dflags 2
645 (text "Error (figuring out LLVM version):" <+>
646 text (show err))
647 errorMsg dflags $ vcat
648 [ text "Warning:", nest 9 $
649 text "Couldn't figure out LLVM version!" $$
650 text "Make sure you have installed LLVM"]
651 return Nothing)
652 return ver
653
654 {- Note [Windows stack usage]
655
656 See: Trac #8870 (and #8834 for related info)
657
658 On Windows, occasionally we need to grow the stack. In order to do
659 this, we would normally just bump the stack pointer - but there's a
660 catch on Windows.
661
662 If the stack pointer is bumped by more than a single page, then the
663 pages between the initial pointer and the resulting location must be
664 properly committed by the Windows virtual memory subsystem. This is
665 only needed in the event we bump by more than one page (i.e 4097 bytes
666 or more).
667
668 Windows compilers solve this by emitting a call to a special function
669 called _chkstk, which does this committing of the pages for you.
670
671 The reason this was causing a segfault was because due to the fact the
672 new code generator tends to generate larger functions, we needed more
673 stack space in GHC itself. In the x86 codegen, we needed approximately
674 ~12kb of stack space in one go, which caused the process to segfault,
675 as the intervening pages were not committed.
676
677 In the future, we should do the same thing, to make the problem
678 completely go away. In the mean time, we're using a workaround: we
679 instruct the linker to specify the generated PE as having an initial
680 reserved stack size of 8mb, as well as a initial *committed* stack
681 size of 8mb. The default committed size was previously only 4k.
682
683 Theoretically it's possible to still hit this problem if you request a
684 stack bump of more than 8mb in one go. But the amount of code
685 necessary is quite large, and 8mb "should be more than enough for
686 anyone" right now (he said, before millions of lines of code cried out
687 in terror).
688
689 -}
690
691 {- Note [Run-time linker info]
692
693 See also: Trac #5240, Trac #6063, Trac #10110
694
695 Before 'runLink', we need to be sure to get the relevant information
696 about the linker we're using at runtime to see if we need any extra
697 options. For example, GNU ld requires '--reduce-memory-overheads' and
698 '--hash-size=31' in order to use reasonable amounts of memory (see
699 trac #5240.) But this isn't supported in GNU gold.
700
701 Generally, the linker changing from what was detected at ./configure
702 time has always been possible using -pgml, but on Linux it can happen
703 'transparently' by installing packages like binutils-gold, which
704 change what /usr/bin/ld actually points to.
705
706 Clang vs GCC notes:
707
708 For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
709 invoke the linker before the version information string. For 'clang',
710 the version information for 'ld' is all that's output. For this
711 reason, we typically need to slurp up all of the standard error output
712 and look through it.
713
714 Other notes:
715
716 We cache the LinkerInfo inside DynFlags, since clients may link
717 multiple times. The definition of LinkerInfo is there to avoid a
718 circular dependency.
719
720 -}
721
722 {- Note [ELF needed shared libs]
723
724 Some distributions change the link editor's default handling of
725 ELF DT_NEEDED tags to include only those shared objects that are
726 needed to resolve undefined symbols. For Template Haskell we need
727 the last temporary shared library also if it is not needed for the
728 currently linked temporary shared library. We specify --no-as-needed
729 to override the default. This flag exists in GNU ld and GNU gold.
730
731 The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
732 (Mach-O) the flag is not needed.
733
734 -}
735
736 {- Note [Windows static libGCC]
737
738 The GCC versions being upgraded to in #10726 are configured with
739 dynamic linking of libgcc supported. This results in libgcc being
740 linked dynamically when a shared library is created.
741
742 This introduces thus an extra dependency on GCC dll that was not
743 needed before by shared libraries created with GHC. This is a particular
744 issue on Windows because you get a non-obvious error due to this missing
745 dependency. This dependent dll is also not commonly on your path.
746
747 For this reason using the static libgcc is preferred as it preserves
748 the same behaviour that existed before. There are however some very good
749 reasons to have the shared version as well as described on page 181 of
750 https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :
751
752 "There are several situations in which an application should use the
753 shared ‘libgcc’ instead of the static version. The most common of these
754 is when the application wishes to throw and catch exceptions across different
755 shared libraries. In that case, each of the libraries as well as the application
756 itself should use the shared ‘libgcc’. "
757
758 -}
759
760 neededLinkArgs :: LinkerInfo -> [Option]
761 neededLinkArgs (GnuLD o) = o
762 neededLinkArgs (GnuGold o) = o
763 neededLinkArgs (DarwinLD o) = o
764 neededLinkArgs (SolarisLD o) = o
765 neededLinkArgs (AixLD o) = o
766 neededLinkArgs UnknownLD = []
767
768 -- Grab linker info and cache it in DynFlags.
769 getLinkerInfo :: DynFlags -> IO LinkerInfo
770 getLinkerInfo dflags = do
771 info <- readIORef (rtldInfo dflags)
772 case info of
773 Just v -> return v
774 Nothing -> do
775 v <- getLinkerInfo' dflags
776 writeIORef (rtldInfo dflags) (Just v)
777 return v
778
779 -- See Note [Run-time linker info].
780 getLinkerInfo' :: DynFlags -> IO LinkerInfo
781 getLinkerInfo' dflags = do
782 let platform = targetPlatform dflags
783 os = platformOS platform
784 (pgm,args0) = pgm_l dflags
785 args1 = map Option (getOpts dflags opt_l)
786 args2 = args0 ++ args1
787 args3 = filter notNull (map showOpt args2)
788
789 -- Try to grab the info from the process output.
790 parseLinkerInfo stdo _stde _exitc
791 | any ("GNU ld" `isPrefixOf`) stdo =
792 -- GNU ld specifically needs to use less memory. This especially
793 -- hurts on small object files. Trac #5240.
794 -- Set DT_NEEDED for all shared libraries. Trac #10110.
795 -- TODO: Investigate if these help or hurt when using split sections.
796 return (GnuLD $ map Option ["-Wl,--hash-size=31",
797 "-Wl,--reduce-memory-overheads",
798 -- ELF specific flag
799 -- see Note [ELF needed shared libs]
800 "-Wl,--no-as-needed"])
801
802 | any ("GNU gold" `isPrefixOf`) stdo =
803 -- GNU gold only needs --no-as-needed. Trac #10110.
804 -- ELF specific flag, see Note [ELF needed shared libs]
805 return (GnuGold [Option "-Wl,--no-as-needed"])
806
807 -- Unknown linker.
808 | otherwise = fail "invalid --version output, or linker is unsupported"
809
810 -- Process the executable call
811 info <- catchIO (do
812 case os of
813 OSSolaris2 ->
814 -- Solaris uses its own Solaris linker. Even all
815 -- GNU C are recommended to configure with Solaris
816 -- linker instead of using GNU binutils linker. Also
817 -- all GCC distributed with Solaris follows this rule
818 -- precisely so we assume here, the Solaris linker is
819 -- used.
820 return $ SolarisLD []
821 OSAIX ->
822 -- IBM AIX uses its own non-binutils linker as well
823 return $ AixLD []
824 OSDarwin ->
825 -- Darwin has neither GNU Gold or GNU LD, but a strange linker
826 -- that doesn't support --version. We can just assume that's
827 -- what we're using.
828 return $ DarwinLD []
829 OSiOS ->
830 -- Ditto for iOS
831 return $ DarwinLD []
832 OSMinGW32 ->
833 -- GHC doesn't support anything but GNU ld on Windows anyway.
834 -- Process creation is also fairly expensive on win32, so
835 -- we short-circuit here.
836 return $ GnuLD $ map Option
837 [ -- Reduce ld memory usage
838 "-Wl,--hash-size=31"
839 , "-Wl,--reduce-memory-overheads"
840 -- Increase default stack, see
841 -- Note [Windows stack usage]
842 -- Force static linking of libGCC
843 -- Note [Windows static libGCC]
844 , "-Xlinker", "--stack=0x800000,0x800000", "-static-libgcc" ]
845 _ -> do
846 -- In practice, we use the compiler as the linker here. Pass
847 -- -Wl,--version to get linker version info.
848 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
849 (["-Wl,--version"] ++ args3)
850 en_locale_env
851 -- Split the output by lines to make certain kinds
852 -- of processing easier. In particular, 'clang' and 'gcc'
853 -- have slightly different outputs for '-Wl,--version', but
854 -- it's still easy to figure out.
855 parseLinkerInfo (lines stdo) (lines stde) exitc
856 )
857 (\err -> do
858 debugTraceMsg dflags 2
859 (text "Error (figuring out linker information):" <+>
860 text (show err))
861 errorMsg dflags $ hang (text "Warning:") 9 $
862 text "Couldn't figure out linker information!" $$
863 text "Make sure you're using GNU ld, GNU gold" <+>
864 text "or the built in OS X linker, etc."
865 return UnknownLD)
866 return info
867
868 -- Grab compiler info and cache it in DynFlags.
869 getCompilerInfo :: DynFlags -> IO CompilerInfo
870 getCompilerInfo dflags = do
871 info <- readIORef (rtccInfo dflags)
872 case info of
873 Just v -> return v
874 Nothing -> do
875 v <- getCompilerInfo' dflags
876 writeIORef (rtccInfo dflags) (Just v)
877 return v
878
879 -- See Note [Run-time linker info].
880 getCompilerInfo' :: DynFlags -> IO CompilerInfo
881 getCompilerInfo' dflags = do
882 let (pgm,_) = pgm_c dflags
883 -- Try to grab the info from the process output.
884 parseCompilerInfo _stdo stde _exitc
885 -- Regular GCC
886 | any ("gcc version" `isInfixOf`) stde =
887 return GCC
888 -- Regular clang
889 | any ("clang version" `isInfixOf`) stde =
890 return Clang
891 -- XCode 5.1 clang
892 | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
893 return AppleClang51
894 -- XCode 5 clang
895 | any ("Apple LLVM version" `isPrefixOf`) stde =
896 return AppleClang
897 -- XCode 4.1 clang
898 | any ("Apple clang version" `isPrefixOf`) stde =
899 return AppleClang
900 -- Unknown linker.
901 | otherwise = fail "invalid -v output, or compiler is unsupported"
902
903 -- Process the executable call
904 info <- catchIO (do
905 (exitc, stdo, stde) <-
906 readProcessEnvWithExitCode pgm ["-v"] en_locale_env
907 -- Split the output by lines to make certain kinds
908 -- of processing easier.
909 parseCompilerInfo (lines stdo) (lines stde) exitc
910 )
911 (\err -> do
912 debugTraceMsg dflags 2
913 (text "Error (figuring out C compiler information):" <+>
914 text (show err))
915 errorMsg dflags $ hang (text "Warning:") 9 $
916 text "Couldn't figure out C compiler information!" $$
917 text "Make sure you're using GNU gcc, or clang"
918 return UnknownCC)
919 return info
920
921 runLink :: DynFlags -> [Option] -> IO ()
922 runLink dflags args = do
923 -- See Note [Run-time linker info]
924 linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
925 let (p,args0) = pgm_l dflags
926 args1 = map Option (getOpts dflags opt_l)
927 args2 = args0 ++ linkargs ++ args1 ++ args
928 mb_env <- getGccEnv args2
929 runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
930 where
931 ld_filter = case (platformOS (targetPlatform dflags)) of
932 OSSolaris2 -> sunos_ld_filter
933 _ -> id
934 {-
935 SunOS/Solaris ld emits harmless warning messages about unresolved
936 symbols in case of compiling into shared library when we do not
937 link against all the required libs. That is the case of GHC which
938 does not link against RTS library explicitly in order to be able to
939 choose the library later based on binary application linking
940 parameters. The warnings look like:
941
942 Undefined first referenced
943 symbol in file
944 stg_ap_n_fast ./T2386_Lib.o
945 stg_upd_frame_info ./T2386_Lib.o
946 templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
947 templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
948 templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
949 templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
950 newCAF ./T2386_Lib.o
951 stg_bh_upd_frame_info ./T2386_Lib.o
952 stg_ap_ppp_fast ./T2386_Lib.o
953 templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
954 stg_ap_p_fast ./T2386_Lib.o
955 stg_ap_pp_fast ./T2386_Lib.o
956 ld: warning: symbol referencing errors
957
958 this is actually coming from T2386 testcase. The emitting of those
959 warnings is also a reason why so many TH testcases fail on Solaris.
960
961 Following filter code is SunOS/Solaris linker specific and should
962 filter out only linker warnings. Please note that the logic is a
963 little bit more complex due to the simple reason that we need to preserve
964 any other linker emitted messages. If there are any. Simply speaking
965 if we see "Undefined" and later "ld: warning:..." then we omit all
966 text between (including) the marks. Otherwise we copy the whole output.
967 -}
968 sunos_ld_filter :: String -> String
969 sunos_ld_filter = unlines . sunos_ld_filter' . lines
970 sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
971 then (ld_prefix x) ++ (ld_postfix x)
972 else x
973 breakStartsWith x y = break (isPrefixOf x) y
974 ld_prefix = fst . breakStartsWith "Undefined"
975 undefined_found = not . null . snd . breakStartsWith "Undefined"
976 ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
977 ld_postfix = tail . snd . ld_warn_break
978 ld_warning_found = not . null . snd . ld_warn_break
979
980
981 runLibtool :: DynFlags -> [Option] -> IO ()
982 runLibtool dflags args = do
983 linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
984 let args1 = map Option (getOpts dflags opt_l)
985 args2 = [Option "-static"] ++ args1 ++ args ++ linkargs
986 libtool = pgm_libtool dflags
987 mb_env <- getGccEnv args2
988 runSomethingFiltered dflags id "Linker" libtool args2 mb_env
989
990 runMkDLL :: DynFlags -> [Option] -> IO ()
991 runMkDLL dflags args = do
992 let (p,args0) = pgm_dll dflags
993 args1 = args0 ++ args
994 mb_env <- getGccEnv (args0++args)
995 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
996
997 runWindres :: DynFlags -> [Option] -> IO ()
998 runWindres dflags args = do
999 let (gcc, gcc_args) = pgm_c dflags
1000 windres = pgm_windres dflags
1001 opts = map Option (getOpts dflags opt_windres)
1002 quote x = "\"" ++ x ++ "\""
1003 args' = -- If windres.exe and gcc.exe are in a directory containing
1004 -- spaces then windres fails to run gcc. We therefore need
1005 -- to tell it what command to use...
1006 Option ("--preprocessor=" ++
1007 unwords (map quote (gcc :
1008 map showOpt gcc_args ++
1009 map showOpt opts ++
1010 ["-E", "-xc", "-DRC_INVOKED"])))
1011 -- ...but if we do that then if windres calls popen then
1012 -- it can't understand the quoting, so we have to use
1013 -- --use-temp-file so that it interprets it correctly.
1014 -- See #1828.
1015 : Option "--use-temp-file"
1016 : args
1017 mb_env <- getGccEnv gcc_args
1018 runSomethingFiltered dflags id "Windres" windres args' mb_env
1019
1020 touch :: DynFlags -> String -> String -> IO ()
1021 touch dflags purpose arg =
1022 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
1023
1024 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
1025 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
1026
1027 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
1028 -> IO ()
1029 copyWithHeader dflags purpose maybe_header from to = do
1030 showPass dflags purpose
1031
1032 hout <- openBinaryFile to WriteMode
1033 hin <- openBinaryFile from ReadMode
1034 ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
1035 maybe (return ()) (header hout) maybe_header
1036 hPutStr hout ls
1037 hClose hout
1038 hClose hin
1039 where
1040 -- write the header string in UTF-8. The header is something like
1041 -- {-# LINE "foo.hs" #-}
1042 -- and we want to make sure a Unicode filename isn't mangled.
1043 header h str = do
1044 hSetEncoding h utf8
1045 hPutStr h str
1046 hSetBinaryMode h True
1047
1048
1049
1050 {-
1051 ************************************************************************
1052 * *
1053 \subsection{Managing temporary files
1054 * *
1055 ************************************************************************
1056 -}
1057
1058 cleanTempDirs :: DynFlags -> IO ()
1059 cleanTempDirs dflags
1060 = unless (gopt Opt_KeepTmpFiles dflags)
1061 $ mask_
1062 $ do let ref = dirsToClean dflags
1063 ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
1064 removeTmpDirs dflags (Map.elems ds)
1065
1066 cleanTempFiles :: DynFlags -> IO ()
1067 cleanTempFiles dflags
1068 = unless (gopt Opt_KeepTmpFiles dflags)
1069 $ mask_
1070 $ do let ref = filesToClean dflags
1071 fs <- atomicModifyIORef' ref $ \fs -> ([],fs)
1072 removeTmpFiles dflags fs
1073
1074 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
1075 cleanTempFilesExcept dflags dont_delete
1076 = unless (gopt Opt_KeepTmpFiles dflags)
1077 $ mask_
1078 $ do let ref = filesToClean dflags
1079 to_delete <- atomicModifyIORef' ref $ \files ->
1080 let (to_keep,to_delete) = partition (`elem` dont_delete) files
1081 in (to_keep,to_delete)
1082 removeTmpFiles dflags to_delete
1083
1084
1085 -- Return a unique numeric temp file suffix
1086 newTempSuffix :: DynFlags -> IO Int
1087 newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
1088
1089 -- Find a temporary name that doesn't already exist.
1090 newTempName :: DynFlags -> Suffix -> IO FilePath
1091 newTempName dflags extn
1092 = do d <- getTempDir dflags
1093 findTempName (d </> "ghc_") -- See Note [Deterministic base name]
1094 where
1095 findTempName :: FilePath -> IO FilePath
1096 findTempName prefix
1097 = do n <- newTempSuffix dflags
1098 let filename = prefix ++ show n <.> extn
1099 b <- doesFileExist filename
1100 if b then findTempName prefix
1101 else do -- clean it up later
1102 consIORef (filesToClean dflags) filename
1103 return filename
1104
1105 newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String)
1106 newTempLibName dflags extn
1107 = do d <- getTempDir dflags
1108 findTempName d ("ghc_")
1109 where
1110 findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
1111 findTempName dir prefix
1112 = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
1113 let libname = prefix ++ show n
1114 filename = dir </> "lib" ++ libname <.> extn
1115 b <- doesFileExist filename
1116 if b then findTempName dir prefix
1117 else do -- clean it up later
1118 consIORef (filesToClean dflags) filename
1119 return (filename, dir, libname)
1120
1121
1122 -- Return our temporary directory within tmp_dir, creating one if we
1123 -- don't have one yet.
1124 getTempDir :: DynFlags -> IO FilePath
1125 getTempDir dflags = do
1126 mapping <- readIORef dir_ref
1127 case Map.lookup tmp_dir mapping of
1128 Nothing -> do
1129 pid <- getProcessID
1130 let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
1131 mask_ $ mkTempDir prefix
1132 Just dir -> return dir
1133 where
1134 tmp_dir = tmpDir dflags
1135 dir_ref = dirsToClean dflags
1136
1137 mkTempDir :: FilePath -> IO FilePath
1138 mkTempDir prefix = do
1139 n <- newTempSuffix dflags
1140 let our_dir = prefix ++ show n
1141
1142 -- 1. Speculatively create our new directory.
1143 createDirectory our_dir
1144
1145 -- 2. Update the dirsToClean mapping unless an entry already exists
1146 -- (i.e. unless another thread beat us to it).
1147 their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
1148 case Map.lookup tmp_dir mapping of
1149 Just dir -> (mapping, Just dir)
1150 Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing)
1151
1152 -- 3. If there was an existing entry, return it and delete the
1153 -- directory we created. Otherwise return the directory we created.
1154 case their_dir of
1155 Nothing -> do
1156 debugTraceMsg dflags 2 $
1157 text "Created temporary directory:" <+> text our_dir
1158 return our_dir
1159 Just dir -> do
1160 removeDirectory our_dir
1161 return dir
1162 `catchIO` \e -> if isAlreadyExistsError e
1163 then mkTempDir prefix else ioError e
1164
1165 -- Note [Deterministic base name]
1166 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1167 --
1168 -- The filename of temporary files, especially the basename of C files, can end
1169 -- up in the output in some form, e.g. as part of linker debug information. In the
1170 -- interest of bit-wise exactly reproducible compilation (#4012), the basename of
1171 -- the temporary file no longer contains random information (it used to contain
1172 -- the process id).
1173 --
1174 -- This is ok, as the temporary directory used contains the pid (see getTempDir).
1175
1176 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
1177 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
1178 addFilesToClean dflags new_files
1179 = atomicModifyIORef' (filesToClean dflags) $ \files -> (new_files++files, ())
1180
1181 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
1182 removeTmpDirs dflags ds
1183 = traceCmd dflags "Deleting temp dirs"
1184 ("Deleting: " ++ unwords ds)
1185 (mapM_ (removeWith dflags removeDirectory) ds)
1186
1187 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
1188 removeTmpFiles dflags fs
1189 = warnNon $
1190 traceCmd dflags "Deleting temp files"
1191 ("Deleting: " ++ unwords deletees)
1192 (mapM_ (removeWith dflags removeFile) deletees)
1193 where
1194 -- Flat out refuse to delete files that are likely to be source input
1195 -- files (is there a worse bug than having a compiler delete your source
1196 -- files?)
1197 --
1198 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
1199 -- the condition.
1200 warnNon act
1201 | null non_deletees = act
1202 | otherwise = do
1203 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
1204 act
1205
1206 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
1207
1208 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
1209 removeWith dflags remover f = remover f `catchIO`
1210 (\e ->
1211 let msg = if isDoesNotExistError e
1212 then ptext (sLit "Warning: deleting non-existent") <+> text f
1213 else ptext (sLit "Warning: exception raised when deleting")
1214 <+> text f <> colon
1215 $$ text (show e)
1216 in debugTraceMsg dflags 2 msg
1217 )
1218
1219 -----------------------------------------------------------------------------
1220 -- Running an external program
1221
1222 runSomething :: DynFlags
1223 -> String -- For -v message
1224 -> String -- Command name (possibly a full path)
1225 -- assumed already dos-ified
1226 -> [Option] -- Arguments
1227 -- runSomething will dos-ify them
1228 -> IO ()
1229
1230 runSomething dflags phase_name pgm args =
1231 runSomethingFiltered dflags id phase_name pgm args Nothing
1232
1233 -- | Run a command, placing the arguments in an external response file.
1234 --
1235 -- This command is used in order to avoid overlong command line arguments on
1236 -- Windows. The command line arguments are first written to an external,
1237 -- temporary response file, and then passed to the linker via @filepath.
1238 -- response files for passing them in. See:
1239 --
1240 -- https://gcc.gnu.org/wiki/Response_Files
1241 -- https://ghc.haskell.org/trac/ghc/ticket/10777
1242 runSomethingResponseFile
1243 :: DynFlags -> (String->String) -> String -> String -> [Option]
1244 -> Maybe [(String,String)] -> IO ()
1245
1246 runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
1247 runSomethingWith dflags phase_name pgm args $ \real_args -> do
1248 fp <- getResponseFile real_args
1249 let args = ['@':fp]
1250 r <- builderMainLoop dflags filter_fn pgm args mb_env
1251 return (r,())
1252 where
1253 getResponseFile args = do
1254 fp <- newTempName dflags "rsp"
1255 withFile fp WriteMode $ \h -> do
1256 hSetEncoding h utf8
1257 hPutStr h $ unlines $ map escape args
1258 return fp
1259
1260 -- Note: Response files have backslash-escaping, double quoting, and are
1261 -- whitespace separated (some implementations use newline, others any
1262 -- whitespace character). Therefore, escape any backslashes, newlines, and
1263 -- double quotes in the argument, and surround the content with double
1264 -- quotes.
1265 --
1266 -- Another possibility that could be considered would be to convert
1267 -- backslashes in the argument to forward slashes. This would generally do
1268 -- the right thing, since backslashes in general only appear in arguments
1269 -- as part of file paths on Windows, and the forward slash is accepted for
1270 -- those. However, escaping is more reliable, in case somehow a backslash
1271 -- appears in a non-file.
1272 escape x = concat
1273 [ "\""
1274 , concatMap
1275 (\c ->
1276 case c of
1277 '\\' -> "\\\\"
1278 '\n' -> "\\n"
1279 '\"' -> "\\\""
1280 _ -> [c])
1281 x
1282 , "\""
1283 ]
1284
1285 runSomethingFiltered
1286 :: DynFlags -> (String->String) -> String -> String -> [Option]
1287 -> Maybe [(String,String)] -> IO ()
1288
1289 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
1290 runSomethingWith dflags phase_name pgm args $ \real_args -> do
1291 r <- builderMainLoop dflags filter_fn pgm real_args mb_env
1292 return (r,())
1293
1294 runSomethingWith
1295 :: DynFlags -> String -> String -> [Option]
1296 -> ([String] -> IO (ExitCode, a))
1297 -> IO a
1298
1299 runSomethingWith dflags phase_name pgm args io = do
1300 let real_args = filter notNull (map showOpt args)
1301 cmdLine = showCommandForUser pgm real_args
1302 traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
1303
1304 handleProc :: String -> String -> IO (ExitCode, r) -> IO r
1305 handleProc pgm phase_name proc = do
1306 (rc, r) <- proc `catchIO` handler
1307 case rc of
1308 ExitSuccess{} -> return r
1309 ExitFailure n -> throwGhcExceptionIO (
1310 ProgramError ("`" ++ takeFileName pgm ++ "'" ++
1311 " failed in phase `" ++ phase_name ++ "'." ++
1312 " (Exit code: " ++ show n ++ ")"))
1313 where
1314 handler err =
1315 if IO.isDoesNotExistError err
1316 then does_not_exist
1317 else throwGhcExceptionIO (ProgramError $ show err)
1318
1319 does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
1320
1321
1322 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
1323 -> [String] -> Maybe [(String, String)]
1324 -> IO ExitCode
1325 builderMainLoop dflags filter_fn pgm real_args mb_env = do
1326 chan <- newChan
1327 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
1328
1329 -- and run a loop piping the output from the compiler to the log_action in DynFlags
1330 hSetBuffering hStdOut LineBuffering
1331 hSetBuffering hStdErr LineBuffering
1332 _ <- forkIO (readerProc chan hStdOut filter_fn)
1333 _ <- forkIO (readerProc chan hStdErr filter_fn)
1334 -- we don't want to finish until 2 streams have been completed
1335 -- (stdout and stderr)
1336 -- nor until 1 exit code has been retrieved.
1337 rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
1338 -- after that, we're done here.
1339 hClose hStdIn
1340 hClose hStdOut
1341 hClose hStdErr
1342 return rc
1343 where
1344 -- status starts at zero, and increments each time either
1345 -- a reader process gets EOF, or the build proc exits. We wait
1346 -- for all of these to happen (status==3).
1347 -- ToDo: we should really have a contingency plan in case any of
1348 -- the threads dies, such as a timeout.
1349 loop _ _ 0 0 exitcode = return exitcode
1350 loop chan hProcess t p exitcode = do
1351 mb_code <- if p > 0
1352 then getProcessExitCode hProcess
1353 else return Nothing
1354 case mb_code of
1355 Just code -> loop chan hProcess t (p-1) code
1356 Nothing
1357 | t > 0 -> do
1358 msg <- readChan chan
1359 case msg of
1360 BuildMsg msg -> do
1361 log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
1362 loop chan hProcess t p exitcode
1363 BuildError loc msg -> do
1364 log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
1365 loop chan hProcess t p exitcode
1366 EOF ->
1367 loop chan hProcess (t-1) p exitcode
1368 | otherwise -> loop chan hProcess t p exitcode
1369
1370 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
1371 readerProc chan hdl filter_fn =
1372 (do str <- hGetContents hdl
1373 loop (linesPlatform (filter_fn str)) Nothing)
1374 `finally`
1375 writeChan chan EOF
1376 -- ToDo: check errors more carefully
1377 -- ToDo: in the future, the filter should be implemented as
1378 -- a stream transformer.
1379 where
1380 loop [] Nothing = return ()
1381 loop [] (Just err) = writeChan chan err
1382 loop (l:ls) in_err =
1383 case in_err of
1384 Just err@(BuildError srcLoc msg)
1385 | leading_whitespace l -> do
1386 loop ls (Just (BuildError srcLoc (msg $$ text l)))
1387 | otherwise -> do
1388 writeChan chan err
1389 checkError l ls
1390 Nothing -> do
1391 checkError l ls
1392 _ -> panic "readerProc/loop"
1393
1394 checkError l ls
1395 = case parseError l of
1396 Nothing -> do
1397 writeChan chan (BuildMsg (text l))
1398 loop ls Nothing
1399 Just (file, lineNum, colNum, msg) -> do
1400 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
1401 loop ls (Just (BuildError srcLoc (text msg)))
1402
1403 leading_whitespace [] = False
1404 leading_whitespace (x:_) = isSpace x
1405
1406 parseError :: String -> Maybe (String, Int, Int, String)
1407 parseError s0 = case breakColon s0 of
1408 Just (filename, s1) ->
1409 case breakIntColon s1 of
1410 Just (lineNum, s2) ->
1411 case breakIntColon s2 of
1412 Just (columnNum, s3) ->
1413 Just (filename, lineNum, columnNum, s3)
1414 Nothing ->
1415 Just (filename, lineNum, 0, s2)
1416 Nothing -> Nothing
1417 Nothing -> Nothing
1418
1419 breakColon :: String -> Maybe (String, String)
1420 breakColon xs = case break (':' ==) xs of
1421 (ys, _:zs) -> Just (ys, zs)
1422 _ -> Nothing
1423
1424 breakIntColon :: String -> Maybe (Int, String)
1425 breakIntColon xs = case break (':' ==) xs of
1426 (ys, _:zs)
1427 | not (null ys) && all isAscii ys && all isDigit ys ->
1428 Just (read ys, zs)
1429 _ -> Nothing
1430
1431 data BuildMessage
1432 = BuildMsg !SDoc
1433 | BuildError !SrcLoc !SDoc
1434 | EOF
1435
1436 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
1437 -- trace the command (at two levels of verbosity)
1438 traceCmd dflags phase_name cmd_line action
1439 = do { let verb = verbosity dflags
1440 ; showPass dflags phase_name
1441 ; debugTraceMsg dflags 3 (text cmd_line)
1442 ; case flushErr dflags of
1443 FlushErr io -> io
1444
1445 -- And run it!
1446 ; action `catchIO` handle_exn verb
1447 }
1448 where
1449 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
1450 ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
1451 ; throwGhcExceptionIO (ProgramError (show exn))}
1452
1453 {-
1454 ************************************************************************
1455 * *
1456 \subsection{Support code}
1457 * *
1458 ************************************************************************
1459 -}
1460
1461 -----------------------------------------------------------------------------
1462 -- Define getBaseDir :: IO (Maybe String)
1463
1464 getBaseDir :: IO (Maybe String)
1465 #if defined(mingw32_HOST_OS)
1466 -- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe,
1467 -- return the path $(stuff)/lib.
1468 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1469 where
1470 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1471 ret <- c_GetModuleFileName nullPtr buf size
1472 case ret of
1473 0 -> return Nothing
1474 _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
1475 | otherwise -> try_size (size * 2)
1476
1477 rootDir s = case splitFileName $ normalise s of
1478 (d, ghc_exe)
1479 | lower ghc_exe `elem` ["ghc.exe",
1480 "ghc-stage1.exe",
1481 "ghc-stage2.exe",
1482 "ghc-stage3.exe"] ->
1483 case splitFileName $ takeDirectory d of
1484 -- ghc is in $topdir/bin/ghc.exe
1485 (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
1486 _ -> fail
1487 _ -> fail
1488 where fail = panic ("can't decompose ghc.exe path: " ++ show s)
1489 lower = map toLower
1490
1491 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1492 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1493 #else
1494 getBaseDir = return Nothing
1495 #endif
1496
1497 #ifdef mingw32_HOST_OS
1498 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
1499 #else
1500 getProcessID :: IO Int
1501 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
1502 #endif
1503
1504 -- Divvy up text stream into lines, taking platform dependent
1505 -- line termination into account.
1506 linesPlatform :: String -> [String]
1507 #if !defined(mingw32_HOST_OS)
1508 linesPlatform ls = lines ls
1509 #else
1510 linesPlatform "" = []
1511 linesPlatform xs =
1512 case lineBreak xs of
1513 (as,xs1) -> as : linesPlatform xs1
1514 where
1515 lineBreak "" = ("","")
1516 lineBreak ('\r':'\n':xs) = ([],xs)
1517 lineBreak ('\n':xs) = ([],xs)
1518 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
1519
1520 #endif
1521
1522 linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO ()
1523 linkDynLib dflags0 o_files dep_packages
1524 = do
1525 let -- This is a rather ugly hack to fix dynamically linked
1526 -- GHC on Windows. If GHC is linked with -threaded, then
1527 -- it links against libHSrts_thr. But if base is linked
1528 -- against libHSrts, then both end up getting loaded,
1529 -- and things go wrong. We therefore link the libraries
1530 -- with the same RTS flags that we link GHC with.
1531 dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0
1532 else dflags0
1533 dflags2 = if cGhcDebugged then addWay' WayDebug dflags1
1534 else dflags1
1535 dflags = updateWays dflags2
1536
1537 verbFlags = getVerbFlags dflags
1538 o_file = outputFile dflags
1539
1540 pkgs <- getPreloadPackagesAnd dflags dep_packages
1541
1542 let pkg_lib_paths = collectLibraryPaths pkgs
1543 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1544 get_pkg_lib_path_opts l
1545 | ( osElfTarget (platformOS (targetPlatform dflags)) ||
1546 osMachOTarget (platformOS (targetPlatform dflags)) ) &&
1547 dynLibLoader dflags == SystemDependent &&
1548 not (gopt Opt_Static dflags)
1549 = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1550 | otherwise = ["-L" ++ l]
1551
1552 let lib_paths = libraryPaths dflags
1553 let lib_path_opts = map ("-L"++) lib_paths
1554
1555 -- We don't want to link our dynamic libs against the RTS package,
1556 -- because the RTS lib comes in several flavours and we want to be
1557 -- able to pick the flavour when a binary is linked.
1558 -- On Windows we need to link the RTS import lib as Windows does
1559 -- not allow undefined symbols.
1560 -- The RTS library path is still added to the library search path
1561 -- above in case the RTS is being explicitly linked in (see #3807).
1562 let platform = targetPlatform dflags
1563 os = platformOS platform
1564 pkgs_no_rts = case os of
1565 OSMinGW32 ->
1566 pkgs
1567 _ ->
1568 filter ((/= rtsUnitId) . packageConfigId) pkgs
1569 let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
1570 in package_hs_libs ++ extra_libs ++ other_flags
1571
1572 -- probably _stub.o files
1573 -- and last temporary shared object file
1574 let extra_ld_inputs = ldInputs dflags
1575
1576 -- frameworks
1577 pkg_framework_opts <- getPkgFrameworkOpts dflags platform
1578 (map unitId pkgs)
1579 let framework_opts = getFrameworkOpts dflags platform
1580
1581 case os of
1582 OSMinGW32 -> do
1583 -------------------------------------------------------------
1584 -- Making a DLL
1585 -------------------------------------------------------------
1586 let output_fn = case o_file of
1587 Just s -> s
1588 Nothing -> "HSdll.dll"
1589
1590 runLink dflags (
1591 map Option verbFlags
1592 ++ [ Option "-o"
1593 , FileOption "" output_fn
1594 , Option "-shared"
1595 ] ++
1596 [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1597 | gopt Opt_SharedImplib dflags
1598 ]
1599 ++ map (FileOption "") o_files
1600
1601 -- Permit the linker to auto link _symbol to _imp_symbol
1602 -- This lets us link against DLLs without needing an "import library"
1603 ++ [Option "-Wl,--enable-auto-import"]
1604
1605 ++ extra_ld_inputs
1606 ++ map Option (
1607 lib_path_opts
1608 ++ pkg_lib_path_opts
1609 ++ pkg_link_opts
1610 ))
1611 OSDarwin -> do
1612 -------------------------------------------------------------------
1613 -- Making a darwin dylib
1614 -------------------------------------------------------------------
1615 -- About the options used for Darwin:
1616 -- -dynamiclib
1617 -- Apple's way of saying -shared
1618 -- -undefined dynamic_lookup:
1619 -- Without these options, we'd have to specify the correct
1620 -- dependencies for each of the dylibs. Note that we could
1621 -- (and should) do without this for all libraries except
1622 -- the RTS; all we need to do is to pass the correct
1623 -- HSfoo_dyn.dylib files to the link command.
1624 -- This feature requires Mac OS X 10.3 or later; there is
1625 -- a similar feature, -flat_namespace -undefined suppress,
1626 -- which works on earlier versions, but it has other
1627 -- disadvantages.
1628 -- -single_module
1629 -- Build the dynamic library as a single "module", i.e. no
1630 -- dynamic binding nonsense when referring to symbols from
1631 -- within the library. The NCG assumes that this option is
1632 -- specified (on i386, at least).
1633 -- -install_name
1634 -- Mac OS/X stores the path where a dynamic library is (to
1635 -- be) installed in the library itself. It's called the
1636 -- "install name" of the library. Then any library or
1637 -- executable that links against it before it's installed
1638 -- will search for it in its ultimate install location.
1639 -- By default we set the install name to the absolute path
1640 -- at build time, but it can be overridden by the
1641 -- -dylib-install-name option passed to ghc. Cabal does
1642 -- this.
1643 -------------------------------------------------------------------
1644
1645 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1646
1647 instName <- case dylibInstallName dflags of
1648 Just n -> return n
1649 Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
1650 runLink dflags (
1651 map Option verbFlags
1652 ++ [ Option "-dynamiclib"
1653 , Option "-o"
1654 , FileOption "" output_fn
1655 ]
1656 ++ map Option o_files
1657 ++ [ Option "-undefined",
1658 Option "dynamic_lookup",
1659 Option "-single_module" ]
1660 ++ (if platformArch platform == ArchX86_64
1661 then [ ]
1662 else [ Option "-Wl,-read_only_relocs,suppress" ])
1663 ++ [ Option "-install_name", Option instName ]
1664 ++ map Option lib_path_opts
1665 ++ extra_ld_inputs
1666 ++ map Option framework_opts
1667 ++ map Option pkg_lib_path_opts
1668 ++ map Option pkg_link_opts
1669 ++ map Option pkg_framework_opts
1670 )
1671 OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target")
1672 _ -> do
1673 -------------------------------------------------------------------
1674 -- Making a DSO
1675 -------------------------------------------------------------------
1676
1677 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1678 let bsymbolicFlag = -- we need symbolic linking to resolve
1679 -- non-PIC intra-package-relocations
1680 ["-Wl,-Bsymbolic"]
1681
1682 runLink dflags (
1683 map Option verbFlags
1684 ++ [ Option "-o"
1685 , FileOption "" output_fn
1686 ]
1687 ++ map Option o_files
1688 ++ [ Option "-shared" ]
1689 ++ map Option bsymbolicFlag
1690 -- Set the library soname. We use -h rather than -soname as
1691 -- Solaris 10 doesn't support the latter:
1692 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
1693 ++ extra_ld_inputs
1694 ++ map Option lib_path_opts
1695 ++ map Option pkg_lib_path_opts
1696 ++ map Option pkg_link_opts
1697 )
1698
1699 getPkgFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]
1700 getPkgFrameworkOpts dflags platform dep_packages
1701 | platformUsesFrameworks platform = do
1702 pkg_framework_path_opts <- do
1703 pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1704 return $ map ("-F" ++) pkg_framework_paths
1705
1706 pkg_framework_opts <- do
1707 pkg_frameworks <- getPackageFrameworks dflags dep_packages
1708 return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1709
1710 return (pkg_framework_path_opts ++ pkg_framework_opts)
1711
1712 | otherwise = return []
1713
1714 getFrameworkOpts :: DynFlags -> Platform -> [String]
1715 getFrameworkOpts dflags platform
1716 | platformUsesFrameworks platform = framework_path_opts ++ framework_opts
1717 | otherwise = []
1718 where
1719 framework_paths = frameworkPaths dflags
1720 framework_path_opts = map ("-F" ++) framework_paths
1721
1722 frameworks = cmdlineFrameworks dflags
1723 -- reverse because they're added in reverse order from the cmd line:
1724 framework_opts = concat [ ["-framework", fw]
1725 | fw <- reverse frameworks ]