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