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