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/")
229 | isWindowsHost && am_installed
230 -- We tell gcc where its specs file + exes are (-B)
231 -- and also some places to pick up include files. We need
232 -- to be careful to put all necessary exes in the -B place
233 -- (as, ld, cc1, etc) since if they don't get found there,
234 -- gcc then tries to run unadorned "as", "ld", etc, and
235 -- will pick up whatever happens to be lying around in
236 -- the path, possibly including those from a cygwin
237 -- install on the target, which is exactly what we're
239 = (installed_bin "gcc", [gcc_b_arg])
240 | otherwise = (cGCC, [])
242 | isWindowsHost && am_installed = installed_bin cGHC_PERL
243 | otherwise = cGHC_PERL
244 -- 'touch' is a GHC util for Windows
248 then installed_bin cGHC_TOUCHY_PGM
249 else inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
250 | otherwise = "touch"
251 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
252 -- a call to Perl to get the invocation of split and mangle.
253 -- On Unix, scripts are invoked using the '#!' method. Binary
254 -- installations of GHC on Unix place the correct line on the
255 -- front of the script at installation time, so we don't want
256 -- to wire-in our knowledge of $(PERL) on the host system here.
257 (split_prog, split_args)
258 | isWindowsHost = (perl_path, [Option split_script])
259 | otherwise = (split_script, [])
260 (mangle_prog, mangle_args)
261 | isWindowsHost = (perl_path, [Option mangle_script])
262 | otherwise = (mangle_script, [])
263 (mkdll_prog, mkdll_args)
265 = panic "Can't build DLLs on a non-Win32 system"
267 (installed "gcc-lib/" </> cMKDLL,
268 [ Option "--dlltool-name",
269 Option (installed "gcc-lib/" </> "dlltool"),
270 Option "--driver-name",
271 Option gcc_prog, gcc_b_arg ])
272 | otherwise = (cMKDLL, [])
274 -- cpp is derived from gcc on all platforms
275 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
276 -- Config.hs one day.
277 ; let cpp_path = (gcc_prog, gcc_args ++
278 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
280 -- Other things being equal, as and ld are simply gcc
281 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
282 (ld_prog,ld_args) = (gcc_prog,gcc_args)
285 ghcUsagePath = ghc_usage_msg_path,
286 ghciUsagePath = ghci_usage_msg_path,
288 systemPackageConfig = pkgconfig_path,
292 pgm_c = (gcc_prog,gcc_args),
293 pgm_m = (mangle_prog,mangle_args),
294 pgm_s = (split_prog,split_args),
295 pgm_a = (as_prog,as_args),
296 pgm_l = (ld_prog,ld_args),
297 pgm_dll = (mkdll_prog,mkdll_args),
299 pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
300 pgm_windres = windres_path
301 -- Hans: this isn't right in general, but you can
302 -- elaborate it in the same way as the others
308 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
309 -> IO (Bool, -- True <=> am installed, False <=> in-place
310 String) -- TopDir (in Unix format '/' separated)
313 = do { top_dir <- get_proto
314 ; exists1 <- doesFileExist (top_dir </> "package.conf")
315 ; exists2 <- doesFileExist (top_dir </> "inplace")
316 ; let amInplace = not exists1 -- On Windows, package.conf doesn't exist
317 -- when we are inplace
318 || exists2 -- On Linux, the presence of inplace signals
319 -- that we are inplace
321 ; let real_top = if exists2 then top_dir </> ".." else top_dir
323 ; return (not amInplace, real_top)
326 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
327 get_proto = case mbMinusB of
328 Just minusb -> return (normalise minusb)
330 -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
331 case maybe_exec_dir of -- (only works on Windows;
332 -- returns Nothing on Unix)
333 Nothing -> ghcError (InstallationError "missing -B<dir> option")
334 Just dir -> return dir
338 %************************************************************************
340 \subsection{Running an external program}
342 %************************************************************************
346 runUnlit :: DynFlags -> [Option] -> IO ()
347 runUnlit dflags args = do
349 runSomething dflags "Literate pre-processor" p args
351 runCpp :: DynFlags -> [Option] -> IO ()
352 runCpp dflags args = do
353 let (p,args0) = pgm_P dflags
354 args1 = args0 ++ args
355 mb_env <- getGccEnv args1
356 runSomethingFiltered dflags id "C pre-processor" p args1 mb_env
358 runPp :: DynFlags -> [Option] -> IO ()
359 runPp dflags args = do
361 runSomething dflags "Haskell pre-processor" p args
363 runCc :: DynFlags -> [Option] -> IO ()
364 runCc dflags args = do
365 let (p,args0) = pgm_c dflags
366 args1 = args0 ++ args
367 mb_env <- getGccEnv args1
368 runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
370 -- discard some harmless warnings from gcc that we can't turn off
371 cc_filter = unlines . doFilter . lines
374 gcc gives warnings in chunks like so:
375 In file included from /foo/bar/baz.h:11,
376 from /foo/bar/baz2.h:22,
378 /foo/flibble:14: global register variable ...
379 /foo/flibble:15: warning: call-clobbered r...
380 We break it up into its chunks, remove any call-clobbered register
381 warnings from each chunk, and then delete any chunks that we have
384 doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
385 -- We can't assume that the output will start with an "In file inc..."
386 -- line, so we start off expecting a list of warnings rather than a
388 chunkWarnings :: [String] -- The location stack to use for the next
390 -> [String] -- The remaining lines to look at
391 -> [([String], [String])]
392 chunkWarnings loc_stack [] = [(loc_stack, [])]
393 chunkWarnings loc_stack xs
394 = case break loc_stack_start xs of
395 (warnings, lss:xs') ->
396 case span loc_start_continuation xs' of
398 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
399 _ -> [(loc_stack, xs)]
401 filterWarnings :: [([String], [String])] -> [([String], [String])]
402 filterWarnings [] = []
403 -- If the warnings are already empty then we are probably doing
404 -- something wrong, so don't delete anything
405 filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
406 filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
407 [] -> filterWarnings zs
408 ys' -> (xs, ys') : filterWarnings zs
410 unChunkWarnings :: [([String], [String])] -> [String]
411 unChunkWarnings [] = []
412 unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
414 loc_stack_start s = "In file included from " `isPrefixOf` s
415 loc_start_continuation s = " from " `isPrefixOf` s
417 | "warning: call-clobbered register used" `isContainedIn` w = False
420 isContainedIn :: String -> String -> Bool
421 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
423 -- If the -B<dir> option is set, add <dir> to PATH. This works around
424 -- a bug in gcc on Windows Vista where it can't find its auxiliary
425 -- binaries (see bug #1110).
426 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
430 else do env <- getEnvironment
431 return (Just (map mangle_path env))
433 (b_dirs, _) = partitionWith get_b_opt opts
435 get_b_opt (Option ('-':'B':dir)) = Left dir
436 get_b_opt other = Right other
438 mangle_path (path,paths) | map toUpper path == "PATH"
439 = (path, '\"' : head b_dirs ++ "\";" ++ paths)
440 mangle_path other = other
442 runMangle :: DynFlags -> [Option] -> IO ()
443 runMangle dflags args = do
444 let (p,args0) = pgm_m dflags
445 runSomething dflags "Mangler" p (args0++args)
447 runSplit :: DynFlags -> [Option] -> IO ()
448 runSplit dflags args = do
449 let (p,args0) = pgm_s dflags
450 runSomething dflags "Splitter" p (args0++args)
452 runAs :: DynFlags -> [Option] -> IO ()
453 runAs dflags args = do
454 let (p,args0) = pgm_a dflags
455 args1 = args0 ++ args
456 mb_env <- getGccEnv args1
457 runSomethingFiltered dflags id "Assembler" p args1 mb_env
459 runLink :: DynFlags -> [Option] -> IO ()
460 runLink dflags args = do
461 let (p,args0) = pgm_l dflags
462 args1 = args0 ++ args
463 mb_env <- getGccEnv args1
464 runSomethingFiltered dflags id "Linker" p args1 mb_env
466 runMkDLL :: DynFlags -> [Option] -> IO ()
467 runMkDLL dflags args = do
468 let (p,args0) = pgm_dll dflags
469 args1 = args0 ++ args
470 mb_env <- getGccEnv (args0++args)
471 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
473 runWindres :: DynFlags -> [Option] -> IO ()
474 runWindres dflags args = do
475 let (gcc,gcc_args) = pgm_c dflags
476 windres = pgm_windres dflags
477 mb_env <- getGccEnv gcc_args
478 runSomethingFiltered dflags id "Windres" windres
479 -- we must tell windres where to find gcc: it might not be on PATH
480 (Option ("--preprocessor=" ++
481 unwords (map quote (gcc : map showOpt gcc_args ++
482 ["-E", "-xc", "-DRC_INVOKED"])))
483 -- -- use-temp-file is required for windres to interpret the
484 -- quoting in the preprocessor arg above correctly. Without
485 -- this, windres calls the preprocessor with popen, which gets
486 -- the quoting wrong (discovered by experimentation and
487 -- reading the windres sources). See #1828.
488 : Option "--use-temp-file"
490 -- we must use the PATH workaround here too, since windres invokes gcc
493 quote x = '\"' : x ++ "\""
495 touch :: DynFlags -> String -> String -> IO ()
496 touch dflags purpose arg =
497 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
499 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
500 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
502 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
504 copyWithHeader dflags purpose maybe_header from to = do
505 showPass dflags purpose
507 h <- openFile to WriteMode
508 ls <- readFile from -- inefficient, but it'll do for now.
509 -- ToDo: speed up via slurping.
510 maybe (return ()) (hPutStr h) maybe_header
514 getExtraViaCOpts :: DynFlags -> IO [String]
515 getExtraViaCOpts dflags = do
516 f <- readFile (topDir dflags </> "extra-gcc-opts")
520 %************************************************************************
522 \subsection{Managing temporary files
524 %************************************************************************
527 GLOBAL_VAR(v_FilesToClean, [], [String] )
528 GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
532 cleanTempDirs :: DynFlags -> IO ()
534 = unless (dopt Opt_KeepTmpFiles dflags)
535 $ do ds <- readIORef v_DirsToClean
536 removeTmpDirs dflags (eltsFM ds)
537 writeIORef v_DirsToClean emptyFM
539 cleanTempFiles :: DynFlags -> IO ()
540 cleanTempFiles dflags
541 = unless (dopt Opt_KeepTmpFiles dflags)
542 $ do fs <- readIORef v_FilesToClean
543 removeTmpFiles dflags fs
544 writeIORef v_FilesToClean []
546 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
547 cleanTempFilesExcept dflags dont_delete
548 = unless (dopt Opt_KeepTmpFiles dflags)
549 $ do files <- readIORef v_FilesToClean
550 let (to_keep, to_delete) = partition (`elem` dont_delete) files
551 removeTmpFiles dflags to_delete
552 writeIORef v_FilesToClean to_keep
555 -- find a temporary name that doesn't already exist.
556 newTempName :: DynFlags -> Suffix -> IO FilePath
557 newTempName dflags extn
558 = do d <- getTempDir dflags
560 findTempName (d ++ "/ghc" ++ show x ++ "_") 0
562 findTempName :: FilePath -> Integer -> IO FilePath
563 findTempName prefix x
564 = do let filename = (prefix ++ show x) <.> extn
565 b <- doesFileExist filename
566 if b then findTempName prefix (x+1)
567 else do consIORef v_FilesToClean filename -- clean it up later
570 -- return our temporary directory within tmp_dir, creating one if we
571 -- don't have one yet
572 getTempDir :: DynFlags -> IO FilePath
573 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
574 = do mapping <- readIORef v_DirsToClean
575 case lookupFM mapping tmp_dir of
578 let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
580 mkTempDir :: Integer -> IO FilePath
582 = let dirname = prefix ++ show x
583 in do createDirectory dirname
584 let mapping' = addToFM mapping tmp_dir dirname
585 writeIORef v_DirsToClean mapping'
586 debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
589 if isAlreadyExistsError e
595 addFilesToClean :: [FilePath] -> IO ()
596 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
597 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
599 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
600 removeTmpDirs dflags ds
601 = traceCmd dflags "Deleting temp dirs"
602 ("Deleting: " ++ unwords ds)
603 (mapM_ (removeWith dflags removeDirectory) ds)
605 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
606 removeTmpFiles dflags fs
608 traceCmd dflags "Deleting temp files"
609 ("Deleting: " ++ unwords deletees)
610 (mapM_ (removeWith dflags removeFile) deletees)
612 -- Flat out refuse to delete files that are likely to be source input
613 -- files (is there a worse bug than having a compiler delete your source
616 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
619 | null non_deletees = act
621 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
624 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
626 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
627 removeWith dflags remover f = remover f `IO.catch`
629 let msg = if isDoesNotExistError e
630 then ptext (sLit "Warning: deleting non-existent") <+> text f
631 else ptext (sLit "Warning: exception raised when deleting")
634 in debugTraceMsg dflags 2 msg
637 -----------------------------------------------------------------------------
638 -- Running an external program
640 runSomething :: DynFlags
641 -> String -- For -v message
642 -> String -- Command name (possibly a full path)
643 -- assumed already dos-ified
644 -> [Option] -- Arguments
645 -- runSomething will dos-ify them
648 runSomething dflags phase_name pgm args =
649 runSomethingFiltered dflags id phase_name pgm args Nothing
652 :: DynFlags -> (String->String) -> String -> String -> [Option]
653 -> Maybe [(String,String)] -> IO ()
655 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
656 let real_args = filter notNull (map showOpt args)
657 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
658 (exit_code, doesn'tExist) <-
660 rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
662 ExitSuccess{} -> return (rc, False)
664 -- rawSystem returns (ExitFailure 127) if the exec failed for any
665 -- reason (eg. the program doesn't exist). This is the only clue
666 -- we have, but we need to report something to the user because in
667 -- the case of a missing program there will otherwise be no output
669 | n == 127 -> return (rc, True)
670 | otherwise -> return (rc, False))
671 -- Should 'rawSystem' generate an IO exception indicating that
672 -- 'pgm' couldn't be run rather than a funky return code, catch
673 -- this here (the win32 version does this, but it doesn't hurt
674 -- to test for this in general.)
676 if IO.isDoesNotExistError err
677 then return (ExitFailure 1, True)
679 case (doesn'tExist, exit_code) of
680 (True, _) -> ghcError (InstallationError ("could not execute: " ++ pgm))
681 (_, ExitSuccess) -> return ()
682 _ -> ghcError (PhaseFailed phase_name exit_code)
684 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
685 -> [String] -> Maybe [(String, String)]
687 builderMainLoop dflags filter_fn pgm real_args mb_env = do
689 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
691 -- and run a loop piping the output from the compiler to the log_action in DynFlags
692 hSetBuffering hStdOut LineBuffering
693 hSetBuffering hStdErr LineBuffering
694 forkIO (readerProc chan hStdOut filter_fn)
695 forkIO (readerProc chan hStdErr filter_fn)
696 -- we don't want to finish until 2 streams have been completed
697 -- (stdout and stderr)
698 -- nor until 1 exit code has been retrieved.
699 rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
700 -- after that, we're done here.
706 -- status starts at zero, and increments each time either
707 -- a reader process gets EOF, or the build proc exits. We wait
708 -- for all of these to happen (status==3).
709 -- ToDo: we should really have a contingency plan in case any of
710 -- the threads dies, such as a timeout.
711 loop _ _ 0 0 exitcode = return exitcode
712 loop chan hProcess t p exitcode = do
714 then getProcessExitCode hProcess
717 Just code -> loop chan hProcess t (p-1) code
723 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
724 loop chan hProcess t p exitcode
725 BuildError loc msg -> do
726 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
727 loop chan hProcess t p exitcode
729 loop chan hProcess (t-1) p exitcode
730 | otherwise -> loop chan hProcess t p exitcode
732 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
733 readerProc chan hdl filter_fn =
734 (do str <- hGetContents hdl
735 loop (linesPlatform (filter_fn str)) Nothing)
738 -- ToDo: check errors more carefully
739 -- ToDo: in the future, the filter should be implemented as
740 -- a stream transformer.
742 loop [] Nothing = return ()
743 loop [] (Just err) = writeChan chan err
746 Just err@(BuildError srcLoc msg)
747 | leading_whitespace l -> do
748 loop ls (Just (BuildError srcLoc (msg $$ text l)))
754 _ -> panic "readerProc/loop"
757 = case parseError l of
759 writeChan chan (BuildMsg (text l))
761 Just (file, lineNum, colNum, msg) -> do
762 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
763 loop ls (Just (BuildError srcLoc (text msg)))
765 leading_whitespace [] = False
766 leading_whitespace (x:_) = isSpace x
768 parseError :: String -> Maybe (String, Int, Int, String)
769 parseError s0 = case breakColon s0 of
770 Just (filename, s1) ->
771 case breakIntColon s1 of
772 Just (lineNum, s2) ->
773 case breakIntColon s2 of
774 Just (columnNum, s3) ->
775 Just (filename, lineNum, columnNum, s3)
777 Just (filename, lineNum, 0, s2)
781 breakColon :: String -> Maybe (String, String)
782 breakColon xs = case break (':' ==) xs of
783 (ys, _:zs) -> Just (ys, zs)
786 breakIntColon :: String -> Maybe (Int, String)
787 breakIntColon xs = case break (':' ==) xs of
789 | not (null ys) && all isAscii ys && all isDigit ys ->
795 | BuildError !SrcLoc !SDoc
798 showOpt :: Option -> String
799 showOpt (FileOption pre f) = pre ++ f
800 showOpt (Option s) = s
802 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
803 -- a) trace the command (at two levels of verbosity)
804 -- b) don't do it at all if dry-run is set
805 traceCmd dflags phase_name cmd_line action
806 = do { let verb = verbosity dflags
807 ; showPass dflags phase_name
808 ; debugTraceMsg dflags 3 (text cmd_line)
812 ; unless (dopt Opt_DryRun dflags) $ do {
815 ; action `IO.catch` handle_exn verb
818 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
819 ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
820 ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
823 %************************************************************************
825 \subsection{Support code}
827 %************************************************************************
830 -----------------------------------------------------------------------------
831 -- Define getBaseDir :: IO (Maybe String)
833 getBaseDir :: IO (Maybe String)
834 #if defined(mingw32_HOST_OS)
835 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
836 -- return the path $(stuff). Note that we drop the "bin/" directory too.
837 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
838 buf <- mallocArray len
839 ret <- getModuleFileName nullPtr buf len
840 if ret == 0 then free buf >> return Nothing
841 else do s <- peekCString buf
843 return (Just (rootDir s))
845 rootDir s = case splitFileName $ normalise s of
847 case splitFileName $ takeDirectory d of
848 -- installed ghc.exe is in $topdir/bin/ghc.exe
849 (d', "bin") -> takeDirectory d'
850 -- inplace ghc.exe is in $topdir/ghc/stage1-inplace/ghc.exe
851 (d', x) | "-inplace" `isSuffixOf` x ->
852 takeDirectory d' </> ".."
855 where fail = panic ("can't decompose ghc.exe path: " ++ show s)
857 foreign import stdcall unsafe "GetModuleFileNameA"
858 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
860 getBaseDir = return Nothing
863 #ifdef mingw32_HOST_OS
864 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
866 getProcessID :: IO Int
867 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
870 -- Divvy up text stream into lines, taking platform dependent
871 -- line termination into account.
872 linesPlatform :: String -> [String]
873 #if !defined(mingw32_HOST_OS)
874 linesPlatform ls = lines ls
876 linesPlatform "" = []
879 (as,xs1) -> as : linesPlatform xs1
881 lineBreak "" = ("","")
882 lineBreak ('\r':'\n':xs) = ([],xs)
883 lineBreak ('\n':xs) = ([],xs)
884 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)