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