Replace hooks by callbacks in RtsConfig (#8785)
[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, Trac #10110
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 {- Note [ELF needed shared libs]
723
724 Some distributions change the link editor's default handling of
725 ELF DT_NEEDED tags to include only those shared objects that are
726 needed to resolve undefined symbols. For Template Haskell we need
727 the last temporary shared library also if it is not needed for the
728 currently linked temporary shared library. We specify --no-as-needed
729 to override the default. This flag exists in GNU ld and GNU gold.
730
731 The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
732 (Mach-O) the flag is not needed.
733
734 -}
735
736 neededLinkArgs :: LinkerInfo -> [Option]
737 neededLinkArgs (GnuLD o) = o
738 neededLinkArgs (GnuGold o) = o
739 neededLinkArgs (DarwinLD o) = o
740 neededLinkArgs (SolarisLD o) = o
741 neededLinkArgs UnknownLD = []
742
743 -- Grab linker info and cache it in DynFlags.
744 getLinkerInfo :: DynFlags -> IO LinkerInfo
745 getLinkerInfo dflags = do
746 info <- readIORef (rtldInfo dflags)
747 case info of
748 Just v -> return v
749 Nothing -> do
750 v <- getLinkerInfo' dflags
751 writeIORef (rtldInfo dflags) (Just v)
752 return v
753
754 -- See Note [Run-time linker info].
755 getLinkerInfo' :: DynFlags -> IO LinkerInfo
756 getLinkerInfo' dflags = do
757 let platform = targetPlatform dflags
758 os = platformOS platform
759 (pgm,args0) = pgm_l dflags
760 args1 = map Option (getOpts dflags opt_l)
761 args2 = args0 ++ args1
762 args3 = filter notNull (map showOpt args2)
763
764 -- Try to grab the info from the process output.
765 parseLinkerInfo stdo _stde _exitc
766 | any ("GNU ld" `isPrefixOf`) stdo =
767 -- GNU ld specifically needs to use less memory. This especially
768 -- hurts on small object files. Trac #5240.
769 -- Set DT_NEEDED for all shared libraries. Trac #10110.
770 return (GnuLD $ map Option ["-Wl,--hash-size=31",
771 "-Wl,--reduce-memory-overheads",
772 -- ELF specific flag
773 -- see Note [ELF needed shared libs]
774 "-Wl,--no-as-needed"])
775
776 | any ("GNU gold" `isPrefixOf`) stdo =
777 -- GNU gold only needs --no-as-needed. Trac #10110.
778 -- ELF specific flag, see Note [ELF needed shared libs]
779 return (GnuGold [Option "-Wl,--no-as-needed"])
780
781 -- Unknown linker.
782 | otherwise = fail "invalid --version output, or linker is unsupported"
783
784 -- Process the executable call
785 info <- catchIO (do
786 case os of
787 OSSolaris2 ->
788 -- Solaris uses its own Solaris linker. Even all
789 -- GNU C are recommended to configure with Solaris
790 -- linker instead of using GNU binutils linker. Also
791 -- all GCC distributed with Solaris follows this rule
792 -- precisely so we assume here, the Solaris linker is
793 -- used.
794 return $ SolarisLD []
795 OSDarwin ->
796 -- Darwin has neither GNU Gold or GNU LD, but a strange linker
797 -- that doesn't support --version. We can just assume that's
798 -- what we're using.
799 return $ DarwinLD []
800 OSiOS ->
801 -- Ditto for iOS
802 return $ DarwinLD []
803 OSMinGW32 ->
804 -- GHC doesn't support anything but GNU ld on Windows anyway.
805 -- Process creation is also fairly expensive on win32, so
806 -- we short-circuit here.
807 return $ GnuLD $ map Option
808 [ -- Reduce ld memory usage
809 "-Wl,--hash-size=31"
810 , "-Wl,--reduce-memory-overheads"
811 -- Increase default stack, see
812 -- Note [Windows stack usage]
813 , "-Xlinker", "--stack=0x800000,0x800000" ]
814 _ -> do
815 -- In practice, we use the compiler as the linker here. Pass
816 -- -Wl,--version to get linker version info.
817 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
818 (["-Wl,--version"] ++ args3)
819 en_locale_env
820 -- Split the output by lines to make certain kinds
821 -- of processing easier. In particular, 'clang' and 'gcc'
822 -- have slightly different outputs for '-Wl,--version', but
823 -- it's still easy to figure out.
824 parseLinkerInfo (lines stdo) (lines stde) exitc
825 )
826 (\err -> do
827 debugTraceMsg dflags 2
828 (text "Error (figuring out linker information):" <+>
829 text (show err))
830 errorMsg dflags $ hang (text "Warning:") 9 $
831 text "Couldn't figure out linker information!" $$
832 text "Make sure you're using GNU ld, GNU gold" <+>
833 text "or the built in OS X linker, etc."
834 return UnknownLD)
835 return info
836
837 -- Grab compiler info and cache it in DynFlags.
838 getCompilerInfo :: DynFlags -> IO CompilerInfo
839 getCompilerInfo dflags = do
840 info <- readIORef (rtccInfo dflags)
841 case info of
842 Just v -> return v
843 Nothing -> do
844 v <- getCompilerInfo' dflags
845 writeIORef (rtccInfo dflags) (Just v)
846 return v
847
848 -- See Note [Run-time linker info].
849 getCompilerInfo' :: DynFlags -> IO CompilerInfo
850 getCompilerInfo' dflags = do
851 let (pgm,_) = pgm_c dflags
852 -- Try to grab the info from the process output.
853 parseCompilerInfo _stdo stde _exitc
854 -- Regular GCC
855 | any ("gcc version" `isPrefixOf`) stde =
856 return GCC
857 -- Regular clang
858 | any ("clang version" `isPrefixOf`) stde =
859 return Clang
860 -- XCode 5.1 clang
861 | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
862 return AppleClang51
863 -- XCode 5 clang
864 | any ("Apple LLVM version" `isPrefixOf`) stde =
865 return AppleClang
866 -- XCode 4.1 clang
867 | any ("Apple clang version" `isPrefixOf`) stde =
868 return AppleClang
869 -- Unknown linker.
870 | otherwise = fail "invalid -v output, or compiler is unsupported"
871
872 -- Process the executable call
873 info <- catchIO (do
874 (exitc, stdo, stde) <-
875 readProcessEnvWithExitCode pgm ["-v"] en_locale_env
876 -- Split the output by lines to make certain kinds
877 -- of processing easier.
878 parseCompilerInfo (lines stdo) (lines stde) exitc
879 )
880 (\err -> do
881 debugTraceMsg dflags 2
882 (text "Error (figuring out C compiler information):" <+>
883 text (show err))
884 errorMsg dflags $ hang (text "Warning:") 9 $
885 text "Couldn't figure out C compiler information!" $$
886 text "Make sure you're using GNU gcc, or clang"
887 return UnknownCC)
888 return info
889
890 runLink :: DynFlags -> [Option] -> IO ()
891 runLink dflags args = do
892 -- See Note [Run-time linker info]
893 linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
894 let (p,args0) = pgm_l dflags
895 args1 = map Option (getOpts dflags opt_l)
896 args2 = args0 ++ linkargs ++ args1 ++ args
897 mb_env <- getGccEnv args2
898 runSomethingFiltered dflags ld_filter "Linker" p args2 mb_env
899 where
900 ld_filter = case (platformOS (targetPlatform dflags)) of
901 OSSolaris2 -> sunos_ld_filter
902 _ -> id
903 {-
904 SunOS/Solaris ld emits harmless warning messages about unresolved
905 symbols in case of compiling into shared library when we do not
906 link against all the required libs. That is the case of GHC which
907 does not link against RTS library explicitly in order to be able to
908 choose the library later based on binary application linking
909 parameters. The warnings look like:
910
911 Undefined first referenced
912 symbol in file
913 stg_ap_n_fast ./T2386_Lib.o
914 stg_upd_frame_info ./T2386_Lib.o
915 templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
916 templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
917 templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
918 templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
919 newCAF ./T2386_Lib.o
920 stg_bh_upd_frame_info ./T2386_Lib.o
921 stg_ap_ppp_fast ./T2386_Lib.o
922 templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
923 stg_ap_p_fast ./T2386_Lib.o
924 stg_ap_pp_fast ./T2386_Lib.o
925 ld: warning: symbol referencing errors
926
927 this is actually coming from T2386 testcase. The emitting of those
928 warnings is also a reason why so many TH testcases fail on Solaris.
929
930 Following filter code is SunOS/Solaris linker specific and should
931 filter out only linker warnings. Please note that the logic is a
932 little bit more complex due to the simple reason that we need to preserve
933 any other linker emitted messages. If there are any. Simply speaking
934 if we see "Undefined" and later "ld: warning:..." then we omit all
935 text between (including) the marks. Otherwise we copy the whole output.
936 -}
937 sunos_ld_filter :: String -> String
938 sunos_ld_filter = unlines . sunos_ld_filter' . lines
939 sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
940 then (ld_prefix x) ++ (ld_postfix x)
941 else x
942 breakStartsWith x y = break (isPrefixOf x) y
943 ld_prefix = fst . breakStartsWith "Undefined"
944 undefined_found = not . null . snd . breakStartsWith "Undefined"
945 ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
946 ld_postfix = tail . snd . ld_warn_break
947 ld_warning_found = not . null . snd . ld_warn_break
948
949
950 runLibtool :: DynFlags -> [Option] -> IO ()
951 runLibtool dflags args = do
952 linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
953 let args1 = map Option (getOpts dflags opt_l)
954 args2 = [Option "-static"] ++ args1 ++ args ++ linkargs
955 libtool = pgm_libtool dflags
956 mb_env <- getGccEnv args2
957 runSomethingFiltered dflags id "Linker" libtool args2 mb_env
958
959 runMkDLL :: DynFlags -> [Option] -> IO ()
960 runMkDLL dflags args = do
961 let (p,args0) = pgm_dll dflags
962 args1 = args0 ++ args
963 mb_env <- getGccEnv (args0++args)
964 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
965
966 runWindres :: DynFlags -> [Option] -> IO ()
967 runWindres dflags args = do
968 let (gcc, gcc_args) = pgm_c dflags
969 windres = pgm_windres dflags
970 opts = map Option (getOpts dflags opt_windres)
971 quote x = "\"" ++ x ++ "\""
972 args' = -- If windres.exe and gcc.exe are in a directory containing
973 -- spaces then windres fails to run gcc. We therefore need
974 -- to tell it what command to use...
975 Option ("--preprocessor=" ++
976 unwords (map quote (gcc :
977 map showOpt gcc_args ++
978 map showOpt opts ++
979 ["-E", "-xc", "-DRC_INVOKED"])))
980 -- ...but if we do that then if windres calls popen then
981 -- it can't understand the quoting, so we have to use
982 -- --use-temp-file so that it interprets it correctly.
983 -- See #1828.
984 : Option "--use-temp-file"
985 : args
986 mb_env <- getGccEnv gcc_args
987 runSomethingFiltered dflags id "Windres" windres args' mb_env
988
989 touch :: DynFlags -> String -> String -> IO ()
990 touch dflags purpose arg =
991 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
992
993 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
994 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
995
996 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
997 -> IO ()
998 copyWithHeader dflags purpose maybe_header from to = do
999 showPass dflags purpose
1000
1001 hout <- openBinaryFile to WriteMode
1002 hin <- openBinaryFile from ReadMode
1003 ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
1004 maybe (return ()) (header hout) maybe_header
1005 hPutStr hout ls
1006 hClose hout
1007 hClose hin
1008 where
1009 -- write the header string in UTF-8. The header is something like
1010 -- {-# LINE "foo.hs" #-}
1011 -- and we want to make sure a Unicode filename isn't mangled.
1012 header h str = do
1013 hSetEncoding h utf8
1014 hPutStr h str
1015 hSetBinaryMode h True
1016
1017 -- | read the contents of the named section in an ELF object as a
1018 -- String.
1019 readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
1020 readElfSection _dflags section exe = do
1021 let
1022 prog = "readelf"
1023 args = [Option "-p", Option section, FileOption "" exe]
1024 --
1025 r <- readProcessEnvWithExitCode prog (filter notNull (map showOpt args))
1026 en_locale_env
1027 case r of
1028 (ExitSuccess, out, _err) -> return (doFilter (lines out))
1029 _ -> return Nothing
1030 where
1031 doFilter [] = Nothing
1032 doFilter (s:r) = case readP_to_S parse s of
1033 [(p,"")] -> Just p
1034 _r -> doFilter r
1035 where parse = do
1036 skipSpaces
1037 _ <- R.char '['
1038 skipSpaces
1039 _ <- string "0]"
1040 skipSpaces
1041 munch (const True)
1042
1043 {-
1044 ************************************************************************
1045 * *
1046 \subsection{Managing temporary files
1047 * *
1048 ************************************************************************
1049 -}
1050
1051 cleanTempDirs :: DynFlags -> IO ()
1052 cleanTempDirs dflags
1053 = unless (gopt Opt_KeepTmpFiles dflags)
1054 $ mask_
1055 $ do let ref = dirsToClean dflags
1056 ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
1057 removeTmpDirs dflags (Map.elems ds)
1058
1059 cleanTempFiles :: DynFlags -> IO ()
1060 cleanTempFiles dflags
1061 = unless (gopt Opt_KeepTmpFiles dflags)
1062 $ mask_
1063 $ do let ref = filesToClean dflags
1064 fs <- atomicModifyIORef' ref $ \fs -> ([],fs)
1065 removeTmpFiles dflags fs
1066
1067 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
1068 cleanTempFilesExcept dflags dont_delete
1069 = unless (gopt Opt_KeepTmpFiles dflags)
1070 $ mask_
1071 $ do let ref = filesToClean dflags
1072 to_delete <- atomicModifyIORef' ref $ \files ->
1073 let (to_keep,to_delete) = partition (`elem` dont_delete) files
1074 in (to_keep,to_delete)
1075 removeTmpFiles dflags to_delete
1076
1077
1078 -- Return a unique numeric temp file suffix
1079 newTempSuffix :: DynFlags -> IO Int
1080 newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
1081
1082 -- Find a temporary name that doesn't already exist.
1083 newTempName :: DynFlags -> Suffix -> IO FilePath
1084 newTempName dflags extn
1085 = do d <- getTempDir dflags
1086 x <- getProcessID
1087 findTempName (d </> "ghc" ++ show x ++ "_")
1088 where
1089 findTempName :: FilePath -> IO FilePath
1090 findTempName prefix
1091 = do n <- newTempSuffix dflags
1092 let filename = prefix ++ show n <.> extn
1093 b <- doesFileExist filename
1094 if b then findTempName prefix
1095 else do -- clean it up later
1096 consIORef (filesToClean dflags) filename
1097 return filename
1098
1099 newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String)
1100 newTempLibName dflags extn
1101 = do d <- getTempDir dflags
1102 x <- getProcessID
1103 findTempName d ("ghc" ++ show x ++ "_")
1104 where
1105 findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
1106 findTempName dir prefix
1107 = do n <- newTempSuffix dflags
1108 let libname = prefix ++ show n
1109 filename = dir </> "lib" ++ libname <.> extn
1110 b <- doesFileExist filename
1111 if b then findTempName dir prefix
1112 else do -- clean it up later
1113 consIORef (filesToClean dflags) filename
1114 return (filename, dir, libname)
1115
1116
1117 -- Return our temporary directory within tmp_dir, creating one if we
1118 -- don't have one yet.
1119 getTempDir :: DynFlags -> IO FilePath
1120 getTempDir dflags = do
1121 mapping <- readIORef dir_ref
1122 case Map.lookup tmp_dir mapping of
1123 Nothing -> do
1124 pid <- getProcessID
1125 let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
1126 mask_ $ mkTempDir prefix
1127 Just dir -> return dir
1128 where
1129 tmp_dir = tmpDir dflags
1130 dir_ref = dirsToClean dflags
1131
1132 mkTempDir :: FilePath -> IO FilePath
1133 mkTempDir prefix = do
1134 n <- newTempSuffix dflags
1135 let our_dir = prefix ++ show n
1136
1137 -- 1. Speculatively create our new directory.
1138 createDirectory our_dir
1139
1140 -- 2. Update the dirsToClean mapping unless an entry already exists
1141 -- (i.e. unless another thread beat us to it).
1142 their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
1143 case Map.lookup tmp_dir mapping of
1144 Just dir -> (mapping, Just dir)
1145 Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing)
1146
1147 -- 3. If there was an existing entry, return it and delete the
1148 -- directory we created. Otherwise return the directory we created.
1149 case their_dir of
1150 Nothing -> do
1151 debugTraceMsg dflags 2 $
1152 text "Created temporary directory:" <+> text our_dir
1153 return our_dir
1154 Just dir -> do
1155 removeDirectory our_dir
1156 return dir
1157 `catchIO` \e -> if isAlreadyExistsError e
1158 then mkTempDir prefix else ioError e
1159
1160 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
1161 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
1162 addFilesToClean dflags new_files
1163 = atomicModifyIORef' (filesToClean dflags) $ \files -> (new_files++files, ())
1164
1165 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
1166 removeTmpDirs dflags ds
1167 = traceCmd dflags "Deleting temp dirs"
1168 ("Deleting: " ++ unwords ds)
1169 (mapM_ (removeWith dflags removeDirectory) ds)
1170
1171 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
1172 removeTmpFiles dflags fs
1173 = warnNon $
1174 traceCmd dflags "Deleting temp files"
1175 ("Deleting: " ++ unwords deletees)
1176 (mapM_ (removeWith dflags removeFile) deletees)
1177 where
1178 -- Flat out refuse to delete files that are likely to be source input
1179 -- files (is there a worse bug than having a compiler delete your source
1180 -- files?)
1181 --
1182 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
1183 -- the condition.
1184 warnNon act
1185 | null non_deletees = act
1186 | otherwise = do
1187 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
1188 act
1189
1190 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
1191
1192 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
1193 removeWith dflags remover f = remover f `catchIO`
1194 (\e ->
1195 let msg = if isDoesNotExistError e
1196 then ptext (sLit "Warning: deleting non-existent") <+> text f
1197 else ptext (sLit "Warning: exception raised when deleting")
1198 <+> text f <> colon
1199 $$ text (show e)
1200 in debugTraceMsg dflags 2 msg
1201 )
1202
1203 -----------------------------------------------------------------------------
1204 -- Running an external program
1205
1206 runSomething :: DynFlags
1207 -> String -- For -v message
1208 -> String -- Command name (possibly a full path)
1209 -- assumed already dos-ified
1210 -> [Option] -- Arguments
1211 -- runSomething will dos-ify them
1212 -> IO ()
1213
1214 runSomething dflags phase_name pgm args =
1215 runSomethingFiltered dflags id phase_name pgm args Nothing
1216
1217 runSomethingFiltered
1218 :: DynFlags -> (String->String) -> String -> String -> [Option]
1219 -> Maybe [(String,String)] -> IO ()
1220
1221 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
1222 runSomethingWith dflags phase_name pgm args $ \real_args -> do
1223 r <- builderMainLoop dflags filter_fn pgm real_args mb_env
1224 return (r,())
1225
1226 runSomethingWith
1227 :: DynFlags -> String -> String -> [Option]
1228 -> ([String] -> IO (ExitCode, a))
1229 -> IO a
1230
1231 runSomethingWith dflags phase_name pgm args io = do
1232 let real_args = filter notNull (map showOpt args)
1233 cmdLine = showCommandForUser pgm real_args
1234 traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
1235
1236 handleProc :: String -> String -> IO (ExitCode, r) -> IO r
1237 handleProc pgm phase_name proc = do
1238 (rc, r) <- proc `catchIO` handler
1239 case rc of
1240 ExitSuccess{} -> return r
1241 ExitFailure n
1242 -- rawSystem returns (ExitFailure 127) if the exec failed for any
1243 -- reason (eg. the program doesn't exist). This is the only clue
1244 -- we have, but we need to report something to the user because in
1245 -- the case of a missing program there will otherwise be no output
1246 -- at all.
1247 | n == 127 -> does_not_exist
1248 | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc)
1249 where
1250 handler err =
1251 if IO.isDoesNotExistError err
1252 then does_not_exist
1253 else IO.ioError err
1254
1255 does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
1256
1257
1258 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
1259 -> [String] -> Maybe [(String, String)]
1260 -> IO ExitCode
1261 builderMainLoop dflags filter_fn pgm real_args mb_env = do
1262 chan <- newChan
1263 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
1264
1265 -- and run a loop piping the output from the compiler to the log_action in DynFlags
1266 hSetBuffering hStdOut LineBuffering
1267 hSetBuffering hStdErr LineBuffering
1268 _ <- forkIO (readerProc chan hStdOut filter_fn)
1269 _ <- forkIO (readerProc chan hStdErr filter_fn)
1270 -- we don't want to finish until 2 streams have been completed
1271 -- (stdout and stderr)
1272 -- nor until 1 exit code has been retrieved.
1273 rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
1274 -- after that, we're done here.
1275 hClose hStdIn
1276 hClose hStdOut
1277 hClose hStdErr
1278 return rc
1279 where
1280 -- status starts at zero, and increments each time either
1281 -- a reader process gets EOF, or the build proc exits. We wait
1282 -- for all of these to happen (status==3).
1283 -- ToDo: we should really have a contingency plan in case any of
1284 -- the threads dies, such as a timeout.
1285 loop _ _ 0 0 exitcode = return exitcode
1286 loop chan hProcess t p exitcode = do
1287 mb_code <- if p > 0
1288 then getProcessExitCode hProcess
1289 else return Nothing
1290 case mb_code of
1291 Just code -> loop chan hProcess t (p-1) code
1292 Nothing
1293 | t > 0 -> do
1294 msg <- readChan chan
1295 case msg of
1296 BuildMsg msg -> do
1297 log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
1298 loop chan hProcess t p exitcode
1299 BuildError loc msg -> do
1300 log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
1301 loop chan hProcess t p exitcode
1302 EOF ->
1303 loop chan hProcess (t-1) p exitcode
1304 | otherwise -> loop chan hProcess t p exitcode
1305
1306 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
1307 readerProc chan hdl filter_fn =
1308 (do str <- hGetContents hdl
1309 loop (linesPlatform (filter_fn str)) Nothing)
1310 `finally`
1311 writeChan chan EOF
1312 -- ToDo: check errors more carefully
1313 -- ToDo: in the future, the filter should be implemented as
1314 -- a stream transformer.
1315 where
1316 loop [] Nothing = return ()
1317 loop [] (Just err) = writeChan chan err
1318 loop (l:ls) in_err =
1319 case in_err of
1320 Just err@(BuildError srcLoc msg)
1321 | leading_whitespace l -> do
1322 loop ls (Just (BuildError srcLoc (msg $$ text l)))
1323 | otherwise -> do
1324 writeChan chan err
1325 checkError l ls
1326 Nothing -> do
1327 checkError l ls
1328 _ -> panic "readerProc/loop"
1329
1330 checkError l ls
1331 = case parseError l of
1332 Nothing -> do
1333 writeChan chan (BuildMsg (text l))
1334 loop ls Nothing
1335 Just (file, lineNum, colNum, msg) -> do
1336 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
1337 loop ls (Just (BuildError srcLoc (text msg)))
1338
1339 leading_whitespace [] = False
1340 leading_whitespace (x:_) = isSpace x
1341
1342 parseError :: String -> Maybe (String, Int, Int, String)
1343 parseError s0 = case breakColon s0 of
1344 Just (filename, s1) ->
1345 case breakIntColon s1 of
1346 Just (lineNum, s2) ->
1347 case breakIntColon s2 of
1348 Just (columnNum, s3) ->
1349 Just (filename, lineNum, columnNum, s3)
1350 Nothing ->
1351 Just (filename, lineNum, 0, s2)
1352 Nothing -> Nothing
1353 Nothing -> Nothing
1354
1355 breakColon :: String -> Maybe (String, String)
1356 breakColon xs = case break (':' ==) xs of
1357 (ys, _:zs) -> Just (ys, zs)
1358 _ -> Nothing
1359
1360 breakIntColon :: String -> Maybe (Int, String)
1361 breakIntColon xs = case break (':' ==) xs of
1362 (ys, _:zs)
1363 | not (null ys) && all isAscii ys && all isDigit ys ->
1364 Just (read ys, zs)
1365 _ -> Nothing
1366
1367 data BuildMessage
1368 = BuildMsg !SDoc
1369 | BuildError !SrcLoc !SDoc
1370 | EOF
1371
1372 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
1373 -- trace the command (at two levels of verbosity)
1374 traceCmd dflags phase_name cmd_line action
1375 = do { let verb = verbosity dflags
1376 ; showPass dflags phase_name
1377 ; debugTraceMsg dflags 3 (text cmd_line)
1378 ; case flushErr dflags of
1379 FlushErr io -> io
1380
1381 -- And run it!
1382 ; action `catchIO` handle_exn verb
1383 }
1384 where
1385 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
1386 ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
1387 ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
1388
1389 {-
1390 ************************************************************************
1391 * *
1392 \subsection{Support code}
1393 * *
1394 ************************************************************************
1395 -}
1396
1397 -----------------------------------------------------------------------------
1398 -- Define getBaseDir :: IO (Maybe String)
1399
1400 getBaseDir :: IO (Maybe String)
1401 #if defined(mingw32_HOST_OS)
1402 -- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe,
1403 -- return the path $(stuff)/lib.
1404 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1405 where
1406 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1407 ret <- c_GetModuleFileName nullPtr buf size
1408 case ret of
1409 0 -> return Nothing
1410 _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
1411 | otherwise -> try_size (size * 2)
1412
1413 rootDir s = case splitFileName $ normalise s of
1414 (d, ghc_exe)
1415 | lower ghc_exe `elem` ["ghc.exe",
1416 "ghc-stage1.exe",
1417 "ghc-stage2.exe",
1418 "ghc-stage3.exe"] ->
1419 case splitFileName $ takeDirectory d of
1420 -- ghc is in $topdir/bin/ghc.exe
1421 (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
1422 _ -> fail
1423 _ -> fail
1424 where fail = panic ("can't decompose ghc.exe path: " ++ show s)
1425 lower = map toLower
1426
1427 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1428 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1429 #else
1430 getBaseDir = return Nothing
1431 #endif
1432
1433 #ifdef mingw32_HOST_OS
1434 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
1435 #else
1436 getProcessID :: IO Int
1437 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
1438 #endif
1439
1440 -- Divvy up text stream into lines, taking platform dependent
1441 -- line termination into account.
1442 linesPlatform :: String -> [String]
1443 #if !defined(mingw32_HOST_OS)
1444 linesPlatform ls = lines ls
1445 #else
1446 linesPlatform "" = []
1447 linesPlatform xs =
1448 case lineBreak xs of
1449 (as,xs1) -> as : linesPlatform xs1
1450 where
1451 lineBreak "" = ("","")
1452 lineBreak ('\r':'\n':xs) = ([],xs)
1453 lineBreak ('\n':xs) = ([],xs)
1454 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
1455
1456 #endif
1457
1458 linkDynLib :: DynFlags -> [String] -> [PackageKey] -> IO ()
1459 linkDynLib dflags0 o_files dep_packages
1460 = do
1461 let -- This is a rather ugly hack to fix dynamically linked
1462 -- GHC on Windows. If GHC is linked with -threaded, then
1463 -- it links against libHSrts_thr. But if base is linked
1464 -- against libHSrts, then both end up getting loaded,
1465 -- and things go wrong. We therefore link the libraries
1466 -- with the same RTS flags that we link GHC with.
1467 dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0
1468 else dflags0
1469 dflags2 = if cGhcDebugged then addWay' WayDebug dflags1
1470 else dflags1
1471 dflags = updateWays dflags2
1472
1473 verbFlags = getVerbFlags dflags
1474 o_file = outputFile dflags
1475
1476 pkgs <- getPreloadPackagesAnd dflags dep_packages
1477
1478 let pkg_lib_paths = collectLibraryPaths pkgs
1479 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1480 get_pkg_lib_path_opts l
1481 | ( osElfTarget (platformOS (targetPlatform dflags)) ||
1482 osMachOTarget (platformOS (targetPlatform dflags)) ) &&
1483 dynLibLoader dflags == SystemDependent &&
1484 not (gopt Opt_Static dflags)
1485 = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1486 | otherwise = ["-L" ++ l]
1487
1488 let lib_paths = libraryPaths dflags
1489 let lib_path_opts = map ("-L"++) lib_paths
1490
1491 -- We don't want to link our dynamic libs against the RTS package,
1492 -- because the RTS lib comes in several flavours and we want to be
1493 -- able to pick the flavour when a binary is linked.
1494 -- On Windows we need to link the RTS import lib as Windows does
1495 -- not allow undefined symbols.
1496 -- The RTS library path is still added to the library search path
1497 -- above in case the RTS is being explicitly linked in (see #3807).
1498 let platform = targetPlatform dflags
1499 os = platformOS platform
1500 pkgs_no_rts = case os of
1501 OSMinGW32 ->
1502 pkgs
1503 _ ->
1504 filter ((/= rtsPackageKey) . packageConfigId) pkgs
1505 let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
1506 in package_hs_libs ++ extra_libs ++ other_flags
1507
1508 -- probably _stub.o files
1509 -- and last temporary shared object file
1510 let extra_ld_inputs = ldInputs dflags
1511
1512 case os of
1513 OSMinGW32 -> do
1514 -------------------------------------------------------------
1515 -- Making a DLL
1516 -------------------------------------------------------------
1517 let output_fn = case o_file of
1518 Just s -> s
1519 Nothing -> "HSdll.dll"
1520
1521 runLink dflags (
1522 map Option verbFlags
1523 ++ [ Option "-o"
1524 , FileOption "" output_fn
1525 , Option "-shared"
1526 ] ++
1527 [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1528 | gopt Opt_SharedImplib dflags
1529 ]
1530 ++ map (FileOption "") o_files
1531
1532 -- Permit the linker to auto link _symbol to _imp_symbol
1533 -- This lets us link against DLLs without needing an "import library"
1534 ++ [Option "-Wl,--enable-auto-import"]
1535
1536 ++ extra_ld_inputs
1537 ++ map Option (
1538 lib_path_opts
1539 ++ pkg_lib_path_opts
1540 ++ pkg_link_opts
1541 ))
1542 OSDarwin -> do
1543 -------------------------------------------------------------------
1544 -- Making a darwin dylib
1545 -------------------------------------------------------------------
1546 -- About the options used for Darwin:
1547 -- -dynamiclib
1548 -- Apple's way of saying -shared
1549 -- -undefined dynamic_lookup:
1550 -- Without these options, we'd have to specify the correct
1551 -- dependencies for each of the dylibs. Note that we could
1552 -- (and should) do without this for all libraries except
1553 -- the RTS; all we need to do is to pass the correct
1554 -- HSfoo_dyn.dylib files to the link command.
1555 -- This feature requires Mac OS X 10.3 or later; there is
1556 -- a similar feature, -flat_namespace -undefined suppress,
1557 -- which works on earlier versions, but it has other
1558 -- disadvantages.
1559 -- -single_module
1560 -- Build the dynamic library as a single "module", i.e. no
1561 -- dynamic binding nonsense when referring to symbols from
1562 -- within the library. The NCG assumes that this option is
1563 -- specified (on i386, at least).
1564 -- -install_name
1565 -- Mac OS/X stores the path where a dynamic library is (to
1566 -- be) installed in the library itself. It's called the
1567 -- "install name" of the library. Then any library or
1568 -- executable that links against it before it's installed
1569 -- will search for it in its ultimate install location.
1570 -- By default we set the install name to the absolute path
1571 -- at build time, but it can be overridden by the
1572 -- -dylib-install-name option passed to ghc. Cabal does
1573 -- this.
1574 -------------------------------------------------------------------
1575
1576 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1577
1578 instName <- case dylibInstallName dflags of
1579 Just n -> return n
1580 Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
1581 runLink dflags (
1582 map Option verbFlags
1583 ++ [ Option "-dynamiclib"
1584 , Option "-o"
1585 , FileOption "" output_fn
1586 ]
1587 ++ map Option o_files
1588 ++ [ Option "-undefined",
1589 Option "dynamic_lookup",
1590 Option "-single_module" ]
1591 ++ (if platformArch platform == ArchX86_64
1592 then [ ]
1593 else [ Option "-Wl,-read_only_relocs,suppress" ])
1594 ++ [ Option "-install_name", Option instName ]
1595 ++ map Option lib_path_opts
1596 ++ extra_ld_inputs
1597 ++ map Option pkg_lib_path_opts
1598 ++ map Option pkg_link_opts
1599 )
1600 OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target")
1601 _ -> do
1602 -------------------------------------------------------------------
1603 -- Making a DSO
1604 -------------------------------------------------------------------
1605
1606 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1607 let bsymbolicFlag = -- we need symbolic linking to resolve
1608 -- non-PIC intra-package-relocations
1609 ["-Wl,-Bsymbolic"]
1610
1611 runLink dflags (
1612 map Option verbFlags
1613 ++ [ Option "-o"
1614 , FileOption "" output_fn
1615 ]
1616 ++ map Option o_files
1617 ++ [ Option "-shared" ]
1618 ++ map Option bsymbolicFlag
1619 -- Set the library soname. We use -h rather than -soname as
1620 -- Solaris 10 doesn't support the latter:
1621 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
1622 ++ extra_ld_inputs
1623 ++ map Option lib_path_opts
1624 ++ map Option pkg_lib_path_opts
1625 ++ map Option pkg_link_opts
1626 )