1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2001-2003
5 -- Access to system tools: gcc, cp, rm etc
7 -----------------------------------------------------------------------------
14 -- Interface to system tools
15 runUnlit, runCpp, runCc, -- [Option] -> IO ()
16 runPp, -- [Option] -> IO ()
17 runMangle, runSplit, -- [Option] -> IO ()
18 runAs, runLink, -- [Option] -> IO ()
21 touch, -- String -> String -> IO ()
24 normalisePath, -- FilePath -> FilePath
26 -- Temporary-file management
29 cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
36 #include "HsVersions.h"
47 import Control.Exception
51 import System.Environment
53 import SYSTEM_IO_ERROR as IO
54 import System.Directory
59 #ifndef mingw32_HOST_OS
60 #if __GLASGOW_HASKELL__ > 504
61 import qualified System.Posix.Internals
63 import qualified Posix
65 #else /* Must be Win32 */
67 import CString ( CString, peekCString )
70 #if __GLASGOW_HASKELL__ < 603
71 -- rawSystem comes from libghccompat.a in stage1
72 import Compat.RawSystem ( rawSystem )
73 import System.Cmd ( system )
74 import GHC.IOBase ( IOErrorType(..) )
76 import System.Process ( runInteractiveProcess, getProcessExitCode )
77 import Control.Concurrent( forkIO, newChan, readChan, writeChan )
78 import FastString ( mkFastString )
79 import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
84 The configuration story
85 ~~~~~~~~~~~~~~~~~~~~~~~
87 GHC needs various support files (library packages, RTS etc), plus
88 various auxiliary programs (cp, gcc, etc). It finds these in one
91 * When running as an *installed program*, GHC finds most of this support
92 stuff in the installed library tree. The path to this tree is passed
93 to GHC via the -B flag, and given to initSysTools .
95 * When running *in-place* in a build tree, GHC finds most of this support
96 stuff in the build tree. The path to the build tree is, again passed
99 GHC tells which of the two is the case by seeing whether package.conf
100 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
103 SysTools.initSysProgs figures out exactly where all the auxiliary programs
104 are, and initialises mutable variables to make it easy to call them.
105 To to this, it makes use of definitions in Config.hs, which is a Haskell
106 file containing variables whose value is figured out by the build system.
108 Config.hs contains two sorts of things
110 cGCC, The *names* of the programs
113 etc They do *not* include paths
116 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
117 cSPLIT_DIR_REL *relative* to the root of the build tree,
118 for use when running *in-place* in a build tree (only)
122 ---------------------------------------------
123 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
125 Another hair-brained scheme for simplifying the current tool location
126 nightmare in GHC: Simon originally suggested using another
127 configuration file along the lines of GCC's specs file - which is fine
128 except that it means adding code to read yet another configuration
129 file. What I didn't notice is that the current package.conf is
130 general enough to do this:
133 {name = "tools", import_dirs = [], source_dirs = [],
134 library_dirs = [], hs_libraries = [], extra_libraries = [],
135 include_dirs = [], c_includes = [], package_deps = [],
136 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
137 extra_cc_opts = [], extra_ld_opts = []}
139 Which would have the advantage that we get to collect together in one
140 place the path-specific package stuff with the path-specific tool
143 ---------------------------------------------
145 %************************************************************************
147 \subsection{Initialisation}
149 %************************************************************************
152 initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
155 -> IO DynFlags -- Set all the mutable variables above, holding
156 -- (a) the system programs
157 -- (b) the package-config file
158 -- (c) the GHC usage message
161 initSysTools mbMinusB dflags
162 = do { (am_installed, top_dir) <- findTopDir mbMinusB
164 -- for "installed" this is the root of GHC's support files
165 -- for "in-place" it is the root of the build tree
166 -- NB: top_dir is assumed to be in standard Unix
167 -- format, '/' separated
169 ; let installed, installed_bin :: FilePath -> FilePath
170 installed_bin pgm = pgmPath top_dir pgm
171 installed file = pgmPath top_dir file
172 inplace dir pgm = pgmPath (top_dir `joinFileName`
173 cPROJECT_DIR `joinFileName` dir) pgm
176 | am_installed = installed "package.conf"
177 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
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
202 ; let dflags0 = defaultDynFlags
203 #ifndef mingw32_HOST_OS
204 -- check whether TMPDIR is set in the environment
205 ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
207 -- On Win32, consult GetTempPath() for a temp dir.
208 -- => it first tries TMP, TEMP, then finally the
209 -- Windows directory(!). The directory is in short-path
213 let len = (2048::Int)
214 buf <- mallocArray len
215 ret <- getTempPath len buf
217 -- failed, consult TMPDIR.
225 ; let dflags1 = case e_tmpdir of
227 Right d -> setTmpDir d dflags0
229 -- Check that the package config exists
230 ; config_exists <- doesFileExist pkgconfig_path
231 ; when (not config_exists) $
232 throwDyn (InstallationError
233 ("Can't find package.conf as " ++ pkgconfig_path))
235 #if defined(mingw32_HOST_OS)
236 -- WINDOWS-SPECIFIC STUFF
237 -- On Windows, gcc and friends are distributed with GHC,
238 -- so when "installed" we look in TopDir/bin
239 -- When "in-place" we look wherever the build-time configure
241 -- When "install" we tell gcc where its specs file + exes are (-B)
242 -- and also some places to pick up include files. We need
243 -- to be careful to put all necessary exes in the -B place
244 -- (as, ld, cc1, etc) since if they don't get found there, gcc
245 -- then tries to run unadorned "as", "ld", etc, and will
246 -- pick up whatever happens to be lying around in the path,
247 -- possibly including those from a cygwin install on the target,
248 -- which is exactly what we're trying to avoid.
249 ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
251 | am_installed = (installed_bin "gcc", [gcc_b_arg])
252 | otherwise = (cGCC, [])
253 -- The trailing "/" is absolutely essential; gcc seems
254 -- to construct file names simply by concatenating to
255 -- this -B path with no extra slash We use "/" rather
256 -- than "\\" because otherwise "\\\" is mangled
257 -- later on; although gcc_args are in NATIVE format,
259 -- (see comments with declarations of global variables)
261 -- The quotes round the -B argument are in case TopDir
264 perl_path | am_installed = installed_bin cGHC_PERL
265 | otherwise = cGHC_PERL
267 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
268 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
269 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
271 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
272 -- a call to Perl to get the invocation of split and mangle
273 ; let (split_prog, split_args) = (perl_path, [Option split_script])
274 (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
276 ; let (mkdll_prog, mkdll_args)
278 (pgmPath (installed "gcc-lib/") cMKDLL,
279 [ Option "--dlltool-name",
280 Option (pgmPath (installed "gcc-lib/") "dlltool"),
281 Option "--driver-name",
282 Option gcc_prog, gcc_b_arg ])
283 | otherwise = (cMKDLL, [])
285 -- UNIX-SPECIFIC STUFF
286 -- On Unix, the "standard" tools are assumed to be
287 -- in the same place whether we are running "in-place" or "installed"
288 -- That place is wherever the build-time configure script found them.
289 ; let gcc_prog = cGCC
292 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
295 -- On Unix, scripts are invoked using the '#!' method. Binary
296 -- installations of GHC on Unix place the correct line on the front
297 -- of the script at installation time, so we don't want to wire-in
298 -- our knowledge of $(PERL) on the host system here.
299 ; let (split_prog, split_args) = (split_script, [])
300 (mangle_prog, mangle_args) = (mangle_script, [])
303 -- cpp is derived from gcc on all platforms
304 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
305 -- Config.hs one day.
306 ; let cpp_path = (gcc_prog, gcc_args ++
307 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
309 -- For all systems, copy and remove are provided by the host
310 -- system; architecture-specific stuff is done when building Config.hs
311 ; let cp_path = cGHC_CP
313 -- Other things being equal, as and ld are simply gcc
314 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
315 (ld_prog,ld_args) = (gcc_prog,gcc_args)
318 ghcUsagePath = ghc_usage_msg_path,
319 ghciUsagePath = ghci_usage_msg_path,
321 systemPackageConfig = pkgconfig_path,
325 pgm_c = (gcc_prog,gcc_args),
326 pgm_m = (mangle_prog,mangle_args),
327 pgm_s = (split_prog,split_args),
328 pgm_a = (as_prog,as_args),
329 pgm_l = (ld_prog,ld_args),
330 pgm_dll = (mkdll_prog,mkdll_args),
332 pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan"
333 -- Hans: this isn't right in general, but you can
334 -- elaborate it in the same way as the others
338 #if defined(mingw32_HOST_OS)
339 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
345 -- for "installed" this is the root of GHC's support files
346 -- for "in-place" it is the root of the build tree
349 -- 1. Set proto_top_dir
350 -- if there is no given TopDir path, get the directory
351 -- where GHC is running (only on Windows)
353 -- 2. If package.conf exists in proto_top_dir, we are running
354 -- installed; and TopDir = proto_top_dir
356 -- 3. Otherwise we are running in-place, so
357 -- proto_top_dir will be /...stuff.../ghc/compiler
358 -- Set TopDir to /...stuff..., which is the root of the build tree
360 -- This is very gruesome indeed
362 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
363 -> IO (Bool, -- True <=> am installed, False <=> in-place
364 String) -- TopDir (in Unix format '/' separated)
367 = do { top_dir <- get_proto
368 -- Discover whether we're running in a build tree or in an installation,
369 -- by looking for the package configuration file.
370 ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf")
372 ; return (am_installed, top_dir)
375 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
376 get_proto = case mbMinusB of
377 Just minusb -> return (normalisePath minusb)
379 -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
380 case maybe_exec_dir of -- (only works on Windows;
381 -- returns Nothing on Unix)
382 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
383 Just dir -> return dir
387 %************************************************************************
389 \subsection{Running an external program}
391 %************************************************************************
395 runUnlit :: DynFlags -> [Option] -> IO ()
396 runUnlit dflags args = do
398 runSomething dflags "Literate pre-processor" p args
400 runCpp :: DynFlags -> [Option] -> IO ()
401 runCpp dflags args = do
402 let (p,args0) = pgm_P dflags
403 runSomething dflags "C pre-processor" p (args0 ++ args)
405 runPp :: DynFlags -> [Option] -> IO ()
406 runPp dflags args = do
408 runSomething dflags "Haskell pre-processor" p args
410 runCc :: DynFlags -> [Option] -> IO ()
411 runCc dflags args = do
412 let (p,args0) = pgm_c dflags
413 args1 = args0 ++ args
414 mb_env <- getGccEnv args1
415 runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
417 -- discard some harmless warnings from gcc that we can't turn off
418 cc_filter = unlines . doFilter . lines
421 gcc gives warnings in chunks like so:
422 In file included from /foo/bar/baz.h:11,
423 from /foo/bar/baz2.h:22,
425 /foo/flibble:14: global register variable ...
426 /foo/flibble:15: warning: call-clobbered r...
427 We break it up into its chunks, remove any call-clobbered register
428 warnings from each chunk, and then delete any chunks that we have
431 doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
432 -- We can't assume that the output will start with an "In file inc..."
433 -- line, so we start off expecting a list of warnings rather than a
435 chunkWarnings :: [String] -- The location stack to use for the next
437 -> [String] -- The remaining lines to look at
438 -> [([String], [String])]
439 chunkWarnings loc_stack [] = [(loc_stack, [])]
440 chunkWarnings loc_stack xs
441 = case break loc_stack_start xs of
442 (warnings, lss:xs') ->
443 case span loc_start_continuation xs' of
445 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
446 _ -> [(loc_stack, xs)]
448 filterWarnings :: [([String], [String])] -> [([String], [String])]
449 filterWarnings [] = []
450 -- If the warnings are already empty then we are probably doing
451 -- something wrong, so don't delete anything
452 filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
453 filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
454 [] -> filterWarnings zs
455 ys' -> (xs, ys') : filterWarnings zs
457 unChunkWarnings :: [([String], [String])] -> [String]
458 unChunkWarnings [] = []
459 unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
461 loc_stack_start s = "In file included from " `isPrefixOf` s
462 loc_start_continuation s = " from " `isPrefixOf` s
464 | "warning: call-clobbered register used" `isContainedIn` w = False
467 isContainedIn :: String -> String -> Bool
468 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
470 -- If the -B<dir> option is set, add <dir> to PATH. This works around
471 -- a bug in gcc on Windows Vista where it can't find its auxiliary
472 -- binaries (see bug #1110).
473 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
475 #if __GLASGOW_HASKELL__ < 603
480 else do env <- getEnvironment
481 return (Just (map mangle_path env))
483 (b_dirs, _) = partitionWith get_b_opt opts
485 get_b_opt (Option ('-':'B':dir)) = Left dir
486 get_b_opt other = Right other
488 mangle_path ("PATH",paths) = ("PATH", '\"' : head b_dirs ++ "\";" ++ paths)
489 mangle_path other = other
492 runMangle :: DynFlags -> [Option] -> IO ()
493 runMangle dflags args = do
494 let (p,args0) = pgm_m dflags
495 runSomething dflags "Mangler" p (args0++args)
497 runSplit :: DynFlags -> [Option] -> IO ()
498 runSplit dflags args = do
499 let (p,args0) = pgm_s dflags
500 runSomething dflags "Splitter" p (args0++args)
502 runAs :: DynFlags -> [Option] -> IO ()
503 runAs dflags args = do
504 let (p,args0) = pgm_a dflags
505 args1 = args0 ++ args
506 mb_env <- getGccEnv args1
507 runSomethingFiltered dflags id "Assembler" p args1 mb_env
509 runLink :: DynFlags -> [Option] -> IO ()
510 runLink dflags args = do
511 let (p,args0) = pgm_l dflags
512 runSomething dflags "Linker" p (args0++args)
514 runMkDLL :: DynFlags -> [Option] -> IO ()
515 runMkDLL dflags args = do
516 let (p,args0) = pgm_dll dflags
517 args1 = args0 ++ args
518 mb_env <- getGccEnv (args0++args)
519 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
521 touch :: DynFlags -> String -> String -> IO ()
522 touch dflags purpose arg =
523 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
525 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
526 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
528 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
530 copyWithHeader dflags purpose maybe_header from to = do
531 showPass dflags purpose
533 h <- openFile to WriteMode
534 ls <- readFile from -- inefficient, but it'll do for now.
535 -- ToDo: speed up via slurping.
536 maybe (return ()) (hPutStr h) maybe_header
542 %************************************************************************
544 \subsection{Managing temporary files
546 %************************************************************************
549 GLOBAL_VAR(v_FilesToClean, [], [String] )
550 GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
554 cleanTempDirs :: DynFlags -> IO ()
556 = unless (dopt Opt_KeepTmpFiles dflags)
557 $ do ds <- readIORef v_DirsToClean
558 removeTmpDirs dflags (eltsFM ds)
559 writeIORef v_DirsToClean emptyFM
561 cleanTempFiles :: DynFlags -> IO ()
562 cleanTempFiles dflags
563 = unless (dopt Opt_KeepTmpFiles dflags)
564 $ do fs <- readIORef v_FilesToClean
565 removeTmpFiles dflags fs
566 writeIORef v_FilesToClean []
568 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
569 cleanTempFilesExcept dflags dont_delete
570 = unless (dopt Opt_KeepTmpFiles dflags)
571 $ do files <- readIORef v_FilesToClean
572 let (to_keep, to_delete) = partition (`elem` dont_delete) files
573 removeTmpFiles dflags to_delete
574 writeIORef v_FilesToClean to_keep
577 -- find a temporary name that doesn't already exist.
578 newTempName :: DynFlags -> Suffix -> IO FilePath
579 newTempName dflags extn
580 = do d <- getTempDir dflags
582 findTempName (d ++ "/ghc" ++ show x ++ "_") 0
584 findTempName prefix x
585 = do let filename = (prefix ++ show x) `joinFileExt` extn
586 b <- doesFileExist filename
587 if b then findTempName prefix (x+1)
588 else do consIORef v_FilesToClean filename -- clean it up later
591 -- return our temporary directory within tmp_dir, creating one if we
592 -- don't have one yet
593 getTempDir :: DynFlags -> IO FilePath
594 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
595 = do mapping <- readIORef v_DirsToClean
596 case lookupFM mapping tmp_dir of
599 let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
601 = let dirname = prefix ++ show x
602 in do createDirectory dirname
603 let mapping' = addToFM mapping tmp_dir dirname
604 writeIORef v_DirsToClean mapping'
605 debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
608 if isAlreadyExistsError e
614 addFilesToClean :: [FilePath] -> IO ()
615 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
616 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
618 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
619 removeTmpDirs dflags ds
620 = traceCmd dflags "Deleting temp dirs"
621 ("Deleting: " ++ unwords ds)
622 (mapM_ (removeWith dflags removeDirectory) ds)
624 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
625 removeTmpFiles dflags fs
627 traceCmd dflags "Deleting temp files"
628 ("Deleting: " ++ unwords deletees)
629 (mapM_ (removeWith dflags removeFile) deletees)
631 -- Flat out refuse to delete files that are likely to be source input
632 -- files (is there a worse bug than having a compiler delete your source
635 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
638 | null non_deletees = act
640 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
643 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
645 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
646 removeWith dflags remover f = remover f `IO.catch`
648 let msg = if isDoesNotExistError e
649 then ptext SLIT("Warning: deleting non-existent") <+> text f
650 else ptext SLIT("Warning: exception raised when deleting")
653 in debugTraceMsg dflags 2 msg
656 -----------------------------------------------------------------------------
657 -- Running an external program
659 runSomething :: DynFlags
660 -> String -- For -v message
661 -> String -- Command name (possibly a full path)
662 -- assumed already dos-ified
663 -> [Option] -- Arguments
664 -- runSomething will dos-ify them
667 runSomething dflags phase_name pgm args =
668 runSomethingFiltered dflags id phase_name pgm args Nothing
671 :: DynFlags -> (String->String) -> String -> String -> [Option]
672 -> Maybe [(String,String)] -> IO ()
674 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
675 let real_args = filter notNull (map showOpt args)
676 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
677 (exit_code, doesn'tExist) <-
679 rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
681 ExitSuccess{} -> return (rc, False)
683 -- rawSystem returns (ExitFailure 127) if the exec failed for any
684 -- reason (eg. the program doesn't exist). This is the only clue
685 -- we have, but we need to report something to the user because in
686 -- the case of a missing program there will otherwise be no output
688 | n == 127 -> return (rc, True)
689 | otherwise -> return (rc, False))
690 -- Should 'rawSystem' generate an IO exception indicating that
691 -- 'pgm' couldn't be run rather than a funky return code, catch
692 -- this here (the win32 version does this, but it doesn't hurt
693 -- to test for this in general.)
695 if IO.isDoesNotExistError err
696 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
697 -- the 'compat' version of rawSystem under mingw32 always
698 -- maps 'errno' to EINVAL to failure.
699 || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
701 then return (ExitFailure 1, True)
703 case (doesn'tExist, exit_code) of
704 (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
705 (_, ExitSuccess) -> return ()
706 _ -> throwDyn (PhaseFailed phase_name exit_code)
710 #if __GLASGOW_HASKELL__ < 603
711 builderMainLoop dflags filter_fn pgm real_args mb_env = do
712 rawSystem pgm real_args
714 builderMainLoop dflags filter_fn pgm real_args mb_env = do
716 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
718 -- and run a loop piping the output from the compiler to the log_action in DynFlags
719 hSetBuffering hStdOut LineBuffering
720 hSetBuffering hStdErr LineBuffering
721 forkIO (readerProc chan hStdOut filter_fn)
722 forkIO (readerProc chan hStdErr filter_fn)
723 rc <- loop chan hProcess 2 1 ExitSuccess
729 -- status starts at zero, and increments each time either
730 -- a reader process gets EOF, or the build proc exits. We wait
731 -- for all of these to happen (status==3).
732 -- ToDo: we should really have a contingency plan in case any of
733 -- the threads dies, such as a timeout.
734 loop chan hProcess 0 0 exitcode = return exitcode
735 loop chan hProcess t p exitcode = do
737 then getProcessExitCode hProcess
740 Just code -> loop chan hProcess t (p-1) code
746 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
747 loop chan hProcess t p exitcode
748 BuildError loc msg -> do
749 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
750 loop chan hProcess t p exitcode
752 loop chan hProcess (t-1) p exitcode
753 | otherwise -> loop chan hProcess t p exitcode
755 readerProc chan hdl filter_fn =
756 (do str <- hGetContents hdl
757 loop (linesPlatform (filter_fn str)) Nothing)
760 -- ToDo: check errors more carefully
761 -- ToDo: in the future, the filter should be implemented as
762 -- a stream transformer.
764 loop [] Nothing = return ()
765 loop [] (Just err) = writeChan chan err
768 Just err@(BuildError srcLoc msg)
769 | leading_whitespace l -> do
770 loop ls (Just (BuildError srcLoc (msg $$ text l)))
778 = case parseError l of
780 writeChan chan (BuildMsg (text l))
782 Just (file, lineNum, colNum, msg) -> do
783 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
784 loop ls (Just (BuildError srcLoc (text msg)))
786 leading_whitespace [] = False
787 leading_whitespace (x:_) = isSpace x
789 parseError :: String -> Maybe (String, Int, Int, String)
790 parseError s0 = case breakColon s0 of
791 Just (filename, s1) ->
792 case breakIntColon s1 of
793 Just (lineNum, s2) ->
794 case breakIntColon s2 of
795 Just (columnNum, s3) ->
796 Just (filename, lineNum, columnNum, s3)
798 Just (filename, lineNum, 0, s2)
802 breakColon :: String -> Maybe (String, String)
803 breakColon xs = case break (':' ==) xs of
804 (ys, _:zs) -> Just (ys, zs)
807 breakIntColon :: String -> Maybe (Int, String)
808 breakIntColon xs = case break (':' ==) xs of
810 | not (null ys) && all isAscii ys && all isDigit ys ->
816 | BuildError !SrcLoc !SDoc
820 showOpt (FileOption pre f) = pre ++ platformPath f
821 showOpt (Option "") = ""
822 showOpt (Option s) = s
824 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
825 -- a) trace the command (at two levels of verbosity)
826 -- b) don't do it at all if dry-run is set
827 traceCmd dflags phase_name cmd_line action
828 = do { let verb = verbosity dflags
829 ; showPass dflags phase_name
830 ; debugTraceMsg dflags 3 (text cmd_line)
834 ; unless (dopt Opt_DryRun dflags) $ do {
837 ; action `IO.catch` handle_exn verb
840 handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
841 ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
842 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
845 %************************************************************************
847 \subsection{Support code}
849 %************************************************************************
852 -----------------------------------------------------------------------------
853 -- Define getBaseDir :: IO (Maybe String)
855 getBaseDir :: IO (Maybe String)
856 #if defined(mingw32_HOST_OS)
857 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
858 -- return the path $(stuff). Note that we drop the "bin/" directory too.
859 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
860 buf <- mallocArray len
861 ret <- getModuleFileName nullPtr buf len
862 if ret == 0 then free buf >> return Nothing
863 else do s <- peekCString buf
865 return (Just (rootDir s))
867 rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
869 foreign import stdcall unsafe "GetModuleFileNameA"
870 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
872 getBaseDir = return Nothing
875 #ifdef mingw32_HOST_OS
876 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
877 #elif __GLASGOW_HASKELL__ > 504
878 getProcessID :: IO Int
879 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
881 getProcessID :: IO Int
882 getProcessID = Posix.getProcessID
885 -- Divvy up text stream into lines, taking platform dependent
886 -- line termination into account.
887 linesPlatform :: String -> [String]
888 #if !defined(mingw32_HOST_OS)
889 linesPlatform ls = lines ls
891 linesPlatform "" = []
894 (as,xs1) -> as : linesPlatform xs1
896 lineBreak "" = ("","")
897 lineBreak ('\r':'\n':xs) = ([],xs)
898 lineBreak ('\n':xs) = ([],xs)
899 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)