1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2001-2003
5 -- Access to system tools: gcc, cp, rm etc
7 -----------------------------------------------------------------------------
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and fix
13 -- any warnings in the module. See
14 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
21 -- Interface to system tools
22 runUnlit, runCpp, runCc, -- [Option] -> IO ()
23 runPp, -- [Option] -> IO ()
24 runMangle, runSplit, -- [Option] -> IO ()
25 runAs, runLink, -- [Option] -> IO ()
29 touch, -- String -> String -> IO ()
34 -- Temporary-file management
37 cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
44 #include "HsVersions.h"
55 import Control.Exception
59 import System.Environment
60 import System.FilePath
62 import SYSTEM_IO_ERROR as IO
63 import System.Directory
68 #ifndef mingw32_HOST_OS
69 import qualified System.Posix.Internals
70 #else /* Must be Win32 */
72 import CString ( CString, peekCString )
75 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
76 -- rawSystem comes from libghccompat.a in stage1
77 import Compat.RawSystem ( rawSystem )
78 import System.Cmd ( system )
79 import GHC.IOBase ( IOErrorType(..) )
81 import System.Process ( runInteractiveProcess, getProcessExitCode )
82 import Control.Concurrent( forkIO, newChan, readChan, writeChan )
83 import FastString ( mkFastString )
84 import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
89 The configuration story
90 ~~~~~~~~~~~~~~~~~~~~~~~
92 GHC needs various support files (library packages, RTS etc), plus
93 various auxiliary programs (cp, gcc, etc). It finds these in one
96 * When running as an *installed program*, GHC finds most of this support
97 stuff in the installed library tree. The path to this tree is passed
98 to GHC via the -B flag, and given to initSysTools .
100 * When running *in-place* in a build tree, GHC finds most of this support
101 stuff in the build tree. The path to the build tree is, again passed
104 GHC tells which of the two is the case by seeing whether package.conf
105 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
108 SysTools.initSysProgs figures out exactly where all the auxiliary programs
109 are, and initialises mutable variables to make it easy to call them.
110 To to this, it makes use of definitions in Config.hs, which is a Haskell
111 file containing variables whose value is figured out by the build system.
113 Config.hs contains two sorts of things
115 cGCC, The *names* of the programs
118 etc They do *not* include paths
121 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
122 cSPLIT_DIR_REL *relative* to the root of the build tree,
123 for use when running *in-place* in a build tree (only)
127 ---------------------------------------------
128 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
130 Another hair-brained scheme for simplifying the current tool location
131 nightmare in GHC: Simon originally suggested using another
132 configuration file along the lines of GCC's specs file - which is fine
133 except that it means adding code to read yet another configuration
134 file. What I didn't notice is that the current package.conf is
135 general enough to do this:
138 {name = "tools", import_dirs = [], source_dirs = [],
139 library_dirs = [], hs_libraries = [], extra_libraries = [],
140 include_dirs = [], c_includes = [], package_deps = [],
141 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
142 extra_cc_opts = [], extra_ld_opts = []}
144 Which would have the advantage that we get to collect together in one
145 place the path-specific package stuff with the path-specific tool
148 ---------------------------------------------
150 %************************************************************************
152 \subsection{Initialisation}
154 %************************************************************************
157 initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
160 -> IO DynFlags -- Set all the mutable variables above, holding
161 -- (a) the system programs
162 -- (b) the package-config file
163 -- (c) the GHC usage message
166 initSysTools mbMinusB dflags
167 = do { (am_installed, top_dir) <- findTopDir mbMinusB
169 -- for "installed" this is the root of GHC's support files
170 -- for "in-place" it is the root of the build tree
171 -- NB: top_dir is assumed to be in standard Unix
172 -- format, '/' separated
174 ; let installed, installed_bin :: FilePath -> FilePath
175 installed_bin pgm = top_dir </> pgm
176 installed file = top_dir </> file
177 inplace dir pgm = top_dir </>
178 #ifndef darwin_TARGET_OS
179 -- Not sure where cPROJECT_DIR makes sense, on Mac OS, building with
180 -- xcodebuild, it surely is a *bad* idea! -=chak
186 | am_installed = installed "package.conf"
187 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
190 | am_installed = installed "ghc-usage.txt"
191 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
194 | am_installed = installed "ghci-usage.txt"
195 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
197 -- For all systems, unlit, split, mangle are GHC utilities
198 -- architecture-specific stuff is done when building Config.hs
200 | am_installed = installed_bin cGHC_UNLIT_PGM
201 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
203 -- split and mangle are Perl scripts
205 | am_installed = installed_bin cGHC_SPLIT_PGM
206 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
209 | am_installed = installed_bin cGHC_MANGLER_PGM
210 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
213 | am_installed = installed_bin "bin/windres"
214 | otherwise = "windres"
216 ; let dflags0 = defaultDynFlags
217 #ifndef mingw32_HOST_OS
218 -- check whether TMPDIR is set in the environment
219 ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
221 -- On Win32, consult GetTempPath() for a temp dir.
222 -- => it first tries TMP, TEMP, then finally the
223 -- Windows directory(!). The directory is in short-path
227 let len = (2048::Int)
228 buf <- mallocArray len
229 ret <- getTempPath len buf
231 -- failed, consult TMPDIR.
239 ; let dflags1 = case e_tmpdir of
241 Right d -> setTmpDir d dflags0
243 -- Check that the package config exists
244 ; config_exists <- doesFileExist pkgconfig_path
245 ; when (not config_exists) $
246 throwDyn (InstallationError
247 ("Can't find package.conf as " ++ pkgconfig_path))
249 #if defined(mingw32_HOST_OS)
250 -- WINDOWS-SPECIFIC STUFF
251 -- On Windows, gcc and friends are distributed with GHC,
252 -- so when "installed" we look in TopDir/bin
253 -- When "in-place" we look wherever the build-time configure
255 -- When "install" we tell gcc where its specs file + exes are (-B)
256 -- and also some places to pick up include files. We need
257 -- to be careful to put all necessary exes in the -B place
258 -- (as, ld, cc1, etc) since if they don't get found there, gcc
259 -- then tries to run unadorned "as", "ld", etc, and will
260 -- pick up whatever happens to be lying around in the path,
261 -- possibly including those from a cygwin install on the target,
262 -- which is exactly what we're trying to avoid.
263 ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
265 | am_installed = (installed_bin "gcc", [gcc_b_arg])
266 | otherwise = (cGCC, [])
267 -- The trailing "/" is absolutely essential; gcc seems
268 -- to construct file names simply by concatenating to
269 -- this -B path with no extra slash We use "/" rather
270 -- than "\\" because otherwise "\\\" is mangled
271 -- later on; although gcc_args are in NATIVE format,
273 -- (see comments with declarations of global variables)
275 perl_path | am_installed = installed_bin cGHC_PERL
276 | otherwise = cGHC_PERL
278 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
279 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
280 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
282 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
283 -- a call to Perl to get the invocation of split and mangle
284 ; let (split_prog, split_args) = (perl_path, [Option split_script])
285 (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
287 ; let (mkdll_prog, mkdll_args)
289 (installed "gcc-lib/" </> cMKDLL,
290 [ Option "--dlltool-name",
291 Option (installed "gcc-lib/" </> "dlltool"),
292 Option "--driver-name",
293 Option gcc_prog, gcc_b_arg ])
294 | otherwise = (cMKDLL, [])
296 -- UNIX-SPECIFIC STUFF
297 -- On Unix, the "standard" tools are assumed to be
298 -- in the same place whether we are running "in-place" or "installed"
299 -- That place is wherever the build-time configure script found them.
300 ; let gcc_prog = cGCC
303 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
306 -- On Unix, scripts are invoked using the '#!' method. Binary
307 -- installations of GHC on Unix place the correct line on the front
308 -- of the script at installation time, so we don't want to wire-in
309 -- our knowledge of $(PERL) on the host system here.
310 ; let (split_prog, split_args) = (split_script, [])
311 (mangle_prog, mangle_args) = (mangle_script, [])
314 -- cpp is derived from gcc on all platforms
315 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
316 -- Config.hs one day.
317 ; let cpp_path = (gcc_prog, gcc_args ++
318 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
320 -- For all systems, copy and remove are provided by the host
321 -- system; architecture-specific stuff is done when building Config.hs
322 ; let cp_path = cGHC_CP
324 -- Other things being equal, as and ld are simply gcc
325 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
326 (ld_prog,ld_args) = (gcc_prog,gcc_args)
329 ghcUsagePath = ghc_usage_msg_path,
330 ghciUsagePath = ghci_usage_msg_path,
332 systemPackageConfig = pkgconfig_path,
336 pgm_c = (gcc_prog,gcc_args),
337 pgm_m = (mangle_prog,mangle_args),
338 pgm_s = (split_prog,split_args),
339 pgm_a = (as_prog,as_args),
340 pgm_l = (ld_prog,ld_args),
341 pgm_dll = (mkdll_prog,mkdll_args),
343 pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
344 pgm_windres = windres_path
345 -- Hans: this isn't right in general, but you can
346 -- elaborate it in the same way as the others
350 #if defined(mingw32_HOST_OS)
351 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
357 -- for "installed" this is the root of GHC's support files
358 -- for "in-place" it is the root of the build tree
361 -- 1. Set proto_top_dir
362 -- if there is no given TopDir path, get the directory
363 -- where GHC is running (only on Windows)
365 -- 2. If package.conf exists in proto_top_dir, we are running
366 -- installed; and TopDir = proto_top_dir
368 -- 3. Otherwise we are running in-place, so
369 -- proto_top_dir will be /...stuff.../ghc/compiler
370 -- Set TopDir to /...stuff..., which is the root of the build tree
372 -- This is very gruesome indeed
374 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
375 -> IO (Bool, -- True <=> am installed, False <=> in-place
376 String) -- TopDir (in Unix format '/' separated)
379 = do { top_dir <- get_proto
380 -- Discover whether we're running in a build tree or in an installation,
381 -- by looking for the package configuration file.
382 ; am_installed <- doesFileExist (top_dir </> "package.conf")
384 ; return (am_installed, top_dir)
387 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
388 get_proto = case mbMinusB of
389 Just minusb -> return (normalise minusb)
391 -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
392 case maybe_exec_dir of -- (only works on Windows;
393 -- returns Nothing on Unix)
394 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
395 Just dir -> return dir
399 %************************************************************************
401 \subsection{Running an external program}
403 %************************************************************************
407 runUnlit :: DynFlags -> [Option] -> IO ()
408 runUnlit dflags args = do
410 runSomething dflags "Literate pre-processor" p args
412 runCpp :: DynFlags -> [Option] -> IO ()
413 runCpp dflags args = do
414 let (p,args0) = pgm_P dflags
415 args1 = args0 ++ args
416 mb_env <- getGccEnv args1
417 runSomethingFiltered dflags id "C pre-processor" p args1 mb_env
419 runPp :: DynFlags -> [Option] -> IO ()
420 runPp dflags args = do
422 runSomething dflags "Haskell pre-processor" p args
424 runCc :: DynFlags -> [Option] -> IO ()
425 runCc dflags args = do
426 let (p,args0) = pgm_c dflags
427 args1 = args0 ++ args
428 mb_env <- getGccEnv args1
429 runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
431 -- discard some harmless warnings from gcc that we can't turn off
432 cc_filter = unlines . doFilter . lines
435 gcc gives warnings in chunks like so:
436 In file included from /foo/bar/baz.h:11,
437 from /foo/bar/baz2.h:22,
439 /foo/flibble:14: global register variable ...
440 /foo/flibble:15: warning: call-clobbered r...
441 We break it up into its chunks, remove any call-clobbered register
442 warnings from each chunk, and then delete any chunks that we have
445 doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
446 -- We can't assume that the output will start with an "In file inc..."
447 -- line, so we start off expecting a list of warnings rather than a
449 chunkWarnings :: [String] -- The location stack to use for the next
451 -> [String] -- The remaining lines to look at
452 -> [([String], [String])]
453 chunkWarnings loc_stack [] = [(loc_stack, [])]
454 chunkWarnings loc_stack xs
455 = case break loc_stack_start xs of
456 (warnings, lss:xs') ->
457 case span loc_start_continuation xs' of
459 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
460 _ -> [(loc_stack, xs)]
462 filterWarnings :: [([String], [String])] -> [([String], [String])]
463 filterWarnings [] = []
464 -- If the warnings are already empty then we are probably doing
465 -- something wrong, so don't delete anything
466 filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
467 filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
468 [] -> filterWarnings zs
469 ys' -> (xs, ys') : filterWarnings zs
471 unChunkWarnings :: [([String], [String])] -> [String]
472 unChunkWarnings [] = []
473 unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
475 loc_stack_start s = "In file included from " `isPrefixOf` s
476 loc_start_continuation s = " from " `isPrefixOf` s
478 | "warning: call-clobbered register used" `isContainedIn` w = False
481 isContainedIn :: String -> String -> Bool
482 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
484 -- If the -B<dir> option is set, add <dir> to PATH. This works around
485 -- a bug in gcc on Windows Vista where it can't find its auxiliary
486 -- binaries (see bug #1110).
487 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
489 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
494 else do env <- getEnvironment
495 return (Just (map mangle_path env))
497 (b_dirs, _) = partitionWith get_b_opt opts
499 get_b_opt (Option ('-':'B':dir)) = Left dir
500 get_b_opt other = Right other
502 mangle_path (path,paths) | map toUpper path == "PATH"
503 = (path, '\"' : head b_dirs ++ "\";" ++ paths)
504 mangle_path other = other
507 runMangle :: DynFlags -> [Option] -> IO ()
508 runMangle dflags args = do
509 let (p,args0) = pgm_m dflags
510 runSomething dflags "Mangler" p (args0++args)
512 runSplit :: DynFlags -> [Option] -> IO ()
513 runSplit dflags args = do
514 let (p,args0) = pgm_s dflags
515 runSomething dflags "Splitter" p (args0++args)
517 runAs :: DynFlags -> [Option] -> IO ()
518 runAs dflags args = do
519 let (p,args0) = pgm_a dflags
520 args1 = args0 ++ args
521 mb_env <- getGccEnv args1
522 runSomethingFiltered dflags id "Assembler" p args1 mb_env
524 runLink :: DynFlags -> [Option] -> IO ()
525 runLink dflags args = do
526 let (p,args0) = pgm_l dflags
527 args1 = args0 ++ args
528 mb_env <- getGccEnv args1
529 runSomethingFiltered dflags id "Linker" p args1 mb_env
531 runMkDLL :: DynFlags -> [Option] -> IO ()
532 runMkDLL dflags args = do
533 let (p,args0) = pgm_dll dflags
534 args1 = args0 ++ args
535 mb_env <- getGccEnv (args0++args)
536 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
538 runWindres :: DynFlags -> [Option] -> IO ()
539 runWindres dflags args = do
540 let (gcc,gcc_args) = pgm_c dflags
541 windres = pgm_windres dflags
542 mb_env <- getGccEnv gcc_args
543 runSomethingFiltered dflags id "Windres" windres
544 -- we must tell windres where to find gcc: it might not be on PATH
545 (Option ("--preprocessor=" ++
546 unwords (map quote (gcc : map showOpt gcc_args ++
547 ["-E", "-xc", "-DRC_INVOKED"])))
548 -- -- use-temp-file is required for windres to interpret the
549 -- quoting in the preprocessor arg above correctly. Without
550 -- this, windres calls the preprocessor with popen, which gets
551 -- the quoting wrong (discovered by experimentation and
552 -- reading the windres sources). See #1828.
553 : Option "--use-temp-file"
555 -- we must use the PATH workaround here too, since windres invokes gcc
558 quote x = '\"' : x ++ "\""
560 touch :: DynFlags -> String -> String -> IO ()
561 touch dflags purpose arg =
562 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
564 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
565 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
567 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
569 copyWithHeader dflags purpose maybe_header from to = do
570 showPass dflags purpose
572 h <- openFile to WriteMode
573 ls <- readFile from -- inefficient, but it'll do for now.
574 -- ToDo: speed up via slurping.
575 maybe (return ()) (hPutStr h) maybe_header
579 getExtraViaCOpts :: DynFlags -> IO [String]
580 getExtraViaCOpts dflags = do
581 f <- readFile (topDir dflags </> "extra-gcc-opts")
585 %************************************************************************
587 \subsection{Managing temporary files
589 %************************************************************************
592 GLOBAL_VAR(v_FilesToClean, [], [String] )
593 GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
597 cleanTempDirs :: DynFlags -> IO ()
599 = unless (dopt Opt_KeepTmpFiles dflags)
600 $ do ds <- readIORef v_DirsToClean
601 removeTmpDirs dflags (eltsFM ds)
602 writeIORef v_DirsToClean emptyFM
604 cleanTempFiles :: DynFlags -> IO ()
605 cleanTempFiles dflags
606 = unless (dopt Opt_KeepTmpFiles dflags)
607 $ do fs <- readIORef v_FilesToClean
608 removeTmpFiles dflags fs
609 writeIORef v_FilesToClean []
611 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
612 cleanTempFilesExcept dflags dont_delete
613 = unless (dopt Opt_KeepTmpFiles dflags)
614 $ do files <- readIORef v_FilesToClean
615 let (to_keep, to_delete) = partition (`elem` dont_delete) files
616 removeTmpFiles dflags to_delete
617 writeIORef v_FilesToClean to_keep
620 -- find a temporary name that doesn't already exist.
621 newTempName :: DynFlags -> Suffix -> IO FilePath
622 newTempName dflags extn
623 = do d <- getTempDir dflags
625 findTempName (d ++ "/ghc" ++ show x ++ "_") 0
627 findTempName :: FilePath -> Integer -> IO FilePath
628 findTempName prefix x
629 = do let filename = (prefix ++ show x) <.> extn
630 b <- doesFileExist filename
631 if b then findTempName prefix (x+1)
632 else do consIORef v_FilesToClean filename -- clean it up later
635 -- return our temporary directory within tmp_dir, creating one if we
636 -- don't have one yet
637 getTempDir :: DynFlags -> IO FilePath
638 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
639 = do mapping <- readIORef v_DirsToClean
640 case lookupFM mapping tmp_dir of
643 let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
645 mkTempDir :: Integer -> IO FilePath
647 = let dirname = prefix ++ show x
648 in do createDirectory dirname
649 let mapping' = addToFM mapping tmp_dir dirname
650 writeIORef v_DirsToClean mapping'
651 debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
654 if isAlreadyExistsError e
660 addFilesToClean :: [FilePath] -> IO ()
661 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
662 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
664 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
665 removeTmpDirs dflags ds
666 = traceCmd dflags "Deleting temp dirs"
667 ("Deleting: " ++ unwords ds)
668 (mapM_ (removeWith dflags removeDirectory) ds)
670 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
671 removeTmpFiles dflags fs
673 traceCmd dflags "Deleting temp files"
674 ("Deleting: " ++ unwords deletees)
675 (mapM_ (removeWith dflags removeFile) deletees)
677 -- Flat out refuse to delete files that are likely to be source input
678 -- files (is there a worse bug than having a compiler delete your source
681 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
684 | null non_deletees = act
686 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
689 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
691 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
692 removeWith dflags remover f = remover f `IO.catch`
694 let msg = if isDoesNotExistError e
695 then ptext SLIT("Warning: deleting non-existent") <+> text f
696 else ptext SLIT("Warning: exception raised when deleting")
699 in debugTraceMsg dflags 2 msg
702 -----------------------------------------------------------------------------
703 -- Running an external program
705 runSomething :: DynFlags
706 -> String -- For -v message
707 -> String -- Command name (possibly a full path)
708 -- assumed already dos-ified
709 -> [Option] -- Arguments
710 -- runSomething will dos-ify them
713 runSomething dflags phase_name pgm args =
714 runSomethingFiltered dflags id phase_name pgm args Nothing
717 :: DynFlags -> (String->String) -> String -> String -> [Option]
718 -> Maybe [(String,String)] -> IO ()
720 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
721 let real_args = filter notNull (map showOpt args)
722 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
723 (exit_code, doesn'tExist) <-
725 rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
727 ExitSuccess{} -> return (rc, False)
729 -- rawSystem returns (ExitFailure 127) if the exec failed for any
730 -- reason (eg. the program doesn't exist). This is the only clue
731 -- we have, but we need to report something to the user because in
732 -- the case of a missing program there will otherwise be no output
734 | n == 127 -> return (rc, True)
735 | otherwise -> return (rc, False))
736 -- Should 'rawSystem' generate an IO exception indicating that
737 -- 'pgm' couldn't be run rather than a funky return code, catch
738 -- this here (the win32 version does this, but it doesn't hurt
739 -- to test for this in general.)
741 if IO.isDoesNotExistError err
742 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
743 -- the 'compat' version of rawSystem under mingw32 always
744 -- maps 'errno' to EINVAL to failure.
745 || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
747 then return (ExitFailure 1, True)
749 case (doesn'tExist, exit_code) of
750 (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
751 (_, ExitSuccess) -> return ()
752 _ -> throwDyn (PhaseFailed phase_name exit_code)
756 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
757 builderMainLoop dflags filter_fn pgm real_args mb_env = do
758 rawSystem pgm real_args
760 builderMainLoop dflags filter_fn pgm real_args mb_env = do
762 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
764 -- and run a loop piping the output from the compiler to the log_action in DynFlags
765 hSetBuffering hStdOut LineBuffering
766 hSetBuffering hStdErr LineBuffering
767 forkIO (readerProc chan hStdOut filter_fn)
768 forkIO (readerProc chan hStdErr filter_fn)
769 -- we don't want to finish until 2 streams have been completed
770 -- (stdout and stderr)
771 -- nor until 1 exit code has been retrieved.
772 rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
773 -- after that, we're done here.
779 -- status starts at zero, and increments each time either
780 -- a reader process gets EOF, or the build proc exits. We wait
781 -- for all of these to happen (status==3).
782 -- ToDo: we should really have a contingency plan in case any of
783 -- the threads dies, such as a timeout.
784 loop chan hProcess 0 0 exitcode = return exitcode
785 loop chan hProcess t p exitcode = do
787 then getProcessExitCode hProcess
790 Just code -> loop chan hProcess t (p-1) code
796 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
797 loop chan hProcess t p exitcode
798 BuildError loc msg -> do
799 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
800 loop chan hProcess t p exitcode
802 loop chan hProcess (t-1) p exitcode
803 | otherwise -> loop chan hProcess t p exitcode
805 readerProc chan hdl filter_fn =
806 (do str <- hGetContents hdl
807 loop (linesPlatform (filter_fn str)) Nothing)
810 -- ToDo: check errors more carefully
811 -- ToDo: in the future, the filter should be implemented as
812 -- a stream transformer.
814 loop [] Nothing = return ()
815 loop [] (Just err) = writeChan chan err
818 Just err@(BuildError srcLoc msg)
819 | leading_whitespace l -> do
820 loop ls (Just (BuildError srcLoc (msg $$ text l)))
828 = case parseError l of
830 writeChan chan (BuildMsg (text l))
832 Just (file, lineNum, colNum, msg) -> do
833 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
834 loop ls (Just (BuildError srcLoc (text msg)))
836 leading_whitespace [] = False
837 leading_whitespace (x:_) = isSpace x
839 parseError :: String -> Maybe (String, Int, Int, String)
840 parseError s0 = case breakColon s0 of
841 Just (filename, s1) ->
842 case breakIntColon s1 of
843 Just (lineNum, s2) ->
844 case breakIntColon s2 of
845 Just (columnNum, s3) ->
846 Just (filename, lineNum, columnNum, s3)
848 Just (filename, lineNum, 0, s2)
852 breakColon :: String -> Maybe (String, String)
853 breakColon xs = case break (':' ==) xs of
854 (ys, _:zs) -> Just (ys, zs)
857 breakIntColon :: String -> Maybe (Int, String)
858 breakIntColon xs = case break (':' ==) xs of
860 | not (null ys) && all isAscii ys && all isDigit ys ->
866 | BuildError !SrcLoc !SDoc
870 showOpt (FileOption pre f) = pre ++ f
871 showOpt (Option s) = s
873 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
874 -- a) trace the command (at two levels of verbosity)
875 -- b) don't do it at all if dry-run is set
876 traceCmd dflags phase_name cmd_line action
877 = do { let verb = verbosity dflags
878 ; showPass dflags phase_name
879 ; debugTraceMsg dflags 3 (text cmd_line)
883 ; unless (dopt Opt_DryRun dflags) $ do {
886 ; action `IO.catch` handle_exn verb
889 handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
890 ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
891 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
894 %************************************************************************
896 \subsection{Support code}
898 %************************************************************************
901 -----------------------------------------------------------------------------
902 -- Define getBaseDir :: IO (Maybe String)
904 getBaseDir :: IO (Maybe String)
905 #if defined(mingw32_HOST_OS)
906 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
907 -- return the path $(stuff). Note that we drop the "bin/" directory too.
908 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
909 buf <- mallocArray len
910 ret <- getModuleFileName nullPtr buf len
911 if ret == 0 then free buf >> return Nothing
912 else do s <- peekCString buf
914 return (Just (rootDir s))
916 rootDir s = case splitFileName $ normalise s of
918 case splitFileName $ takeDirectory d of
919 (d', "bin") -> takeDirectory d'
920 _ -> panic ("Expected \"bin\" in " ++ show s)
921 _ -> panic ("Expected \"ghc.exe\" in " ++ show s)
923 foreign import stdcall unsafe "GetModuleFileNameA"
924 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
926 getBaseDir = return Nothing
929 #ifdef mingw32_HOST_OS
930 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
932 getProcessID :: IO Int
933 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
936 -- Divvy up text stream into lines, taking platform dependent
937 -- line termination into account.
938 linesPlatform :: String -> [String]
939 #if !defined(mingw32_HOST_OS)
940 linesPlatform ls = lines ls
942 linesPlatform "" = []
945 (as,xs1) -> as : linesPlatform xs1
947 lineBreak "" = ("","")
948 lineBreak ('\r':'\n':xs) = ([],xs)
949 lineBreak ('\n':xs) = ([],xs)
950 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)