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 :: FilePath -> Integer -> IO FilePath
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 mkTempDir :: Integer -> IO FilePath
603 = let dirname = prefix ++ show x
604 in do createDirectory dirname
605 let mapping' = addToFM mapping tmp_dir dirname
606 writeIORef v_DirsToClean mapping'
607 debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
610 if isAlreadyExistsError e
616 addFilesToClean :: [FilePath] -> IO ()
617 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
618 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
620 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
621 removeTmpDirs dflags ds
622 = traceCmd dflags "Deleting temp dirs"
623 ("Deleting: " ++ unwords ds)
624 (mapM_ (removeWith dflags removeDirectory) ds)
626 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
627 removeTmpFiles dflags fs
629 traceCmd dflags "Deleting temp files"
630 ("Deleting: " ++ unwords deletees)
631 (mapM_ (removeWith dflags removeFile) deletees)
633 -- Flat out refuse to delete files that are likely to be source input
634 -- files (is there a worse bug than having a compiler delete your source
637 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
640 | null non_deletees = act
642 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
645 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
647 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
648 removeWith dflags remover f = remover f `IO.catch`
650 let msg = if isDoesNotExistError e
651 then ptext SLIT("Warning: deleting non-existent") <+> text f
652 else ptext SLIT("Warning: exception raised when deleting")
655 in debugTraceMsg dflags 2 msg
658 -----------------------------------------------------------------------------
659 -- Running an external program
661 runSomething :: DynFlags
662 -> String -- For -v message
663 -> String -- Command name (possibly a full path)
664 -- assumed already dos-ified
665 -> [Option] -- Arguments
666 -- runSomething will dos-ify them
669 runSomething dflags phase_name pgm args =
670 runSomethingFiltered dflags id phase_name pgm args Nothing
673 :: DynFlags -> (String->String) -> String -> String -> [Option]
674 -> Maybe [(String,String)] -> IO ()
676 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
677 let real_args = filter notNull (map showOpt args)
678 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
679 (exit_code, doesn'tExist) <-
681 rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
683 ExitSuccess{} -> return (rc, False)
685 -- rawSystem returns (ExitFailure 127) if the exec failed for any
686 -- reason (eg. the program doesn't exist). This is the only clue
687 -- we have, but we need to report something to the user because in
688 -- the case of a missing program there will otherwise be no output
690 | n == 127 -> return (rc, True)
691 | otherwise -> return (rc, False))
692 -- Should 'rawSystem' generate an IO exception indicating that
693 -- 'pgm' couldn't be run rather than a funky return code, catch
694 -- this here (the win32 version does this, but it doesn't hurt
695 -- to test for this in general.)
697 if IO.isDoesNotExistError err
698 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
699 -- the 'compat' version of rawSystem under mingw32 always
700 -- maps 'errno' to EINVAL to failure.
701 || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
703 then return (ExitFailure 1, True)
705 case (doesn'tExist, exit_code) of
706 (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
707 (_, ExitSuccess) -> return ()
708 _ -> throwDyn (PhaseFailed phase_name exit_code)
712 #if __GLASGOW_HASKELL__ < 603
713 builderMainLoop dflags filter_fn pgm real_args mb_env = do
714 rawSystem pgm real_args
716 builderMainLoop dflags filter_fn pgm real_args mb_env = do
718 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
720 -- and run a loop piping the output from the compiler to the log_action in DynFlags
721 hSetBuffering hStdOut LineBuffering
722 hSetBuffering hStdErr LineBuffering
723 forkIO (readerProc chan hStdOut filter_fn)
724 forkIO (readerProc chan hStdErr filter_fn)
725 -- we don't want to finish until 2 streams have been completed
726 -- (stdout and stderr)
727 -- nor until 1 exit code has been retrieved.
728 rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
729 -- after that, we're done here.
735 -- status starts at zero, and increments each time either
736 -- a reader process gets EOF, or the build proc exits. We wait
737 -- for all of these to happen (status==3).
738 -- ToDo: we should really have a contingency plan in case any of
739 -- the threads dies, such as a timeout.
740 loop chan hProcess 0 0 exitcode = return exitcode
741 loop chan hProcess t p exitcode = do
743 then getProcessExitCode hProcess
746 Just code -> loop chan hProcess t (p-1) code
752 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
753 loop chan hProcess t p exitcode
754 BuildError loc msg -> do
755 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
756 loop chan hProcess t p exitcode
758 loop chan hProcess (t-1) p exitcode
759 | otherwise -> loop chan hProcess t p exitcode
761 readerProc chan hdl filter_fn =
762 (do str <- hGetContents hdl
763 loop (linesPlatform (filter_fn str)) Nothing)
766 -- ToDo: check errors more carefully
767 -- ToDo: in the future, the filter should be implemented as
768 -- a stream transformer.
770 loop [] Nothing = return ()
771 loop [] (Just err) = writeChan chan err
774 Just err@(BuildError srcLoc msg)
775 | leading_whitespace l -> do
776 loop ls (Just (BuildError srcLoc (msg $$ text l)))
784 = case parseError l of
786 writeChan chan (BuildMsg (text l))
788 Just (file, lineNum, colNum, msg) -> do
789 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
790 loop ls (Just (BuildError srcLoc (text msg)))
792 leading_whitespace [] = False
793 leading_whitespace (x:_) = isSpace x
795 parseError :: String -> Maybe (String, Int, Int, String)
796 parseError s0 = case breakColon s0 of
797 Just (filename, s1) ->
798 case breakIntColon s1 of
799 Just (lineNum, s2) ->
800 case breakIntColon s2 of
801 Just (columnNum, s3) ->
802 Just (filename, lineNum, columnNum, s3)
804 Just (filename, lineNum, 0, s2)
808 breakColon :: String -> Maybe (String, String)
809 breakColon xs = case break (':' ==) xs of
810 (ys, _:zs) -> Just (ys, zs)
813 breakIntColon :: String -> Maybe (Int, String)
814 breakIntColon xs = case break (':' ==) xs of
816 | not (null ys) && all isAscii ys && all isDigit ys ->
822 | BuildError !SrcLoc !SDoc
826 showOpt (FileOption pre f) = pre ++ platformPath f
827 showOpt (Option "") = ""
828 showOpt (Option s) = s
830 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
831 -- a) trace the command (at two levels of verbosity)
832 -- b) don't do it at all if dry-run is set
833 traceCmd dflags phase_name cmd_line action
834 = do { let verb = verbosity dflags
835 ; showPass dflags phase_name
836 ; debugTraceMsg dflags 3 (text cmd_line)
840 ; unless (dopt Opt_DryRun dflags) $ do {
843 ; action `IO.catch` handle_exn verb
846 handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
847 ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
848 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
851 %************************************************************************
853 \subsection{Support code}
855 %************************************************************************
858 -----------------------------------------------------------------------------
859 -- Define getBaseDir :: IO (Maybe String)
861 getBaseDir :: IO (Maybe String)
862 #if defined(mingw32_HOST_OS)
863 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
864 -- return the path $(stuff). Note that we drop the "bin/" directory too.
865 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
866 buf <- mallocArray len
867 ret <- getModuleFileName nullPtr buf len
868 if ret == 0 then free buf >> return Nothing
869 else do s <- peekCString buf
871 return (Just (rootDir s))
873 rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
875 foreign import stdcall unsafe "GetModuleFileNameA"
876 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
878 getBaseDir = return Nothing
881 #ifdef mingw32_HOST_OS
882 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
884 getProcessID :: IO Int
885 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
888 -- Divvy up text stream into lines, taking platform dependent
889 -- line termination into account.
890 linesPlatform :: String -> [String]
891 #if !defined(mingw32_HOST_OS)
892 linesPlatform ls = lines ls
894 linesPlatform "" = []
897 (as,xs1) -> as : linesPlatform xs1
899 lineBreak "" = ("","")
900 lineBreak ('\r':'\n':xs) = ([],xs)
901 lineBreak ('\n':xs) = ([],xs)
902 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)