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) | map toUpper path == "PATH"
489 = (path, '\"' : head b_dirs ++ "\";" ++ paths)
490 mangle_path other = other
493 runMangle :: DynFlags -> [Option] -> IO ()
494 runMangle dflags args = do
495 let (p,args0) = pgm_m dflags
496 runSomething dflags "Mangler" p (args0++args)
498 runSplit :: DynFlags -> [Option] -> IO ()
499 runSplit dflags args = do
500 let (p,args0) = pgm_s dflags
501 runSomething dflags "Splitter" p (args0++args)
503 runAs :: DynFlags -> [Option] -> IO ()
504 runAs dflags args = do
505 let (p,args0) = pgm_a dflags
506 args1 = args0 ++ args
507 mb_env <- getGccEnv args1
508 runSomethingFiltered dflags id "Assembler" p args1 mb_env
510 runLink :: DynFlags -> [Option] -> IO ()
511 runLink dflags args = do
512 let (p,args0) = pgm_l dflags
513 args1 = args0 ++ args
514 mb_env <- getGccEnv args1
515 runSomethingFiltered dflags id "Linker" p args1 mb_env
517 runMkDLL :: DynFlags -> [Option] -> IO ()
518 runMkDLL dflags args = do
519 let (p,args0) = pgm_dll dflags
520 args1 = args0 ++ args
521 mb_env <- getGccEnv (args0++args)
522 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
524 touch :: DynFlags -> String -> String -> IO ()
525 touch dflags purpose arg =
526 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
528 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
529 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
531 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
533 copyWithHeader dflags purpose maybe_header from to = do
534 showPass dflags purpose
536 h <- openFile to WriteMode
537 ls <- readFile from -- inefficient, but it'll do for now.
538 -- ToDo: speed up via slurping.
539 maybe (return ()) (hPutStr h) maybe_header
545 %************************************************************************
547 \subsection{Managing temporary files
549 %************************************************************************
552 GLOBAL_VAR(v_FilesToClean, [], [String] )
553 GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
557 cleanTempDirs :: DynFlags -> IO ()
559 = unless (dopt Opt_KeepTmpFiles dflags)
560 $ do ds <- readIORef v_DirsToClean
561 removeTmpDirs dflags (eltsFM ds)
562 writeIORef v_DirsToClean emptyFM
564 cleanTempFiles :: DynFlags -> IO ()
565 cleanTempFiles dflags
566 = unless (dopt Opt_KeepTmpFiles dflags)
567 $ do fs <- readIORef v_FilesToClean
568 removeTmpFiles dflags fs
569 writeIORef v_FilesToClean []
571 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
572 cleanTempFilesExcept dflags dont_delete
573 = unless (dopt Opt_KeepTmpFiles dflags)
574 $ do files <- readIORef v_FilesToClean
575 let (to_keep, to_delete) = partition (`elem` dont_delete) files
576 removeTmpFiles dflags to_delete
577 writeIORef v_FilesToClean to_keep
580 -- find a temporary name that doesn't already exist.
581 newTempName :: DynFlags -> Suffix -> IO FilePath
582 newTempName dflags extn
583 = do d <- getTempDir dflags
585 findTempName (d ++ "/ghc" ++ show x ++ "_") 0
587 findTempName prefix x
588 = do let filename = (prefix ++ show x) `joinFileExt` extn
589 b <- doesFileExist filename
590 if b then findTempName prefix (x+1)
591 else do consIORef v_FilesToClean filename -- clean it up later
594 -- return our temporary directory within tmp_dir, creating one if we
595 -- don't have one yet
596 getTempDir :: DynFlags -> IO FilePath
597 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
598 = do mapping <- readIORef v_DirsToClean
599 case lookupFM mapping tmp_dir of
602 let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
604 = let dirname = prefix ++ show x
605 in do createDirectory dirname
606 let mapping' = addToFM mapping tmp_dir dirname
607 writeIORef v_DirsToClean mapping'
608 debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
611 if isAlreadyExistsError e
617 addFilesToClean :: [FilePath] -> IO ()
618 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
619 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
621 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
622 removeTmpDirs dflags ds
623 = traceCmd dflags "Deleting temp dirs"
624 ("Deleting: " ++ unwords ds)
625 (mapM_ (removeWith dflags removeDirectory) ds)
627 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
628 removeTmpFiles dflags fs
630 traceCmd dflags "Deleting temp files"
631 ("Deleting: " ++ unwords deletees)
632 (mapM_ (removeWith dflags removeFile) deletees)
634 -- Flat out refuse to delete files that are likely to be source input
635 -- files (is there a worse bug than having a compiler delete your source
638 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
641 | null non_deletees = act
643 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
646 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
648 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
649 removeWith dflags remover f = remover f `IO.catch`
651 let msg = if isDoesNotExistError e
652 then ptext SLIT("Warning: deleting non-existent") <+> text f
653 else ptext SLIT("Warning: exception raised when deleting")
656 in debugTraceMsg dflags 2 msg
659 -----------------------------------------------------------------------------
660 -- Running an external program
662 runSomething :: DynFlags
663 -> String -- For -v message
664 -> String -- Command name (possibly a full path)
665 -- assumed already dos-ified
666 -> [Option] -- Arguments
667 -- runSomething will dos-ify them
670 runSomething dflags phase_name pgm args =
671 runSomethingFiltered dflags id phase_name pgm args Nothing
674 :: DynFlags -> (String->String) -> String -> String -> [Option]
675 -> Maybe [(String,String)] -> IO ()
677 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
678 let real_args = filter notNull (map showOpt args)
679 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
680 (exit_code, doesn'tExist) <-
682 rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
684 ExitSuccess{} -> return (rc, False)
686 -- rawSystem returns (ExitFailure 127) if the exec failed for any
687 -- reason (eg. the program doesn't exist). This is the only clue
688 -- we have, but we need to report something to the user because in
689 -- the case of a missing program there will otherwise be no output
691 | n == 127 -> return (rc, True)
692 | otherwise -> return (rc, False))
693 -- Should 'rawSystem' generate an IO exception indicating that
694 -- 'pgm' couldn't be run rather than a funky return code, catch
695 -- this here (the win32 version does this, but it doesn't hurt
696 -- to test for this in general.)
698 if IO.isDoesNotExistError err
699 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
700 -- the 'compat' version of rawSystem under mingw32 always
701 -- maps 'errno' to EINVAL to failure.
702 || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
704 then return (ExitFailure 1, True)
706 case (doesn'tExist, exit_code) of
707 (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
708 (_, ExitSuccess) -> return ()
709 _ -> throwDyn (PhaseFailed phase_name exit_code)
713 #if __GLASGOW_HASKELL__ < 603
714 builderMainLoop dflags filter_fn pgm real_args mb_env = do
715 rawSystem pgm real_args
717 builderMainLoop dflags filter_fn pgm real_args mb_env = do
719 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
721 -- and run a loop piping the output from the compiler to the log_action in DynFlags
722 hSetBuffering hStdOut LineBuffering
723 hSetBuffering hStdErr LineBuffering
724 forkIO (readerProc chan hStdOut filter_fn)
725 forkIO (readerProc chan hStdErr filter_fn)
726 rc <- loop chan hProcess 2 1 ExitSuccess
732 -- status starts at zero, and increments each time either
733 -- a reader process gets EOF, or the build proc exits. We wait
734 -- for all of these to happen (status==3).
735 -- ToDo: we should really have a contingency plan in case any of
736 -- the threads dies, such as a timeout.
737 loop chan hProcess 0 0 exitcode = return exitcode
738 loop chan hProcess t p exitcode = do
740 then getProcessExitCode hProcess
743 Just code -> loop chan hProcess t (p-1) code
749 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
750 loop chan hProcess t p exitcode
751 BuildError loc msg -> do
752 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
753 loop chan hProcess t p exitcode
755 loop chan hProcess (t-1) p exitcode
756 | otherwise -> loop chan hProcess t p exitcode
758 readerProc chan hdl filter_fn =
759 (do str <- hGetContents hdl
760 loop (linesPlatform (filter_fn str)) Nothing)
763 -- ToDo: check errors more carefully
764 -- ToDo: in the future, the filter should be implemented as
765 -- a stream transformer.
767 loop [] Nothing = return ()
768 loop [] (Just err) = writeChan chan err
771 Just err@(BuildError srcLoc msg)
772 | leading_whitespace l -> do
773 loop ls (Just (BuildError srcLoc (msg $$ text l)))
781 = case parseError l of
783 writeChan chan (BuildMsg (text l))
785 Just (file, lineNum, colNum, msg) -> do
786 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
787 loop ls (Just (BuildError srcLoc (text msg)))
789 leading_whitespace [] = False
790 leading_whitespace (x:_) = isSpace x
792 parseError :: String -> Maybe (String, Int, Int, String)
793 parseError s0 = case breakColon s0 of
794 Just (filename, s1) ->
795 case breakIntColon s1 of
796 Just (lineNum, s2) ->
797 case breakIntColon s2 of
798 Just (columnNum, s3) ->
799 Just (filename, lineNum, columnNum, s3)
801 Just (filename, lineNum, 0, s2)
805 breakColon :: String -> Maybe (String, String)
806 breakColon xs = case break (':' ==) xs of
807 (ys, _:zs) -> Just (ys, zs)
810 breakIntColon :: String -> Maybe (Int, String)
811 breakIntColon xs = case break (':' ==) xs of
813 | not (null ys) && all isAscii ys && all isDigit ys ->
819 | BuildError !SrcLoc !SDoc
823 showOpt (FileOption pre f) = pre ++ platformPath f
824 showOpt (Option "") = ""
825 showOpt (Option s) = s
827 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
828 -- a) trace the command (at two levels of verbosity)
829 -- b) don't do it at all if dry-run is set
830 traceCmd dflags phase_name cmd_line action
831 = do { let verb = verbosity dflags
832 ; showPass dflags phase_name
833 ; debugTraceMsg dflags 3 (text cmd_line)
837 ; unless (dopt Opt_DryRun dflags) $ do {
840 ; action `IO.catch` handle_exn verb
843 handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
844 ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
845 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
848 %************************************************************************
850 \subsection{Support code}
852 %************************************************************************
855 -----------------------------------------------------------------------------
856 -- Define getBaseDir :: IO (Maybe String)
858 getBaseDir :: IO (Maybe String)
859 #if defined(mingw32_HOST_OS)
860 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
861 -- return the path $(stuff). Note that we drop the "bin/" directory too.
862 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
863 buf <- mallocArray len
864 ret <- getModuleFileName nullPtr buf len
865 if ret == 0 then free buf >> return Nothing
866 else do s <- peekCString buf
868 return (Just (rootDir s))
870 rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
872 foreign import stdcall unsafe "GetModuleFileNameA"
873 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
875 getBaseDir = return Nothing
878 #ifdef mingw32_HOST_OS
879 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
880 #elif __GLASGOW_HASKELL__ > 504
881 getProcessID :: IO Int
882 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
884 getProcessID :: IO Int
885 getProcessID = Posix.getProcessID
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)