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