1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2001-2003
5 -- Access to system tools: gcc, cp, rm etc
7 -----------------------------------------------------------------------------
10 {-# OPTIONS -fno-cse #-}
11 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
17 -- Interface to system tools
18 runUnlit, runCpp, runCc, -- [Option] -> IO ()
19 runPp, -- [Option] -> IO ()
20 runMangle, runSplit, -- [Option] -> IO ()
21 runAs, runLink, -- [Option] -> IO ()
25 touch, -- String -> String -> IO ()
30 -- Temporary-file management
33 cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
40 #include "HsVersions.h"
55 import System.Environment
56 import System.FilePath
58 import System.IO.Error as IO
59 import System.Directory
64 #ifndef mingw32_HOST_OS
65 import qualified System.Posix.Internals
66 #else /* Must be Win32 */
68 import CString ( CString, peekCString )
71 import System.Process ( runInteractiveProcess, getProcessExitCode )
72 import Control.Concurrent
74 import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
77 How GHC finds its files
78 ~~~~~~~~~~~~~~~~~~~~~~~
82 GHC needs various support files (library packages, RTS etc), plus
83 various auxiliary programs (cp, gcc, etc). It starts by finding topdir:
85 for "installed" topdir is the root of GHC's support files ($libdir)
86 for "in-place" topdir is the root of the build tree
89 - ghc always has a shell wrapper that passes a -B<dir> option
90 - in an installation, <dir> is $libdir
91 - in a build tree, <dir> is $TOP/inplace-datadir
92 - so we detect the build-tree case and add ".." to get us back to $TOP
95 - ghc never has a shell wrapper.
96 - we can find the location of the ghc binary, which is
97 $topdir/bin/ghc.exe in an installation, or
98 $topdir/ghc/stage1-inplace/ghc.exe in a build tree.
99 - we detect which one of these we have, and calculate $topdir.
102 from topdir we can find package.conf, which contains the locations of
103 almost everything else, whether we're in a build tree or installed.
106 SysTools.initSysProgs figures out exactly where all the auxiliary programs
107 are, and initialises mutable variables to make it easy to call them.
108 To to this, it makes use of definitions in Config.hs, which is a Haskell
109 file containing variables whose value is figured out by the build system.
111 Config.hs contains two sorts of things
113 cGCC, The *names* of the programs
116 etc They do *not* include paths
119 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
120 cSPLIT_DIR_REL *relative* to the root of the build tree,
121 for use when running *in-place* in a build tree (only)
125 ---------------------------------------------
126 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
128 Another hair-brained scheme for simplifying the current tool location
129 nightmare in GHC: Simon originally suggested using another
130 configuration file along the lines of GCC's specs file - which is fine
131 except that it means adding code to read yet another configuration
132 file. What I didn't notice is that the current package.conf is
133 general enough to do this:
136 {name = "tools", import_dirs = [], source_dirs = [],
137 library_dirs = [], hs_libraries = [], extra_libraries = [],
138 include_dirs = [], c_includes = [], package_deps = [],
139 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
140 extra_cc_opts = [], extra_ld_opts = []}
142 Which would have the advantage that we get to collect together in one
143 place the path-specific package stuff with the path-specific tool
146 ---------------------------------------------
148 %************************************************************************
150 \subsection{Initialisation}
152 %************************************************************************
155 initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
158 -> IO DynFlags -- Set all the mutable variables above, holding
159 -- (a) the system programs
160 -- (b) the package-config file
161 -- (c) the GHC usage message
164 initSysTools mbMinusB dflags0
165 = do { (am_installed, top_dir) <- findTopDir mbMinusB
167 -- NB: top_dir is assumed to be in standard Unix
168 -- format, '/' separated
170 ; let installed, installed_bin :: FilePath -> FilePath
171 installed_bin pgm = top_dir </> pgm
172 installed file = top_dir </> file
173 inplace dir pgm = top_dir </> dir </> pgm
176 | am_installed = installed "package.conf"
177 | otherwise = inplace "inplace-datadir" "package.conf"
180 | am_installed = installed "ghc-usage.txt"
181 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
184 | am_installed = installed "ghci-usage.txt"
185 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
187 -- For all systems, unlit, split, mangle are GHC utilities
188 -- architecture-specific stuff is done when building Config.hs
190 | am_installed = installed_bin cGHC_UNLIT_PGM
191 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
193 -- split and mangle are Perl scripts
195 | am_installed = installed_bin cGHC_SPLIT_PGM
196 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
199 | am_installed = installed_bin cGHC_MANGLER_PGM
200 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
203 | am_installed = installed_bin "bin/windres"
204 | otherwise = "windres"
206 ; tmpdir <- getTemporaryDirectory
207 ; let dflags1 = setTmpDir tmpdir dflags0
209 -- Check that the package config exists
210 ; config_exists <- doesFileExist pkgconfig_path
211 ; when (not config_exists) $
212 ghcError (InstallationError
213 ("Can't find package.conf as " ++ pkgconfig_path))
215 -- On Windows, gcc and friends are distributed with GHC,
216 -- so when "installed" we look in TopDir/bin
217 -- When "in-place", or when not on Windows, we look wherever
218 -- the build-time configure script found them
220 -- The trailing "/" is absolutely essential; gcc seems
221 -- to construct file names simply by concatenating to
222 -- this -B path with no extra slash We use "/" rather
223 -- than "\\" because otherwise "\\\" is mangled
224 -- later on; although gcc_args are in NATIVE format,
226 -- (see comments with declarations of global variables)
227 gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
228 gcc_mingw_include_arg = Option ("-I" ++ installed "include/mingw/")
230 | isWindowsHost && am_installed
231 -- We tell gcc where its specs file + exes are (-B)
232 -- and also some places to pick up include files. We need
233 -- to be careful to put all necessary exes in the -B place
234 -- (as, ld, cc1, etc) since if they don't get found there,
235 -- gcc then tries to run unadorned "as", "ld", etc, and
236 -- will pick up whatever happens to be lying around in
237 -- the path, possibly including those from a cygwin
238 -- install on the target, which is exactly what we're
240 = (installed_bin "gcc", [gcc_b_arg, gcc_mingw_include_arg])
241 | otherwise = (cGCC, [])
243 | isWindowsHost && am_installed = installed_bin cGHC_PERL
244 | otherwise = cGHC_PERL
245 -- 'touch' is a GHC util for Windows
249 then installed_bin cGHC_TOUCHY_PGM
250 else inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
251 | otherwise = "touch"
252 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
253 -- a call to Perl to get the invocation of split and mangle.
254 -- On Unix, scripts are invoked using the '#!' method. Binary
255 -- installations of GHC on Unix place the correct line on the
256 -- front of the script at installation time, so we don't want
257 -- to wire-in our knowledge of $(PERL) on the host system here.
258 (split_prog, split_args)
259 | isWindowsHost = (perl_path, [Option split_script])
260 | otherwise = (split_script, [])
261 (mangle_prog, mangle_args)
262 | isWindowsHost = (perl_path, [Option mangle_script])
263 | otherwise = (mangle_script, [])
264 (mkdll_prog, mkdll_args)
266 = panic "Can't build DLLs on a non-Win32 system"
268 (installed "gcc-lib/" </> cMKDLL,
269 [ Option "--dlltool-name",
270 Option (installed "gcc-lib/" </> "dlltool"),
271 Option "--driver-name",
272 Option gcc_prog, gcc_b_arg, gcc_mingw_include_arg ])
273 | otherwise = (cMKDLL, [])
275 -- cpp is derived from gcc on all platforms
276 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
277 -- Config.hs one day.
278 ; let cpp_path = (gcc_prog, gcc_args ++
279 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
281 -- Other things being equal, as and ld are simply gcc
282 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
283 (ld_prog,ld_args) = (gcc_prog,gcc_args)
286 ghcUsagePath = ghc_usage_msg_path,
287 ghciUsagePath = ghci_usage_msg_path,
289 systemPackageConfig = pkgconfig_path,
293 pgm_c = (gcc_prog,gcc_args),
294 pgm_m = (mangle_prog,mangle_args),
295 pgm_s = (split_prog,split_args),
296 pgm_a = (as_prog,as_args),
297 pgm_l = (ld_prog,ld_args),
298 pgm_dll = (mkdll_prog,mkdll_args),
300 pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
301 pgm_windres = windres_path
302 -- Hans: this isn't right in general, but you can
303 -- elaborate it in the same way as the others
309 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
310 -> IO (Bool, -- True <=> am installed, False <=> in-place
311 String) -- TopDir (in Unix format '/' separated)
314 = do { top_dir <- get_proto
315 ; exists1 <- doesFileExist (top_dir </> "package.conf")
316 ; exists2 <- doesFileExist (top_dir </> "inplace")
317 ; let amInplace = not exists1 -- On Windows, package.conf doesn't exist
318 -- when we are inplace
319 || exists2 -- On Linux, the presence of inplace signals
320 -- that we are inplace
322 ; let real_top = if exists2 then top_dir </> ".." else top_dir
324 ; return (not amInplace, real_top)
327 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
328 get_proto = case mbMinusB of
329 Just minusb -> return (normalise minusb)
331 -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
332 case maybe_exec_dir of -- (only works on Windows;
333 -- returns Nothing on Unix)
334 Nothing -> ghcError (InstallationError "missing -B<dir> option")
335 Just dir -> return dir
339 %************************************************************************
341 \subsection{Running an external program}
343 %************************************************************************
347 runUnlit :: DynFlags -> [Option] -> IO ()
348 runUnlit dflags args = do
350 runSomething dflags "Literate pre-processor" p args
352 runCpp :: DynFlags -> [Option] -> IO ()
353 runCpp dflags args = do
354 let (p,args0) = pgm_P dflags
355 args1 = args0 ++ args
356 mb_env <- getGccEnv args1
357 runSomethingFiltered dflags id "C pre-processor" p args1 mb_env
359 runPp :: DynFlags -> [Option] -> IO ()
360 runPp dflags args = do
362 runSomething dflags "Haskell pre-processor" p args
364 runCc :: DynFlags -> [Option] -> IO ()
365 runCc dflags args = do
366 let (p,args0) = pgm_c dflags
367 args1 = args0 ++ args
368 mb_env <- getGccEnv args1
369 runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
371 -- discard some harmless warnings from gcc that we can't turn off
372 cc_filter = unlines . doFilter . lines
375 gcc gives warnings in chunks like so:
376 In file included from /foo/bar/baz.h:11,
377 from /foo/bar/baz2.h:22,
379 /foo/flibble:14: global register variable ...
380 /foo/flibble:15: warning: call-clobbered r...
381 We break it up into its chunks, remove any call-clobbered register
382 warnings from each chunk, and then delete any chunks that we have
385 doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
386 -- We can't assume that the output will start with an "In file inc..."
387 -- line, so we start off expecting a list of warnings rather than a
389 chunkWarnings :: [String] -- The location stack to use for the next
391 -> [String] -- The remaining lines to look at
392 -> [([String], [String])]
393 chunkWarnings loc_stack [] = [(loc_stack, [])]
394 chunkWarnings loc_stack xs
395 = case break loc_stack_start xs of
396 (warnings, lss:xs') ->
397 case span loc_start_continuation xs' of
399 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
400 _ -> [(loc_stack, xs)]
402 filterWarnings :: [([String], [String])] -> [([String], [String])]
403 filterWarnings [] = []
404 -- If the warnings are already empty then we are probably doing
405 -- something wrong, so don't delete anything
406 filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
407 filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
408 [] -> filterWarnings zs
409 ys' -> (xs, ys') : filterWarnings zs
411 unChunkWarnings :: [([String], [String])] -> [String]
412 unChunkWarnings [] = []
413 unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
415 loc_stack_start s = "In file included from " `isPrefixOf` s
416 loc_start_continuation s = " from " `isPrefixOf` s
418 | "warning: call-clobbered register used" `isContainedIn` w = False
421 isContainedIn :: String -> String -> Bool
422 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
424 -- If the -B<dir> option is set, add <dir> to PATH. This works around
425 -- a bug in gcc on Windows Vista where it can't find its auxiliary
426 -- binaries (see bug #1110).
427 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
431 else do env <- getEnvironment
432 return (Just (map mangle_path env))
434 (b_dirs, _) = partitionWith get_b_opt opts
436 get_b_opt (Option ('-':'B':dir)) = Left dir
437 get_b_opt other = Right other
439 mangle_path (path,paths) | map toUpper path == "PATH"
440 = (path, '\"' : head b_dirs ++ "\";" ++ paths)
441 mangle_path other = other
443 runMangle :: DynFlags -> [Option] -> IO ()
444 runMangle dflags args = do
445 let (p,args0) = pgm_m dflags
446 runSomething dflags "Mangler" p (args0++args)
448 runSplit :: DynFlags -> [Option] -> IO ()
449 runSplit dflags args = do
450 let (p,args0) = pgm_s dflags
451 runSomething dflags "Splitter" p (args0++args)
453 runAs :: DynFlags -> [Option] -> IO ()
454 runAs dflags args = do
455 let (p,args0) = pgm_a dflags
456 args1 = args0 ++ args
457 mb_env <- getGccEnv args1
458 runSomethingFiltered dflags id "Assembler" p args1 mb_env
460 runLink :: DynFlags -> [Option] -> IO ()
461 runLink dflags args = do
462 let (p,args0) = pgm_l dflags
463 args1 = args0 ++ args
464 mb_env <- getGccEnv args1
465 runSomethingFiltered dflags id "Linker" p args1 mb_env
467 runMkDLL :: DynFlags -> [Option] -> IO ()
468 runMkDLL dflags args = do
469 let (p,args0) = pgm_dll dflags
470 args1 = args0 ++ args
471 mb_env <- getGccEnv (args0++args)
472 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
474 runWindres :: DynFlags -> [Option] -> IO ()
475 runWindres dflags args = do
476 let (gcc,gcc_args) = pgm_c dflags
477 windres = pgm_windres dflags
478 mb_env <- getGccEnv gcc_args
479 runSomethingFiltered dflags id "Windres" windres
480 -- we must tell windres where to find gcc: it might not be on PATH
481 (Option ("--preprocessor=" ++
482 unwords (map quote (gcc : map showOpt gcc_args ++
483 ["-E", "-xc", "-DRC_INVOKED"])))
484 -- -- use-temp-file is required for windres to interpret the
485 -- quoting in the preprocessor arg above correctly. Without
486 -- this, windres calls the preprocessor with popen, which gets
487 -- the quoting wrong (discovered by experimentation and
488 -- reading the windres sources). See #1828.
489 : Option "--use-temp-file"
491 -- we must use the PATH workaround here too, since windres invokes gcc
494 quote x = '\"' : x ++ "\""
496 touch :: DynFlags -> String -> String -> IO ()
497 touch dflags purpose arg =
498 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
500 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
501 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
503 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
505 copyWithHeader dflags purpose maybe_header from to = do
506 showPass dflags purpose
508 h <- openFile to WriteMode
509 ls <- readFile from -- inefficient, but it'll do for now.
510 -- ToDo: speed up via slurping.
511 maybe (return ()) (hPutStr h) maybe_header
515 getExtraViaCOpts :: DynFlags -> IO [String]
516 getExtraViaCOpts dflags = do
517 f <- readFile (topDir dflags </> "extra-gcc-opts")
521 %************************************************************************
523 \subsection{Managing temporary files
525 %************************************************************************
528 GLOBAL_VAR(v_FilesToClean, [], [String] )
529 GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
533 cleanTempDirs :: DynFlags -> IO ()
535 = unless (dopt Opt_KeepTmpFiles dflags)
536 $ do ds <- readIORef v_DirsToClean
537 removeTmpDirs dflags (eltsFM ds)
538 writeIORef v_DirsToClean emptyFM
540 cleanTempFiles :: DynFlags -> IO ()
541 cleanTempFiles dflags
542 = unless (dopt Opt_KeepTmpFiles dflags)
543 $ do fs <- readIORef v_FilesToClean
544 removeTmpFiles dflags fs
545 writeIORef v_FilesToClean []
547 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
548 cleanTempFilesExcept dflags dont_delete
549 = unless (dopt Opt_KeepTmpFiles dflags)
550 $ do files <- readIORef v_FilesToClean
551 let (to_keep, to_delete) = partition (`elem` dont_delete) files
552 removeTmpFiles dflags to_delete
553 writeIORef v_FilesToClean to_keep
556 -- find a temporary name that doesn't already exist.
557 newTempName :: DynFlags -> Suffix -> IO FilePath
558 newTempName dflags extn
559 = do d <- getTempDir dflags
561 findTempName (d ++ "/ghc" ++ show x ++ "_") 0
563 findTempName :: FilePath -> Integer -> IO FilePath
564 findTempName prefix x
565 = do let filename = (prefix ++ show x) <.> extn
566 b <- doesFileExist filename
567 if b then findTempName prefix (x+1)
568 else do consIORef v_FilesToClean filename -- clean it up later
571 -- return our temporary directory within tmp_dir, creating one if we
572 -- don't have one yet
573 getTempDir :: DynFlags -> IO FilePath
574 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
575 = do mapping <- readIORef v_DirsToClean
576 case lookupFM mapping tmp_dir of
579 let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
581 mkTempDir :: Integer -> IO FilePath
583 = let dirname = prefix ++ show x
584 in do createDirectory dirname
585 let mapping' = addToFM mapping tmp_dir dirname
586 writeIORef v_DirsToClean mapping'
587 debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
590 if isAlreadyExistsError e
596 addFilesToClean :: [FilePath] -> IO ()
597 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
598 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
600 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
601 removeTmpDirs dflags ds
602 = traceCmd dflags "Deleting temp dirs"
603 ("Deleting: " ++ unwords ds)
604 (mapM_ (removeWith dflags removeDirectory) ds)
606 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
607 removeTmpFiles dflags fs
609 traceCmd dflags "Deleting temp files"
610 ("Deleting: " ++ unwords deletees)
611 (mapM_ (removeWith dflags removeFile) deletees)
613 -- Flat out refuse to delete files that are likely to be source input
614 -- files (is there a worse bug than having a compiler delete your source
617 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
620 | null non_deletees = act
622 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
625 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
627 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
628 removeWith dflags remover f = remover f `IO.catch`
630 let msg = if isDoesNotExistError e
631 then ptext (sLit "Warning: deleting non-existent") <+> text f
632 else ptext (sLit "Warning: exception raised when deleting")
635 in debugTraceMsg dflags 2 msg
638 -----------------------------------------------------------------------------
639 -- Running an external program
641 runSomething :: DynFlags
642 -> String -- For -v message
643 -> String -- Command name (possibly a full path)
644 -- assumed already dos-ified
645 -> [Option] -- Arguments
646 -- runSomething will dos-ify them
649 runSomething dflags phase_name pgm args =
650 runSomethingFiltered dflags id phase_name pgm args Nothing
653 :: DynFlags -> (String->String) -> String -> String -> [Option]
654 -> Maybe [(String,String)] -> IO ()
656 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
657 let real_args = filter notNull (map showOpt args)
658 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
659 (exit_code, doesn'tExist) <-
661 rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
663 ExitSuccess{} -> return (rc, False)
665 -- rawSystem returns (ExitFailure 127) if the exec failed for any
666 -- reason (eg. the program doesn't exist). This is the only clue
667 -- we have, but we need to report something to the user because in
668 -- the case of a missing program there will otherwise be no output
670 | n == 127 -> return (rc, True)
671 | otherwise -> return (rc, False))
672 -- Should 'rawSystem' generate an IO exception indicating that
673 -- 'pgm' couldn't be run rather than a funky return code, catch
674 -- this here (the win32 version does this, but it doesn't hurt
675 -- to test for this in general.)
677 if IO.isDoesNotExistError err
678 then return (ExitFailure 1, True)
680 case (doesn'tExist, exit_code) of
681 (True, _) -> ghcError (InstallationError ("could not execute: " ++ pgm))
682 (_, ExitSuccess) -> return ()
683 _ -> ghcError (PhaseFailed phase_name exit_code)
685 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
686 -> [String] -> Maybe [(String, String)]
688 builderMainLoop dflags filter_fn pgm real_args mb_env = do
690 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
692 -- and run a loop piping the output from the compiler to the log_action in DynFlags
693 hSetBuffering hStdOut LineBuffering
694 hSetBuffering hStdErr LineBuffering
695 forkIO (readerProc chan hStdOut filter_fn)
696 forkIO (readerProc chan hStdErr filter_fn)
697 -- we don't want to finish until 2 streams have been completed
698 -- (stdout and stderr)
699 -- nor until 1 exit code has been retrieved.
700 rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
701 -- after that, we're done here.
707 -- status starts at zero, and increments each time either
708 -- a reader process gets EOF, or the build proc exits. We wait
709 -- for all of these to happen (status==3).
710 -- ToDo: we should really have a contingency plan in case any of
711 -- the threads dies, such as a timeout.
712 loop _ _ 0 0 exitcode = return exitcode
713 loop chan hProcess t p exitcode = do
715 then getProcessExitCode hProcess
718 Just code -> loop chan hProcess t (p-1) code
724 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
725 loop chan hProcess t p exitcode
726 BuildError loc msg -> do
727 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
728 loop chan hProcess t p exitcode
730 loop chan hProcess (t-1) p exitcode
731 | otherwise -> loop chan hProcess t p exitcode
733 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
734 readerProc chan hdl filter_fn =
735 (do str <- hGetContents hdl
736 loop (linesPlatform (filter_fn str)) Nothing)
739 -- ToDo: check errors more carefully
740 -- ToDo: in the future, the filter should be implemented as
741 -- a stream transformer.
743 loop [] Nothing = return ()
744 loop [] (Just err) = writeChan chan err
747 Just err@(BuildError srcLoc msg)
748 | leading_whitespace l -> do
749 loop ls (Just (BuildError srcLoc (msg $$ text l)))
755 _ -> panic "readerProc/loop"
758 = case parseError l of
760 writeChan chan (BuildMsg (text l))
762 Just (file, lineNum, colNum, msg) -> do
763 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
764 loop ls (Just (BuildError srcLoc (text msg)))
766 leading_whitespace [] = False
767 leading_whitespace (x:_) = isSpace x
769 parseError :: String -> Maybe (String, Int, Int, String)
770 parseError s0 = case breakColon s0 of
771 Just (filename, s1) ->
772 case breakIntColon s1 of
773 Just (lineNum, s2) ->
774 case breakIntColon s2 of
775 Just (columnNum, s3) ->
776 Just (filename, lineNum, columnNum, s3)
778 Just (filename, lineNum, 0, s2)
782 breakColon :: String -> Maybe (String, String)
783 breakColon xs = case break (':' ==) xs of
784 (ys, _:zs) -> Just (ys, zs)
787 breakIntColon :: String -> Maybe (Int, String)
788 breakIntColon xs = case break (':' ==) xs of
790 | not (null ys) && all isAscii ys && all isDigit ys ->
796 | BuildError !SrcLoc !SDoc
799 showOpt :: Option -> String
800 showOpt (FileOption pre f) = pre ++ f
801 showOpt (Option s) = s
803 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
804 -- a) trace the command (at two levels of verbosity)
805 -- b) don't do it at all if dry-run is set
806 traceCmd dflags phase_name cmd_line action
807 = do { let verb = verbosity dflags
808 ; showPass dflags phase_name
809 ; debugTraceMsg dflags 3 (text cmd_line)
813 ; unless (dopt Opt_DryRun dflags) $ do {
816 ; action `IO.catch` handle_exn verb
819 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
820 ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
821 ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
824 %************************************************************************
826 \subsection{Support code}
828 %************************************************************************
831 -----------------------------------------------------------------------------
832 -- Define getBaseDir :: IO (Maybe String)
834 getBaseDir :: IO (Maybe String)
835 #if defined(mingw32_HOST_OS)
836 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
837 -- return the path $(stuff). Note that we drop the "bin/" directory too.
838 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
839 buf <- mallocArray len
840 ret <- getModuleFileName nullPtr buf len
841 if ret == 0 then free buf >> return Nothing
842 else do s <- peekCString buf
844 return (Just (rootDir s))
846 rootDir s = case splitFileName $ normalise s of
847 (d, ghc_exe) | map toLower ghc_exe == "ghc.exe" ->
848 case splitFileName $ takeDirectory d of
849 -- installed ghc.exe is in $topdir/bin/ghc.exe
850 (d', "bin") -> takeDirectory d'
851 -- inplace ghc.exe is in $topdir/ghc/stage1-inplace/ghc.exe
852 (d', x) | "-inplace" `isSuffixOf` x ->
853 takeDirectory d' </> ".."
856 where fail = panic ("can't decompose ghc.exe path: " ++ show s)
858 foreign import stdcall unsafe "GetModuleFileNameA"
859 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
861 getBaseDir = return Nothing
864 #ifdef mingw32_HOST_OS
865 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
867 getProcessID :: IO Int
868 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
871 -- Divvy up text stream into lines, taking platform dependent
872 -- line termination into account.
873 linesPlatform :: String -> [String]
874 #if !defined(mingw32_HOST_OS)
875 linesPlatform ls = lines ls
877 linesPlatform "" = []
880 (as,xs1) -> as : linesPlatform xs1
882 lineBreak "" = ("","")
883 lineBreak ('\r':'\n':xs) = ([],xs)
884 lineBreak ('\n':xs) = ([],xs)
885 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)