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