15baa38bf570efa67a0a38860a8af2879172f055
[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)
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 Low Level Virtual Machine (http://llvm.org/):
630 llvm version 2.8 (Ubuntu 2.8-0Ubuntu1)
631 ...
632 -}
633 hSetBinaryMode pout False
634 _ <- hGetLine pout
635 vline <- hGetLine pout
636 v <- case filter isDigit vline of
637 [] -> fail "no digits!"
638 [x] -> fail $ "only 1 digit! (" ++ show x ++ ")"
639 (x:y:_) -> return ((read [x,y]) :: Int)
640 hClose pin
641 hClose pout
642 hClose perr
643 return $ Just v
644 )
645 (\err -> do
646 debugTraceMsg dflags 2
647 (text "Error (figuring out LLVM version):" <+>
648 text (show err))
649 errorMsg dflags $ vcat
650 [ text "Warning:", nest 9 $
651 text "Couldn't figure out LLVM version!" $$
652 text "Make sure you have installed LLVM"]
653 return Nothing)
654 return ver
655
656 {- Note [Windows stack usage]
657
658 See: Trac #8870 (and #8834 for related info)
659
660 On Windows, occasionally we need to grow the stack. In order to do
661 this, we would normally just bump the stack pointer - but there's a
662 catch on Windows.
663
664 If the stack pointer is bumped by more than a single page, then the
665 pages between the initial pointer and the resulting location must be
666 properly committed by the Windows virtual memory subsystem. This is
667 only needed in the event we bump by more than one page (i.e 4097 bytes
668 or more).
669
670 Windows compilers solve this by emitting a call to a special function
671 called _chkstk, which does this committing of the pages for you.
672
673 The reason this was causing a segfault was because due to the fact the
674 new code generator tends to generate larger functions, we needed more
675 stack space in GHC itself. In the x86 codegen, we needed approximately
676 ~12kb of stack space in one go, which caused the process to segfault,
677 as the intervening pages were not committed.
678
679 In the future, we should do the same thing, to make the problem
680 completely go away. In the mean time, we're using a workaround: we
681 instruct the linker to specify the generated PE as having an initial
682 reserved stack size of 8mb, as well as a initial *committed* stack
683 size of 8mb. The default committed size was previously only 4k.
684
685 Theoretically it's possible to still hit this problem if you request a
686 stack bump of more than 8mb in one go. But the amount of code
687 necessary is quite large, and 8mb "should be more than enough for
688 anyone" right now (he said, before millions of lines of code cried out
689 in terror).
690
691 -}
692
693 {- Note [Run-time linker info]
694
695 See also: Trac #5240, Trac #6063, Trac #10110
696
697 Before 'runLink', we need to be sure to get the relevant information
698 about the linker we're using at runtime to see if we need any extra
699 options. For example, GNU ld requires '--reduce-memory-overheads' and
700 '--hash-size=31' in order to use reasonable amounts of memory (see
701 trac #5240.) But this isn't supported in GNU gold.
702
703 Generally, the linker changing from what was detected at ./configure
704 time has always been possible using -pgml, but on Linux it can happen
705 'transparently' by installing packages like binutils-gold, which
706 change what /usr/bin/ld actually points to.
707
708 Clang vs GCC notes:
709
710 For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
711 invoke the linker before the version information string. For 'clang',
712 the version information for 'ld' is all that's output. For this
713 reason, we typically need to slurp up all of the standard error output
714 and look through it.
715
716 Other notes:
717
718 We cache the LinkerInfo inside DynFlags, since clients may link
719 multiple times. The definition of LinkerInfo is there to avoid a
720 circular dependency.
721
722 -}
723
724 {- Note [ELF needed shared libs]
725
726 Some distributions change the link editor's default handling of
727 ELF DT_NEEDED tags to include only those shared objects that are
728 needed to resolve undefined symbols. For Template Haskell we need
729 the last temporary shared library also if it is not needed for the
730 currently linked temporary shared library. We specify --no-as-needed
731 to override the default. This flag exists in GNU ld and GNU gold.
732
733 The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
734 (Mach-O) the flag is not needed.
735
736 -}
737
738 {- Note [Windows static libGCC]
739
740 The GCC versions being upgraded to in #10726 are configured with
741 dynamic linking of libgcc supported. This results in libgcc being
742 linked dynamically when a shared library is created.
743
744 This introduces thus an extra dependency on GCC dll that was not
745 needed before by shared libraries created with GHC. This is a particular
746 issue on Windows because you get a non-obvious error due to this missing
747 dependency. This dependent dll is also not commonly on your path.
748
749 For this reason using the static libgcc is preferred as it preserves
750 the same behaviour that existed before. There are however some very good
751 reasons to have the shared version as well as described on page 181 of
752 https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :
753
754 "There are several situations in which an application should use the
755 shared ‘libgcc’ instead of the static version. The most common of these
756 is when the application wishes to throw and catch exceptions across different
757 shared libraries. In that case, each of the libraries as well as the application
758 itself should use the shared ‘libgcc’. "
759
760 -}
761
762 neededLinkArgs :: LinkerInfo -> [Option]
763 neededLinkArgs (GnuLD o) = o
764 neededLinkArgs (GnuGold o) = o
765 neededLinkArgs (DarwinLD o) = o
766 neededLinkArgs (SolarisLD o) = o
767 neededLinkArgs UnknownLD = []
768
769 -- Grab linker info and cache it in DynFlags.
770 getLinkerInfo :: DynFlags -> IO LinkerInfo
771 getLinkerInfo dflags = do
772 info <- readIORef (rtldInfo dflags)
773 case info of
774 Just v -> return v
775 Nothing -> do
776 v <- getLinkerInfo' dflags
777 writeIORef (rtldInfo dflags) (Just v)
778 return v
779
780 -- See Note [Run-time linker info].
781 getLinkerInfo' :: DynFlags -> IO LinkerInfo
782 getLinkerInfo' dflags = do
783 let platform = targetPlatform dflags
784 os = platformOS platform
785 (pgm,args0) = pgm_l dflags
786 args1 = map Option (getOpts dflags opt_l)
787 args2 = args0 ++ args1
788 args3 = filter notNull (map showOpt args2)
789
790 -- Try to grab the info from the process output.
791 parseLinkerInfo stdo _stde _exitc
792 | any ("GNU ld" `isPrefixOf`) stdo =
793 -- GNU ld specifically needs to use less memory. This especially
794 -- hurts on small object files. Trac #5240.
795 -- Set DT_NEEDED for all shared libraries. Trac #10110.
796 return (GnuLD $ map Option ["-Wl,--hash-size=31",
797 "-Wl,--reduce-memory-overheads",
798 -- ELF specific flag
799 -- see Note [ELF needed shared libs]
800 "-Wl,--no-as-needed"])
801
802 | any ("GNU gold" `isPrefixOf`) stdo =
803 -- GNU gold only needs --no-as-needed. Trac #10110.
804 -- ELF specific flag, see Note [ELF needed shared libs]
805 return (GnuGold [Option "-Wl,--no-as-needed"])
806
807 -- Unknown linker.
808 | otherwise = fail "invalid --version output, or linker is unsupported"
809
810 -- Process the executable call
811 info <- catchIO (do
812 case os of
813 OSSolaris2 ->
814 -- Solaris uses its own Solaris linker. Even all
815 -- GNU C are recommended to configure with Solaris
816 -- linker instead of using GNU binutils linker. Also
817 -- all GCC distributed with Solaris follows this rule
818 -- precisely so we assume here, the Solaris linker is
819 -- used.
820 return $ SolarisLD []
821 OSDarwin ->
822 -- Darwin has neither GNU Gold or GNU LD, but a strange linker
823 -- that doesn't support --version. We can just assume that's
824 -- what we're using.
825 return $ DarwinLD []
826 OSiOS ->
827 -- Ditto for iOS
828 return $ DarwinLD []
829 OSMinGW32 ->
830 -- GHC doesn't support anything but GNU ld on Windows anyway.
831 -- Process creation is also fairly expensive on win32, so
832 -- we short-circuit here.
833 return $ GnuLD $ map Option
834 [ -- Reduce ld memory usage
835 "-Wl,--hash-size=31"
836 , "-Wl,--reduce-memory-overheads"
837 -- Increase default stack, see
838 -- Note [Windows stack usage]
839 -- Force static linking of libGCC
840 -- Note [Windows static libGCC]
841 , "-Xlinker", "--stack=0x800000,0x800000", "-static-libgcc" ]
842 _ -> do
843 -- In practice, we use the compiler as the linker here. Pass
844 -- -Wl,--version to get linker version info.
845 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
846 (["-Wl,--version"] ++ args3)
847 en_locale_env
848 -- Split the output by lines to make certain kinds
849 -- of processing easier. In particular, 'clang' and 'gcc'
850 -- have slightly different outputs for '-Wl,--version', but
851 -- it's still easy to figure out.
852 parseLinkerInfo (lines stdo) (lines stde) exitc
853 )
854 (\err -> do
855 debugTraceMsg dflags 2
856 (text "Error (figuring out linker information):" <+>
857 text (show err))
858 errorMsg dflags $ hang (text "Warning:") 9 $
859 text "Couldn't figure out linker information!" $$
860 text "Make sure you're using GNU ld, GNU gold" <+>
861 text "or the built in OS X linker, etc."
862 return UnknownLD)
863 return info
864
865 -- Grab compiler info and cache it in DynFlags.
866 getCompilerInfo :: DynFlags -> IO CompilerInfo
867 getCompilerInfo dflags = do
868 info <- readIORef (rtccInfo dflags)
869 case info of
870 Just v -> return v
871 Nothing -> do
872 v <- getCompilerInfo' dflags
873 writeIORef (rtccInfo dflags) (Just v)
874 return v
875
876 -- See Note [Run-time linker info].
877 getCompilerInfo' :: DynFlags -> IO CompilerInfo
878 getCompilerInfo' dflags = do
879 let (pgm,_) = pgm_c dflags
880 -- Try to grab the info from the process output.
881 parseCompilerInfo _stdo stde _exitc
882 -- Regular GCC
883 | any ("gcc version" `isPrefixOf`) stde =
884 return GCC
885 -- Regular clang
886 | any ("clang version" `isPrefixOf`) stde =
887 return Clang
888 -- XCode 5.1 clang
889 | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
890 return AppleClang51
891 -- XCode 5 clang
892 | any ("Apple LLVM version" `isPrefixOf`) stde =
893 return AppleClang
894 -- XCode 4.1 clang
895 | any ("Apple clang version" `isPrefixOf`) stde =
896 return AppleClang
897 -- Unknown linker.
898 | otherwise = fail "invalid -v output, or compiler is unsupported"
899
900 -- Process the executable call
901 info <- catchIO (do
902 (exitc, stdo, stde) <-
903 readProcessEnvWithExitCode pgm ["-v"] en_locale_env
904 -- Split the output by lines to make certain kinds
905 -- of processing easier.
906 parseCompilerInfo (lines stdo) (lines stde) exitc
907 )
908 (\err -> do
909 debugTraceMsg dflags 2
910 (text "Error (figuring out C compiler information):" <+>
911 text (show err))
912 errorMsg dflags $ hang (text "Warning:") 9 $
913 text "Couldn't figure out C compiler information!" $$
914 text "Make sure you're using GNU gcc, or clang"
915 return UnknownCC)
916 return info
917
918 runLink :: DynFlags -> [Option] -> IO ()
919 runLink dflags args = do
920 -- See Note [Run-time linker info]
921 linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
922 let (p,args0) = pgm_l dflags
923 args1 = map Option (getOpts dflags opt_l)
924 args2 = args0 ++ linkargs ++ args1 ++ args
925 mb_env <- getGccEnv args2
926 runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
927 where
928 ld_filter = case (platformOS (targetPlatform dflags)) of
929 OSSolaris2 -> sunos_ld_filter
930 _ -> id
931 {-
932 SunOS/Solaris ld emits harmless warning messages about unresolved
933 symbols in case of compiling into shared library when we do not
934 link against all the required libs. That is the case of GHC which
935 does not link against RTS library explicitly in order to be able to
936 choose the library later based on binary application linking
937 parameters. The warnings look like:
938
939 Undefined first referenced
940 symbol in file
941 stg_ap_n_fast ./T2386_Lib.o
942 stg_upd_frame_info ./T2386_Lib.o
943 templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
944 templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
945 templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
946 templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
947 newCAF ./T2386_Lib.o
948 stg_bh_upd_frame_info ./T2386_Lib.o
949 stg_ap_ppp_fast ./T2386_Lib.o
950 templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
951 stg_ap_p_fast ./T2386_Lib.o
952 stg_ap_pp_fast ./T2386_Lib.o
953 ld: warning: symbol referencing errors
954
955 this is actually coming from T2386 testcase. The emitting of those
956 warnings is also a reason why so many TH testcases fail on Solaris.
957
958 Following filter code is SunOS/Solaris linker specific and should
959 filter out only linker warnings. Please note that the logic is a
960 little bit more complex due to the simple reason that we need to preserve
961 any other linker emitted messages. If there are any. Simply speaking
962 if we see "Undefined" and later "ld: warning:..." then we omit all
963 text between (including) the marks. Otherwise we copy the whole output.
964 -}
965 sunos_ld_filter :: String -> String
966 sunos_ld_filter = unlines . sunos_ld_filter' . lines
967 sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
968 then (ld_prefix x) ++ (ld_postfix x)
969 else x
970 breakStartsWith x y = break (isPrefixOf x) y
971 ld_prefix = fst . breakStartsWith "Undefined"
972 undefined_found = not . null . snd . breakStartsWith "Undefined"
973 ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
974 ld_postfix = tail . snd . ld_warn_break
975 ld_warning_found = not . null . snd . ld_warn_break
976
977
978 runLibtool :: DynFlags -> [Option] -> IO ()
979 runLibtool dflags args = do
980 linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
981 let args1 = map Option (getOpts dflags opt_l)
982 args2 = [Option "-static"] ++ args1 ++ args ++ linkargs
983 libtool = pgm_libtool dflags
984 mb_env <- getGccEnv args2
985 runSomethingFiltered dflags id "Linker" libtool args2 mb_env
986
987 runMkDLL :: DynFlags -> [Option] -> IO ()
988 runMkDLL dflags args = do
989 let (p,args0) = pgm_dll dflags
990 args1 = args0 ++ args
991 mb_env <- getGccEnv (args0++args)
992 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
993
994 runWindres :: DynFlags -> [Option] -> IO ()
995 runWindres dflags args = do
996 let (gcc, gcc_args) = pgm_c dflags
997 windres = pgm_windres dflags
998 opts = map Option (getOpts dflags opt_windres)
999 quote x = "\"" ++ x ++ "\""
1000 args' = -- If windres.exe and gcc.exe are in a directory containing
1001 -- spaces then windres fails to run gcc. We therefore need
1002 -- to tell it what command to use...
1003 Option ("--preprocessor=" ++
1004 unwords (map quote (gcc :
1005 map showOpt gcc_args ++
1006 map showOpt opts ++
1007 ["-E", "-xc", "-DRC_INVOKED"])))
1008 -- ...but if we do that then if windres calls popen then
1009 -- it can't understand the quoting, so we have to use
1010 -- --use-temp-file so that it interprets it correctly.
1011 -- See #1828.
1012 : Option "--use-temp-file"
1013 : args
1014 mb_env <- getGccEnv gcc_args
1015 runSomethingFiltered dflags id "Windres" windres args' mb_env
1016
1017 touch :: DynFlags -> String -> String -> IO ()
1018 touch dflags purpose arg =
1019 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
1020
1021 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
1022 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
1023
1024 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
1025 -> IO ()
1026 copyWithHeader dflags purpose maybe_header from to = do
1027 showPass dflags purpose
1028
1029 hout <- openBinaryFile to WriteMode
1030 hin <- openBinaryFile from ReadMode
1031 ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
1032 maybe (return ()) (header hout) maybe_header
1033 hPutStr hout ls
1034 hClose hout
1035 hClose hin
1036 where
1037 -- write the header string in UTF-8. The header is something like
1038 -- {-# LINE "foo.hs" #-}
1039 -- and we want to make sure a Unicode filename isn't mangled.
1040 header h str = do
1041 hSetEncoding h utf8
1042 hPutStr h str
1043 hSetBinaryMode h True
1044
1045 -- | read the contents of the named section in an ELF object as a
1046 -- String.
1047 readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
1048 readElfSection _dflags section exe = do
1049 let
1050 prog = "readelf"
1051 args = [Option "-p", Option section, FileOption "" exe]
1052 --
1053 r <- readProcessEnvWithExitCode prog (filter notNull (map showOpt args))
1054 en_locale_env
1055 case r of
1056 (ExitSuccess, out, _err) -> return (doFilter (lines out))
1057 _ -> return Nothing
1058 where
1059 doFilter [] = Nothing
1060 doFilter (s:r) = case readP_to_S parse s of
1061 [(p,"")] -> Just p
1062 _r -> doFilter r
1063 where parse = do
1064 skipSpaces
1065 _ <- R.char '['
1066 skipSpaces
1067 _ <- string "0]"
1068 skipSpaces
1069 munch (const True)
1070
1071 {-
1072 ************************************************************************
1073 * *
1074 \subsection{Managing temporary files
1075 * *
1076 ************************************************************************
1077 -}
1078
1079 cleanTempDirs :: DynFlags -> IO ()
1080 cleanTempDirs dflags
1081 = unless (gopt Opt_KeepTmpFiles dflags)
1082 $ mask_
1083 $ do let ref = dirsToClean dflags
1084 ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
1085 removeTmpDirs dflags (Map.elems ds)
1086
1087 cleanTempFiles :: DynFlags -> IO ()
1088 cleanTempFiles dflags
1089 = unless (gopt Opt_KeepTmpFiles dflags)
1090 $ mask_
1091 $ do let ref = filesToClean dflags
1092 fs <- atomicModifyIORef' ref $ \fs -> ([],fs)
1093 removeTmpFiles dflags fs
1094
1095 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
1096 cleanTempFilesExcept dflags dont_delete
1097 = unless (gopt Opt_KeepTmpFiles dflags)
1098 $ mask_
1099 $ do let ref = filesToClean dflags
1100 to_delete <- atomicModifyIORef' ref $ \files ->
1101 let (to_keep,to_delete) = partition (`elem` dont_delete) files
1102 in (to_keep,to_delete)
1103 removeTmpFiles dflags to_delete
1104
1105
1106 -- Return a unique numeric temp file suffix
1107 newTempSuffix :: DynFlags -> IO Int
1108 newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
1109
1110 -- Find a temporary name that doesn't already exist.
1111 newTempName :: DynFlags -> Suffix -> IO FilePath
1112 newTempName dflags extn
1113 = do d <- getTempDir dflags
1114 findTempName (d </> "ghc_") -- See Note [Deterministic base name]
1115 where
1116 findTempName :: FilePath -> IO FilePath
1117 findTempName prefix
1118 = do n <- newTempSuffix dflags
1119 let filename = prefix ++ show n <.> extn
1120 b <- doesFileExist filename
1121 if b then findTempName prefix
1122 else do -- clean it up later
1123 consIORef (filesToClean dflags) filename
1124 return filename
1125
1126 newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String)
1127 newTempLibName dflags extn
1128 = do d <- getTempDir dflags
1129 findTempName d ("ghc_")
1130 where
1131 findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
1132 findTempName dir prefix
1133 = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
1134 let libname = prefix ++ show n
1135 filename = dir </> "lib" ++ libname <.> extn
1136 b <- doesFileExist filename
1137 if b then findTempName dir prefix
1138 else do -- clean it up later
1139 consIORef (filesToClean dflags) filename
1140 return (filename, dir, libname)
1141
1142
1143 -- Return our temporary directory within tmp_dir, creating one if we
1144 -- don't have one yet.
1145 getTempDir :: DynFlags -> IO FilePath
1146 getTempDir dflags = do
1147 mapping <- readIORef dir_ref
1148 case Map.lookup tmp_dir mapping of
1149 Nothing -> do
1150 pid <- getProcessID
1151 let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
1152 mask_ $ mkTempDir prefix
1153 Just dir -> return dir
1154 where
1155 tmp_dir = tmpDir dflags
1156 dir_ref = dirsToClean dflags
1157
1158 mkTempDir :: FilePath -> IO FilePath
1159 mkTempDir prefix = do
1160 n <- newTempSuffix dflags
1161 let our_dir = prefix ++ show n
1162
1163 -- 1. Speculatively create our new directory.
1164 createDirectory our_dir
1165
1166 -- 2. Update the dirsToClean mapping unless an entry already exists
1167 -- (i.e. unless another thread beat us to it).
1168 their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
1169 case Map.lookup tmp_dir mapping of
1170 Just dir -> (mapping, Just dir)
1171 Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing)
1172
1173 -- 3. If there was an existing entry, return it and delete the
1174 -- directory we created. Otherwise return the directory we created.
1175 case their_dir of
1176 Nothing -> do
1177 debugTraceMsg dflags 2 $
1178 text "Created temporary directory:" <+> text our_dir
1179 return our_dir
1180 Just dir -> do
1181 removeDirectory our_dir
1182 return dir
1183 `catchIO` \e -> if isAlreadyExistsError e
1184 then mkTempDir prefix else ioError e
1185
1186 -- Note [Deterministic base name]
1187 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1188 --
1189 -- The filename of temporary files, especially the basename of C files, can end
1190 -- up in the output in some form, e.g. as part of linker debug information. In the
1191 -- interest of bit-wise exactly reproducible compilation (#4012), the basename of
1192 -- the temporary file no longer contains random information (it used to contain
1193 -- the process id).
1194 --
1195 -- This is ok, as the temporary directory used contains the pid (see getTempDir).
1196
1197 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
1198 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
1199 addFilesToClean dflags new_files
1200 = atomicModifyIORef' (filesToClean dflags) $ \files -> (new_files++files, ())
1201
1202 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
1203 removeTmpDirs dflags ds
1204 = traceCmd dflags "Deleting temp dirs"
1205 ("Deleting: " ++ unwords ds)
1206 (mapM_ (removeWith dflags removeDirectory) ds)
1207
1208 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
1209 removeTmpFiles dflags fs
1210 = warnNon $
1211 traceCmd dflags "Deleting temp files"
1212 ("Deleting: " ++ unwords deletees)
1213 (mapM_ (removeWith dflags removeFile) deletees)
1214 where
1215 -- Flat out refuse to delete files that are likely to be source input
1216 -- files (is there a worse bug than having a compiler delete your source
1217 -- files?)
1218 --
1219 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
1220 -- the condition.
1221 warnNon act
1222 | null non_deletees = act
1223 | otherwise = do
1224 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
1225 act
1226
1227 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
1228
1229 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
1230 removeWith dflags remover f = remover f `catchIO`
1231 (\e ->
1232 let msg = if isDoesNotExistError e
1233 then ptext (sLit "Warning: deleting non-existent") <+> text f
1234 else ptext (sLit "Warning: exception raised when deleting")
1235 <+> text f <> colon
1236 $$ text (show e)
1237 in debugTraceMsg dflags 2 msg
1238 )
1239
1240 -----------------------------------------------------------------------------
1241 -- Running an external program
1242
1243 runSomething :: DynFlags
1244 -> String -- For -v message
1245 -> String -- Command name (possibly a full path)
1246 -- assumed already dos-ified
1247 -> [Option] -- Arguments
1248 -- runSomething will dos-ify them
1249 -> IO ()
1250
1251 runSomething dflags phase_name pgm args =
1252 runSomethingFiltered dflags id phase_name pgm args Nothing
1253
1254 -- | Run a command, placing the arguments in an external response file.
1255 --
1256 -- This command is used in order to avoid overlong command line arguments on
1257 -- Windows. The command line arguments are first written to an external,
1258 -- temporary response file, and then passed to the linker via @filepath.
1259 -- response files for passing them in. See:
1260 --
1261 -- https://gcc.gnu.org/wiki/Response_Files
1262 -- https://ghc.haskell.org/trac/ghc/ticket/10777
1263 runSomethingResponseFile
1264 :: DynFlags -> (String->String) -> String -> String -> [Option]
1265 -> Maybe [(String,String)] -> IO ()
1266
1267 runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
1268 runSomethingWith dflags phase_name pgm args $ \real_args -> do
1269 fp <- getResponseFile real_args
1270 let args = ['@':fp]
1271 r <- builderMainLoop dflags filter_fn pgm args mb_env
1272 return (r,())
1273 where
1274 getResponseFile args = do
1275 fp <- newTempName dflags "rsp"
1276 withFile fp WriteMode $ \h -> do
1277 hSetEncoding h utf8
1278 hPutStr h $ unlines $ map escape args
1279 return fp
1280
1281 -- Note: Response files have backslash-escaping, double quoting, and are
1282 -- whitespace separated (some implementations use newline, others any
1283 -- whitespace character). Therefore, escape any backslashes, newlines, and
1284 -- double quotes in the argument, and surround the content with double
1285 -- quotes.
1286 --
1287 -- Another possibility that could be considered would be to convert
1288 -- backslashes in the argument to forward slashes. This would generally do
1289 -- the right thing, since backslashes in general only appear in arguments
1290 -- as part of file paths on Windows, and the forward slash is accepted for
1291 -- those. However, escaping is more reliable, in case somehow a backslash
1292 -- appears in a non-file.
1293 escape x = concat
1294 [ "\""
1295 , concatMap
1296 (\c ->
1297 case c of
1298 '\\' -> "\\\\"
1299 '\n' -> "\\n"
1300 '\"' -> "\\\""
1301 _ -> [c])
1302 x
1303 , "\""
1304 ]
1305
1306 runSomethingFiltered
1307 :: DynFlags -> (String->String) -> String -> String -> [Option]
1308 -> Maybe [(String,String)] -> IO ()
1309
1310 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
1311 runSomethingWith dflags phase_name pgm args $ \real_args -> do
1312 r <- builderMainLoop dflags filter_fn pgm real_args mb_env
1313 return (r,())
1314
1315 runSomethingWith
1316 :: DynFlags -> String -> String -> [Option]
1317 -> ([String] -> IO (ExitCode, a))
1318 -> IO a
1319
1320 runSomethingWith dflags phase_name pgm args io = do
1321 let real_args = filter notNull (map showOpt args)
1322 cmdLine = showCommandForUser pgm real_args
1323 traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
1324
1325 handleProc :: String -> String -> IO (ExitCode, r) -> IO r
1326 handleProc pgm phase_name proc = do
1327 (rc, r) <- proc `catchIO` handler
1328 case rc of
1329 ExitSuccess{} -> return r
1330 ExitFailure n
1331 -- rawSystem returns (ExitFailure 127) if the exec failed for any
1332 -- reason (eg. the program doesn't exist). This is the only clue
1333 -- we have, but we need to report something to the user because in
1334 -- the case of a missing program there will otherwise be no output
1335 -- at all.
1336 | n == 127 -> does_not_exist
1337 | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc)
1338 where
1339 handler err =
1340 if IO.isDoesNotExistError err
1341 then does_not_exist
1342 else IO.ioError err
1343
1344 does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
1345
1346
1347 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
1348 -> [String] -> Maybe [(String, String)]
1349 -> IO ExitCode
1350 builderMainLoop dflags filter_fn pgm real_args mb_env = do
1351 chan <- newChan
1352 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
1353
1354 -- and run a loop piping the output from the compiler to the log_action in DynFlags
1355 hSetBuffering hStdOut LineBuffering
1356 hSetBuffering hStdErr LineBuffering
1357 _ <- forkIO (readerProc chan hStdOut filter_fn)
1358 _ <- forkIO (readerProc chan hStdErr filter_fn)
1359 -- we don't want to finish until 2 streams have been completed
1360 -- (stdout and stderr)
1361 -- nor until 1 exit code has been retrieved.
1362 rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
1363 -- after that, we're done here.
1364 hClose hStdIn
1365 hClose hStdOut
1366 hClose hStdErr
1367 return rc
1368 where
1369 -- status starts at zero, and increments each time either
1370 -- a reader process gets EOF, or the build proc exits. We wait
1371 -- for all of these to happen (status==3).
1372 -- ToDo: we should really have a contingency plan in case any of
1373 -- the threads dies, such as a timeout.
1374 loop _ _ 0 0 exitcode = return exitcode
1375 loop chan hProcess t p exitcode = do
1376 mb_code <- if p > 0
1377 then getProcessExitCode hProcess
1378 else return Nothing
1379 case mb_code of
1380 Just code -> loop chan hProcess t (p-1) code
1381 Nothing
1382 | t > 0 -> do
1383 msg <- readChan chan
1384 case msg of
1385 BuildMsg msg -> do
1386 log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
1387 loop chan hProcess t p exitcode
1388 BuildError loc msg -> do
1389 log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
1390 loop chan hProcess t p exitcode
1391 EOF ->
1392 loop chan hProcess (t-1) p exitcode
1393 | otherwise -> loop chan hProcess t p exitcode
1394
1395 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
1396 readerProc chan hdl filter_fn =
1397 (do str <- hGetContents hdl
1398 loop (linesPlatform (filter_fn str)) Nothing)
1399 `finally`
1400 writeChan chan EOF
1401 -- ToDo: check errors more carefully
1402 -- ToDo: in the future, the filter should be implemented as
1403 -- a stream transformer.
1404 where
1405 loop [] Nothing = return ()
1406 loop [] (Just err) = writeChan chan err
1407 loop (l:ls) in_err =
1408 case in_err of
1409 Just err@(BuildError srcLoc msg)
1410 | leading_whitespace l -> do
1411 loop ls (Just (BuildError srcLoc (msg $$ text l)))
1412 | otherwise -> do
1413 writeChan chan err
1414 checkError l ls
1415 Nothing -> do
1416 checkError l ls
1417 _ -> panic "readerProc/loop"
1418
1419 checkError l ls
1420 = case parseError l of
1421 Nothing -> do
1422 writeChan chan (BuildMsg (text l))
1423 loop ls Nothing
1424 Just (file, lineNum, colNum, msg) -> do
1425 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
1426 loop ls (Just (BuildError srcLoc (text msg)))
1427
1428 leading_whitespace [] = False
1429 leading_whitespace (x:_) = isSpace x
1430
1431 parseError :: String -> Maybe (String, Int, Int, String)
1432 parseError s0 = case breakColon s0 of
1433 Just (filename, s1) ->
1434 case breakIntColon s1 of
1435 Just (lineNum, s2) ->
1436 case breakIntColon s2 of
1437 Just (columnNum, s3) ->
1438 Just (filename, lineNum, columnNum, s3)
1439 Nothing ->
1440 Just (filename, lineNum, 0, s2)
1441 Nothing -> Nothing
1442 Nothing -> Nothing
1443
1444 breakColon :: String -> Maybe (String, String)
1445 breakColon xs = case break (':' ==) xs of
1446 (ys, _:zs) -> Just (ys, zs)
1447 _ -> Nothing
1448
1449 breakIntColon :: String -> Maybe (Int, String)
1450 breakIntColon xs = case break (':' ==) xs of
1451 (ys, _:zs)
1452 | not (null ys) && all isAscii ys && all isDigit ys ->
1453 Just (read ys, zs)
1454 _ -> Nothing
1455
1456 data BuildMessage
1457 = BuildMsg !SDoc
1458 | BuildError !SrcLoc !SDoc
1459 | EOF
1460
1461 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
1462 -- trace the command (at two levels of verbosity)
1463 traceCmd dflags phase_name cmd_line action
1464 = do { let verb = verbosity dflags
1465 ; showPass dflags phase_name
1466 ; debugTraceMsg dflags 3 (text cmd_line)
1467 ; case flushErr dflags of
1468 FlushErr io -> io
1469
1470 -- And run it!
1471 ; action `catchIO` handle_exn verb
1472 }
1473 where
1474 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
1475 ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
1476 ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
1477
1478 {-
1479 ************************************************************************
1480 * *
1481 \subsection{Support code}
1482 * *
1483 ************************************************************************
1484 -}
1485
1486 -----------------------------------------------------------------------------
1487 -- Define getBaseDir :: IO (Maybe String)
1488
1489 getBaseDir :: IO (Maybe String)
1490 #if defined(mingw32_HOST_OS)
1491 -- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe,
1492 -- return the path $(stuff)/lib.
1493 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1494 where
1495 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1496 ret <- c_GetModuleFileName nullPtr buf size
1497 case ret of
1498 0 -> return Nothing
1499 _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
1500 | otherwise -> try_size (size * 2)
1501
1502 rootDir s = case splitFileName $ normalise s of
1503 (d, ghc_exe)
1504 | lower ghc_exe `elem` ["ghc.exe",
1505 "ghc-stage1.exe",
1506 "ghc-stage2.exe",
1507 "ghc-stage3.exe"] ->
1508 case splitFileName $ takeDirectory d of
1509 -- ghc is in $topdir/bin/ghc.exe
1510 (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
1511 _ -> fail
1512 _ -> fail
1513 where fail = panic ("can't decompose ghc.exe path: " ++ show s)
1514 lower = map toLower
1515
1516 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1517 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1518 #else
1519 getBaseDir = return Nothing
1520 #endif
1521
1522 #ifdef mingw32_HOST_OS
1523 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
1524 #else
1525 getProcessID :: IO Int
1526 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
1527 #endif
1528
1529 -- Divvy up text stream into lines, taking platform dependent
1530 -- line termination into account.
1531 linesPlatform :: String -> [String]
1532 #if !defined(mingw32_HOST_OS)
1533 linesPlatform ls = lines ls
1534 #else
1535 linesPlatform "" = []
1536 linesPlatform xs =
1537 case lineBreak xs of
1538 (as,xs1) -> as : linesPlatform xs1
1539 where
1540 lineBreak "" = ("","")
1541 lineBreak ('\r':'\n':xs) = ([],xs)
1542 lineBreak ('\n':xs) = ([],xs)
1543 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
1544
1545 #endif
1546
1547 linkDynLib :: DynFlags -> [String] -> [PackageKey] -> IO ()
1548 linkDynLib dflags0 o_files dep_packages
1549 = do
1550 let -- This is a rather ugly hack to fix dynamically linked
1551 -- GHC on Windows. If GHC is linked with -threaded, then
1552 -- it links against libHSrts_thr. But if base is linked
1553 -- against libHSrts, then both end up getting loaded,
1554 -- and things go wrong. We therefore link the libraries
1555 -- with the same RTS flags that we link GHC with.
1556 dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0
1557 else dflags0
1558 dflags2 = if cGhcDebugged then addWay' WayDebug dflags1
1559 else dflags1
1560 dflags = updateWays dflags2
1561
1562 verbFlags = getVerbFlags dflags
1563 o_file = outputFile dflags
1564
1565 pkgs <- getPreloadPackagesAnd dflags dep_packages
1566
1567 let pkg_lib_paths = collectLibraryPaths pkgs
1568 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1569 get_pkg_lib_path_opts l
1570 | ( osElfTarget (platformOS (targetPlatform dflags)) ||
1571 osMachOTarget (platformOS (targetPlatform dflags)) ) &&
1572 dynLibLoader dflags == SystemDependent &&
1573 not (gopt Opt_Static dflags)
1574 = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1575 | otherwise = ["-L" ++ l]
1576
1577 let lib_paths = libraryPaths dflags
1578 let lib_path_opts = map ("-L"++) lib_paths
1579
1580 -- We don't want to link our dynamic libs against the RTS package,
1581 -- because the RTS lib comes in several flavours and we want to be
1582 -- able to pick the flavour when a binary is linked.
1583 -- On Windows we need to link the RTS import lib as Windows does
1584 -- not allow undefined symbols.
1585 -- The RTS library path is still added to the library search path
1586 -- above in case the RTS is being explicitly linked in (see #3807).
1587 let platform = targetPlatform dflags
1588 os = platformOS platform
1589 pkgs_no_rts = case os of
1590 OSMinGW32 ->
1591 pkgs
1592 _ ->
1593 filter ((/= rtsPackageKey) . packageConfigId) pkgs
1594 let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
1595 in package_hs_libs ++ extra_libs ++ other_flags
1596
1597 -- probably _stub.o files
1598 -- and last temporary shared object file
1599 let extra_ld_inputs = ldInputs dflags
1600
1601 -- frameworks
1602 pkg_framework_opts <- getPkgFrameworkOpts dflags platform
1603 (map packageKey pkgs)
1604 let framework_opts = getFrameworkOpts dflags platform
1605
1606 case os of
1607 OSMinGW32 -> do
1608 -------------------------------------------------------------
1609 -- Making a DLL
1610 -------------------------------------------------------------
1611 let output_fn = case o_file of
1612 Just s -> s
1613 Nothing -> "HSdll.dll"
1614
1615 runLink dflags (
1616 map Option verbFlags
1617 ++ [ Option "-o"
1618 , FileOption "" output_fn
1619 , Option "-shared"
1620 ] ++
1621 [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1622 | gopt Opt_SharedImplib dflags
1623 ]
1624 ++ map (FileOption "") o_files
1625
1626 -- Permit the linker to auto link _symbol to _imp_symbol
1627 -- This lets us link against DLLs without needing an "import library"
1628 ++ [Option "-Wl,--enable-auto-import"]
1629
1630 ++ extra_ld_inputs
1631 ++ map Option (
1632 lib_path_opts
1633 ++ pkg_lib_path_opts
1634 ++ pkg_link_opts
1635 ))
1636 OSDarwin -> do
1637 -------------------------------------------------------------------
1638 -- Making a darwin dylib
1639 -------------------------------------------------------------------
1640 -- About the options used for Darwin:
1641 -- -dynamiclib
1642 -- Apple's way of saying -shared
1643 -- -undefined dynamic_lookup:
1644 -- Without these options, we'd have to specify the correct
1645 -- dependencies for each of the dylibs. Note that we could
1646 -- (and should) do without this for all libraries except
1647 -- the RTS; all we need to do is to pass the correct
1648 -- HSfoo_dyn.dylib files to the link command.
1649 -- This feature requires Mac OS X 10.3 or later; there is
1650 -- a similar feature, -flat_namespace -undefined suppress,
1651 -- which works on earlier versions, but it has other
1652 -- disadvantages.
1653 -- -single_module
1654 -- Build the dynamic library as a single "module", i.e. no
1655 -- dynamic binding nonsense when referring to symbols from
1656 -- within the library. The NCG assumes that this option is
1657 -- specified (on i386, at least).
1658 -- -install_name
1659 -- Mac OS/X stores the path where a dynamic library is (to
1660 -- be) installed in the library itself. It's called the
1661 -- "install name" of the library. Then any library or
1662 -- executable that links against it before it's installed
1663 -- will search for it in its ultimate install location.
1664 -- By default we set the install name to the absolute path
1665 -- at build time, but it can be overridden by the
1666 -- -dylib-install-name option passed to ghc. Cabal does
1667 -- this.
1668 -------------------------------------------------------------------
1669
1670 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1671
1672 instName <- case dylibInstallName dflags of
1673 Just n -> return n
1674 Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
1675 runLink dflags (
1676 map Option verbFlags
1677 ++ [ Option "-dynamiclib"
1678 , Option "-o"
1679 , FileOption "" output_fn
1680 ]
1681 ++ map Option o_files
1682 ++ [ Option "-undefined",
1683 Option "dynamic_lookup",
1684 Option "-single_module" ]
1685 ++ (if platformArch platform == ArchX86_64
1686 then [ ]
1687 else [ Option "-Wl,-read_only_relocs,suppress" ])
1688 ++ [ Option "-install_name", Option instName ]
1689 ++ map Option lib_path_opts
1690 ++ extra_ld_inputs
1691 ++ map Option framework_opts
1692 ++ map Option pkg_lib_path_opts
1693 ++ map Option pkg_link_opts
1694 ++ map Option pkg_framework_opts
1695 )
1696 OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target")
1697 _ -> do
1698 -------------------------------------------------------------------
1699 -- Making a DSO
1700 -------------------------------------------------------------------
1701
1702 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1703 let bsymbolicFlag = -- we need symbolic linking to resolve
1704 -- non-PIC intra-package-relocations
1705 ["-Wl,-Bsymbolic"]
1706
1707 runLink dflags (
1708 map Option verbFlags
1709 ++ [ Option "-o"
1710 , FileOption "" output_fn
1711 ]
1712 ++ map Option o_files
1713 ++ [ Option "-shared" ]
1714 ++ map Option bsymbolicFlag
1715 -- Set the library soname. We use -h rather than -soname as
1716 -- Solaris 10 doesn't support the latter:
1717 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
1718 ++ extra_ld_inputs
1719 ++ map Option lib_path_opts
1720 ++ map Option pkg_lib_path_opts
1721 ++ map Option pkg_link_opts
1722 )
1723
1724 getPkgFrameworkOpts :: DynFlags -> Platform -> [PackageKey] -> IO [String]
1725 getPkgFrameworkOpts dflags platform dep_packages
1726 | platformUsesFrameworks platform = do
1727 pkg_framework_path_opts <- do
1728 pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1729 return $ map ("-F" ++) pkg_framework_paths
1730
1731 pkg_framework_opts <- do
1732 pkg_frameworks <- getPackageFrameworks dflags dep_packages
1733 return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1734
1735 return (pkg_framework_path_opts ++ pkg_framework_opts)
1736
1737 | otherwise = return []
1738
1739 getFrameworkOpts :: DynFlags -> Platform -> [String]
1740 getFrameworkOpts dflags platform
1741 | platformUsesFrameworks platform = framework_path_opts ++ framework_opts
1742 | otherwise = []
1743 where
1744 framework_paths = frameworkPaths dflags
1745 framework_path_opts = map ("-F" ++) framework_paths
1746
1747 frameworks = cmdlineFrameworks dflags
1748 -- reverse because they're added in reverse order from the cmd line:
1749 framework_opts = concat [ ["-framework", fw]
1750 | fw <- reverse frameworks ]