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 import qualified System.Posix.Internals
61 #else /* Must be Win32 */
63 import CString ( CString, peekCString )
66 #if __GLASGOW_HASKELL__ < 603
67 -- rawSystem comes from libghccompat.a in stage1
68 import Compat.RawSystem ( rawSystem )
69 import System.Cmd ( system )
70 import GHC.IOBase ( IOErrorType(..) )
72 import System.Process ( runInteractiveProcess, getProcessExitCode )
73 import Control.Concurrent( forkIO, newChan, readChan, writeChan )
74 import FastString ( mkFastString )
75 import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
80 The configuration story
81 ~~~~~~~~~~~~~~~~~~~~~~~
83 GHC needs various support files (library packages, RTS etc), plus
84 various auxiliary programs (cp, gcc, etc). It finds these in one
87 * When running as an *installed program*, GHC finds most of this support
88 stuff in the installed library tree. The path to this tree is passed
89 to GHC via the -B flag, and given to initSysTools .
91 * When running *in-place* in a build tree, GHC finds most of this support
92 stuff in the build tree. The path to the build tree is, again passed
95 GHC tells which of the two is the case by seeing whether package.conf
96 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
99 SysTools.initSysProgs figures out exactly where all the auxiliary programs
100 are, and initialises mutable variables to make it easy to call them.
101 To to this, it makes use of definitions in Config.hs, which is a Haskell
102 file containing variables whose value is figured out by the build system.
104 Config.hs contains two sorts of things
106 cGCC, The *names* of the programs
109 etc They do *not* include paths
112 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
113 cSPLIT_DIR_REL *relative* to the root of the build tree,
114 for use when running *in-place* in a build tree (only)
118 ---------------------------------------------
119 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
121 Another hair-brained scheme for simplifying the current tool location
122 nightmare in GHC: Simon originally suggested using another
123 configuration file along the lines of GCC's specs file - which is fine
124 except that it means adding code to read yet another configuration
125 file. What I didn't notice is that the current package.conf is
126 general enough to do this:
129 {name = "tools", import_dirs = [], source_dirs = [],
130 library_dirs = [], hs_libraries = [], extra_libraries = [],
131 include_dirs = [], c_includes = [], package_deps = [],
132 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
133 extra_cc_opts = [], extra_ld_opts = []}
135 Which would have the advantage that we get to collect together in one
136 place the path-specific package stuff with the path-specific tool
139 ---------------------------------------------
141 %************************************************************************
143 \subsection{Initialisation}
145 %************************************************************************
148 initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
151 -> IO DynFlags -- Set all the mutable variables above, holding
152 -- (a) the system programs
153 -- (b) the package-config file
154 -- (c) the GHC usage message
157 initSysTools mbMinusB dflags
158 = do { (am_installed, top_dir) <- findTopDir mbMinusB
160 -- for "installed" this is the root of GHC's support files
161 -- for "in-place" it is the root of the build tree
162 -- NB: top_dir is assumed to be in standard Unix
163 -- format, '/' separated
165 ; let installed, installed_bin :: FilePath -> FilePath
166 installed_bin pgm = pgmPath top_dir pgm
167 installed file = pgmPath top_dir file
168 inplace dir pgm = pgmPath (top_dir `joinFileName`
169 cPROJECT_DIR `joinFileName` dir) pgm
172 | am_installed = installed "package.conf"
173 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
176 | am_installed = installed "ghc-usage.txt"
177 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
180 | am_installed = installed "ghci-usage.txt"
181 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
183 -- For all systems, unlit, split, mangle are GHC utilities
184 -- architecture-specific stuff is done when building Config.hs
186 | am_installed = installed_bin cGHC_UNLIT_PGM
187 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
189 -- split and mangle are Perl scripts
191 | am_installed = installed_bin cGHC_SPLIT_PGM
192 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
195 | am_installed = installed_bin cGHC_MANGLER_PGM
196 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
198 ; let dflags0 = defaultDynFlags
199 #ifndef mingw32_HOST_OS
200 -- check whether TMPDIR is set in the environment
201 ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
203 -- On Win32, consult GetTempPath() for a temp dir.
204 -- => it first tries TMP, TEMP, then finally the
205 -- Windows directory(!). The directory is in short-path
209 let len = (2048::Int)
210 buf <- mallocArray len
211 ret <- getTempPath len buf
213 -- failed, consult TMPDIR.
221 ; let dflags1 = case e_tmpdir of
223 Right d -> setTmpDir d dflags0
225 -- Check that the package config exists
226 ; config_exists <- doesFileExist pkgconfig_path
227 ; when (not config_exists) $
228 throwDyn (InstallationError
229 ("Can't find package.conf as " ++ pkgconfig_path))
231 #if defined(mingw32_HOST_OS)
232 -- WINDOWS-SPECIFIC STUFF
233 -- On Windows, gcc and friends are distributed with GHC,
234 -- so when "installed" we look in TopDir/bin
235 -- When "in-place" we look wherever the build-time configure
237 -- When "install" we tell gcc where its specs file + exes are (-B)
238 -- and also some places to pick up include files. We need
239 -- to be careful to put all necessary exes in the -B place
240 -- (as, ld, cc1, etc) since if they don't get found there, gcc
241 -- then tries to run unadorned "as", "ld", etc, and will
242 -- pick up whatever happens to be lying around in the path,
243 -- possibly including those from a cygwin install on the target,
244 -- which is exactly what we're trying to avoid.
245 ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
247 | am_installed = (installed_bin "gcc", [gcc_b_arg])
248 | otherwise = (cGCC, [])
249 -- The trailing "/" is absolutely essential; gcc seems
250 -- to construct file names simply by concatenating to
251 -- this -B path with no extra slash We use "/" rather
252 -- than "\\" because otherwise "\\\" is mangled
253 -- later on; although gcc_args are in NATIVE format,
255 -- (see comments with declarations of global variables)
257 -- The quotes round the -B argument are in case TopDir
260 perl_path | am_installed = installed_bin cGHC_PERL
261 | otherwise = cGHC_PERL
263 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
264 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
265 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
267 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
268 -- a call to Perl to get the invocation of split and mangle
269 ; let (split_prog, split_args) = (perl_path, [Option split_script])
270 (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
272 ; let (mkdll_prog, mkdll_args)
274 (pgmPath (installed "gcc-lib/") cMKDLL,
275 [ Option "--dlltool-name",
276 Option (pgmPath (installed "gcc-lib/") "dlltool"),
277 Option "--driver-name",
278 Option gcc_prog, gcc_b_arg ])
279 | otherwise = (cMKDLL, [])
281 -- UNIX-SPECIFIC STUFF
282 -- On Unix, the "standard" tools are assumed to be
283 -- in the same place whether we are running "in-place" or "installed"
284 -- That place is wherever the build-time configure script found them.
285 ; let gcc_prog = cGCC
288 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
291 -- On Unix, scripts are invoked using the '#!' method. Binary
292 -- installations of GHC on Unix place the correct line on the front
293 -- of the script at installation time, so we don't want to wire-in
294 -- our knowledge of $(PERL) on the host system here.
295 ; let (split_prog, split_args) = (split_script, [])
296 (mangle_prog, mangle_args) = (mangle_script, [])
299 -- cpp is derived from gcc on all platforms
300 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
301 -- Config.hs one day.
302 ; let cpp_path = (gcc_prog, gcc_args ++
303 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
305 -- For all systems, copy and remove are provided by the host
306 -- system; architecture-specific stuff is done when building Config.hs
307 ; let cp_path = cGHC_CP
309 -- Other things being equal, as and ld are simply gcc
310 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
311 (ld_prog,ld_args) = (gcc_prog,gcc_args)
314 ghcUsagePath = ghc_usage_msg_path,
315 ghciUsagePath = ghci_usage_msg_path,
317 systemPackageConfig = pkgconfig_path,
321 pgm_c = (gcc_prog,gcc_args),
322 pgm_m = (mangle_prog,mangle_args),
323 pgm_s = (split_prog,split_args),
324 pgm_a = (as_prog,as_args),
325 pgm_l = (ld_prog,ld_args),
326 pgm_dll = (mkdll_prog,mkdll_args),
328 pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan"
329 -- Hans: this isn't right in general, but you can
330 -- elaborate it in the same way as the others
334 #if defined(mingw32_HOST_OS)
335 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
341 -- for "installed" this is the root of GHC's support files
342 -- for "in-place" it is the root of the build tree
345 -- 1. Set proto_top_dir
346 -- if there is no given TopDir path, get the directory
347 -- where GHC is running (only on Windows)
349 -- 2. If package.conf exists in proto_top_dir, we are running
350 -- installed; and TopDir = proto_top_dir
352 -- 3. Otherwise we are running in-place, so
353 -- proto_top_dir will be /...stuff.../ghc/compiler
354 -- Set TopDir to /...stuff..., which is the root of the build tree
356 -- This is very gruesome indeed
358 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
359 -> IO (Bool, -- True <=> am installed, False <=> in-place
360 String) -- TopDir (in Unix format '/' separated)
363 = do { top_dir <- get_proto
364 -- Discover whether we're running in a build tree or in an installation,
365 -- by looking for the package configuration file.
366 ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf")
368 ; return (am_installed, top_dir)
371 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
372 get_proto = case mbMinusB of
373 Just minusb -> return (normalisePath minusb)
375 -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
376 case maybe_exec_dir of -- (only works on Windows;
377 -- returns Nothing on Unix)
378 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
379 Just dir -> return dir
383 %************************************************************************
385 \subsection{Running an external program}
387 %************************************************************************
391 runUnlit :: DynFlags -> [Option] -> IO ()
392 runUnlit dflags args = do
394 runSomething dflags "Literate pre-processor" p args
396 runCpp :: DynFlags -> [Option] -> IO ()
397 runCpp dflags args = do
398 let (p,args0) = pgm_P dflags
399 runSomething dflags "C pre-processor" p (args0 ++ args)
401 runPp :: DynFlags -> [Option] -> IO ()
402 runPp dflags args = do
404 runSomething dflags "Haskell pre-processor" p args
406 runCc :: DynFlags -> [Option] -> IO ()
407 runCc dflags args = do
408 let (p,args0) = pgm_c dflags
409 args1 = args0 ++ args
410 mb_env <- getGccEnv args1
411 runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
413 -- discard some harmless warnings from gcc that we can't turn off
414 cc_filter = unlines . doFilter . lines
417 gcc gives warnings in chunks like so:
418 In file included from /foo/bar/baz.h:11,
419 from /foo/bar/baz2.h:22,
421 /foo/flibble:14: global register variable ...
422 /foo/flibble:15: warning: call-clobbered r...
423 We break it up into its chunks, remove any call-clobbered register
424 warnings from each chunk, and then delete any chunks that we have
427 doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
428 -- We can't assume that the output will start with an "In file inc..."
429 -- line, so we start off expecting a list of warnings rather than a
431 chunkWarnings :: [String] -- The location stack to use for the next
433 -> [String] -- The remaining lines to look at
434 -> [([String], [String])]
435 chunkWarnings loc_stack [] = [(loc_stack, [])]
436 chunkWarnings loc_stack xs
437 = case break loc_stack_start xs of
438 (warnings, lss:xs') ->
439 case span loc_start_continuation xs' of
441 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
442 _ -> [(loc_stack, xs)]
444 filterWarnings :: [([String], [String])] -> [([String], [String])]
445 filterWarnings [] = []
446 -- If the warnings are already empty then we are probably doing
447 -- something wrong, so don't delete anything
448 filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
449 filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
450 [] -> filterWarnings zs
451 ys' -> (xs, ys') : filterWarnings zs
453 unChunkWarnings :: [([String], [String])] -> [String]
454 unChunkWarnings [] = []
455 unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
457 loc_stack_start s = "In file included from " `isPrefixOf` s
458 loc_start_continuation s = " from " `isPrefixOf` s
460 | "warning: call-clobbered register used" `isContainedIn` w = False
463 isContainedIn :: String -> String -> Bool
464 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
466 -- If the -B<dir> option is set, add <dir> to PATH. This works around
467 -- a bug in gcc on Windows Vista where it can't find its auxiliary
468 -- binaries (see bug #1110).
469 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
471 #if __GLASGOW_HASKELL__ < 603
476 else do env <- getEnvironment
477 return (Just (map mangle_path env))
479 (b_dirs, _) = partitionWith get_b_opt opts
481 get_b_opt (Option ('-':'B':dir)) = Left dir
482 get_b_opt other = Right other
484 mangle_path (path,paths) | map toUpper path == "PATH"
485 = (path, '\"' : head b_dirs ++ "\";" ++ paths)
486 mangle_path other = other
489 runMangle :: DynFlags -> [Option] -> IO ()
490 runMangle dflags args = do
491 let (p,args0) = pgm_m dflags
492 runSomething dflags "Mangler" p (args0++args)
494 runSplit :: DynFlags -> [Option] -> IO ()
495 runSplit dflags args = do
496 let (p,args0) = pgm_s dflags
497 runSomething dflags "Splitter" p (args0++args)
499 runAs :: DynFlags -> [Option] -> IO ()
500 runAs dflags args = do
501 let (p,args0) = pgm_a dflags
502 args1 = args0 ++ args
503 mb_env <- getGccEnv args1
504 runSomethingFiltered dflags id "Assembler" p args1 mb_env
506 runLink :: DynFlags -> [Option] -> IO ()
507 runLink dflags args = do
508 let (p,args0) = pgm_l dflags
509 args1 = args0 ++ args
510 mb_env <- getGccEnv args1
511 runSomethingFiltered dflags id "Linker" p args1 mb_env
513 runMkDLL :: DynFlags -> [Option] -> IO ()
514 runMkDLL dflags args = do
515 let (p,args0) = pgm_dll dflags
516 args1 = args0 ++ args
517 mb_env <- getGccEnv (args0++args)
518 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
520 touch :: DynFlags -> String -> String -> IO ()
521 touch dflags purpose arg =
522 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
524 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
525 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
527 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
529 copyWithHeader dflags purpose maybe_header from to = do
530 showPass dflags purpose
532 h <- openFile to WriteMode
533 ls <- readFile from -- inefficient, but it'll do for now.
534 -- ToDo: speed up via slurping.
535 maybe (return ()) (hPutStr h) maybe_header
541 %************************************************************************
543 \subsection{Managing temporary files
545 %************************************************************************
548 GLOBAL_VAR(v_FilesToClean, [], [String] )
549 GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
553 cleanTempDirs :: DynFlags -> IO ()
555 = unless (dopt Opt_KeepTmpFiles dflags)
556 $ do ds <- readIORef v_DirsToClean
557 removeTmpDirs dflags (eltsFM ds)
558 writeIORef v_DirsToClean emptyFM
560 cleanTempFiles :: DynFlags -> IO ()
561 cleanTempFiles dflags
562 = unless (dopt Opt_KeepTmpFiles dflags)
563 $ do fs <- readIORef v_FilesToClean
564 removeTmpFiles dflags fs
565 writeIORef v_FilesToClean []
567 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
568 cleanTempFilesExcept dflags dont_delete
569 = unless (dopt Opt_KeepTmpFiles dflags)
570 $ do files <- readIORef v_FilesToClean
571 let (to_keep, to_delete) = partition (`elem` dont_delete) files
572 removeTmpFiles dflags to_delete
573 writeIORef v_FilesToClean to_keep
576 -- find a temporary name that doesn't already exist.
577 newTempName :: DynFlags -> Suffix -> IO FilePath
578 newTempName dflags extn
579 = do d <- getTempDir dflags
581 findTempName (d ++ "/ghc" ++ show x ++ "_") 0
583 findTempName prefix x
584 = do let filename = (prefix ++ show x) `joinFileExt` extn
585 b <- doesFileExist filename
586 if b then findTempName prefix (x+1)
587 else do consIORef v_FilesToClean filename -- clean it up later
590 -- return our temporary directory within tmp_dir, creating one if we
591 -- don't have one yet
592 getTempDir :: DynFlags -> IO FilePath
593 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
594 = do mapping <- readIORef v_DirsToClean
595 case lookupFM mapping tmp_dir of
598 let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
600 = let dirname = prefix ++ show x
601 in do createDirectory dirname
602 let mapping' = addToFM mapping tmp_dir dirname
603 writeIORef v_DirsToClean mapping'
604 debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
607 if isAlreadyExistsError e
613 addFilesToClean :: [FilePath] -> IO ()
614 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
615 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
617 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
618 removeTmpDirs dflags ds
619 = traceCmd dflags "Deleting temp dirs"
620 ("Deleting: " ++ unwords ds)
621 (mapM_ (removeWith dflags removeDirectory) ds)
623 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
624 removeTmpFiles dflags fs
626 traceCmd dflags "Deleting temp files"
627 ("Deleting: " ++ unwords deletees)
628 (mapM_ (removeWith dflags removeFile) deletees)
630 -- Flat out refuse to delete files that are likely to be source input
631 -- files (is there a worse bug than having a compiler delete your source
634 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
637 | null non_deletees = act
639 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
642 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
644 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
645 removeWith dflags remover f = remover f `IO.catch`
647 let msg = if isDoesNotExistError e
648 then ptext SLIT("Warning: deleting non-existent") <+> text f
649 else ptext SLIT("Warning: exception raised when deleting")
652 in debugTraceMsg dflags 2 msg
655 -----------------------------------------------------------------------------
656 -- Running an external program
658 runSomething :: DynFlags
659 -> String -- For -v message
660 -> String -- Command name (possibly a full path)
661 -- assumed already dos-ified
662 -> [Option] -- Arguments
663 -- runSomething will dos-ify them
666 runSomething dflags phase_name pgm args =
667 runSomethingFiltered dflags id phase_name pgm args Nothing
670 :: DynFlags -> (String->String) -> String -> String -> [Option]
671 -> Maybe [(String,String)] -> IO ()
673 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
674 let real_args = filter notNull (map showOpt args)
675 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
676 (exit_code, doesn'tExist) <-
678 rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
680 ExitSuccess{} -> return (rc, False)
682 -- rawSystem returns (ExitFailure 127) if the exec failed for any
683 -- reason (eg. the program doesn't exist). This is the only clue
684 -- we have, but we need to report something to the user because in
685 -- the case of a missing program there will otherwise be no output
687 | n == 127 -> return (rc, True)
688 | otherwise -> return (rc, False))
689 -- Should 'rawSystem' generate an IO exception indicating that
690 -- 'pgm' couldn't be run rather than a funky return code, catch
691 -- this here (the win32 version does this, but it doesn't hurt
692 -- to test for this in general.)
694 if IO.isDoesNotExistError err
695 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
696 -- the 'compat' version of rawSystem under mingw32 always
697 -- maps 'errno' to EINVAL to failure.
698 || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
700 then return (ExitFailure 1, True)
702 case (doesn'tExist, exit_code) of
703 (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
704 (_, ExitSuccess) -> return ()
705 _ -> throwDyn (PhaseFailed phase_name exit_code)
709 #if __GLASGOW_HASKELL__ < 603
710 builderMainLoop dflags filter_fn pgm real_args mb_env = do
711 rawSystem pgm real_args
713 builderMainLoop dflags filter_fn pgm real_args mb_env = do
715 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
717 -- and run a loop piping the output from the compiler to the log_action in DynFlags
718 hSetBuffering hStdOut LineBuffering
719 hSetBuffering hStdErr LineBuffering
720 forkIO (readerProc chan hStdOut filter_fn)
721 forkIO (readerProc chan hStdErr filter_fn)
722 rc <- loop chan hProcess 2 1 ExitSuccess
728 -- status starts at zero, and increments each time either
729 -- a reader process gets EOF, or the build proc exits. We wait
730 -- for all of these to happen (status==3).
731 -- ToDo: we should really have a contingency plan in case any of
732 -- the threads dies, such as a timeout.
733 loop chan hProcess 0 0 exitcode = return exitcode
734 loop chan hProcess t p exitcode = do
736 then getProcessExitCode hProcess
739 Just code -> loop chan hProcess t (p-1) code
745 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
746 loop chan hProcess t p exitcode
747 BuildError loc msg -> do
748 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
749 loop chan hProcess t p exitcode
751 loop chan hProcess (t-1) p exitcode
752 | otherwise -> loop chan hProcess t p exitcode
754 readerProc chan hdl filter_fn =
755 (do str <- hGetContents hdl
756 loop (linesPlatform (filter_fn str)) Nothing)
759 -- ToDo: check errors more carefully
760 -- ToDo: in the future, the filter should be implemented as
761 -- a stream transformer.
763 loop [] Nothing = return ()
764 loop [] (Just err) = writeChan chan err
767 Just err@(BuildError srcLoc msg)
768 | leading_whitespace l -> do
769 loop ls (Just (BuildError srcLoc (msg $$ text l)))
777 = case parseError l of
779 writeChan chan (BuildMsg (text l))
781 Just (file, lineNum, colNum, msg) -> do
782 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
783 loop ls (Just (BuildError srcLoc (text msg)))
785 leading_whitespace [] = False
786 leading_whitespace (x:_) = isSpace x
788 parseError :: String -> Maybe (String, Int, Int, String)
789 parseError s0 = case breakColon s0 of
790 Just (filename, s1) ->
791 case breakIntColon s1 of
792 Just (lineNum, s2) ->
793 case breakIntColon s2 of
794 Just (columnNum, s3) ->
795 Just (filename, lineNum, columnNum, s3)
797 Just (filename, lineNum, 0, s2)
801 breakColon :: String -> Maybe (String, String)
802 breakColon xs = case break (':' ==) xs of
803 (ys, _:zs) -> Just (ys, zs)
806 breakIntColon :: String -> Maybe (Int, String)
807 breakIntColon xs = case break (':' ==) xs of
809 | not (null ys) && all isAscii ys && all isDigit ys ->
815 | BuildError !SrcLoc !SDoc
819 showOpt (FileOption pre f) = pre ++ platformPath f
820 showOpt (Option "") = ""
821 showOpt (Option s) = s
823 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
824 -- a) trace the command (at two levels of verbosity)
825 -- b) don't do it at all if dry-run is set
826 traceCmd dflags phase_name cmd_line action
827 = do { let verb = verbosity dflags
828 ; showPass dflags phase_name
829 ; debugTraceMsg dflags 3 (text cmd_line)
833 ; unless (dopt Opt_DryRun dflags) $ do {
836 ; action `IO.catch` handle_exn verb
839 handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
840 ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
841 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
844 %************************************************************************
846 \subsection{Support code}
848 %************************************************************************
851 -----------------------------------------------------------------------------
852 -- Define getBaseDir :: IO (Maybe String)
854 getBaseDir :: IO (Maybe String)
855 #if defined(mingw32_HOST_OS)
856 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
857 -- return the path $(stuff). Note that we drop the "bin/" directory too.
858 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
859 buf <- mallocArray len
860 ret <- getModuleFileName nullPtr buf len
861 if ret == 0 then free buf >> return Nothing
862 else do s <- peekCString buf
864 return (Just (rootDir s))
866 rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
868 foreign import stdcall unsafe "GetModuleFileNameA"
869 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
871 getBaseDir = return Nothing
874 #ifdef mingw32_HOST_OS
875 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
877 getProcessID :: IO Int
878 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
881 -- Divvy up text stream into lines, taking platform dependent
882 -- line termination into account.
883 linesPlatform :: String -> [String]
884 #if !defined(mingw32_HOST_OS)
885 linesPlatform ls = lines ls
887 linesPlatform "" = []
890 (as,xs1) -> as : linesPlatform xs1
892 lineBreak "" = ("","")
893 lineBreak ('\r':'\n':xs) = ([],xs)
894 lineBreak ('\n':xs) = ([],xs)
895 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)