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,
33 system, -- String -> IO ExitCode
39 #include "HsVersions.h"
50 import Control.Exception
55 import System.Environment
57 import SYSTEM_IO_ERROR as IO
58 import System.Directory
62 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
63 -- lines on mingw32, so we disallow it now.
64 #if __GLASGOW_HASKELL__ < 500
65 #error GHC >= 5.00 is required for bootstrapping GHC
68 #ifndef mingw32_HOST_OS
69 #if __GLASGOW_HASKELL__ > 504
70 import qualified System.Posix.Internals
72 import qualified Posix
74 #else /* Must be Win32 */
75 import List ( isPrefixOf )
76 import Util ( dropList )
78 import CString ( CString, peekCString )
83 #if __GLASGOW_HASKELL__ < 603
84 -- rawSystem comes from libghccompat.a in stage1
85 import Compat.RawSystem ( rawSystem )
86 import System.Cmd ( system )
87 import GHC.IOBase ( IOErrorType(..) )
89 import System.Cmd ( rawSystem, system )
90 import System.Process ( runInteractiveProcess, getProcessExitCode )
91 import Control.Concurrent( forkIO, newChan, readChan, writeChan )
92 import Data.Char ( isSpace )
93 import FastString ( mkFastString )
94 import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
99 The configuration story
100 ~~~~~~~~~~~~~~~~~~~~~~~
102 GHC needs various support files (library packages, RTS etc), plus
103 various auxiliary programs (cp, gcc, etc). It finds these in one
106 * When running as an *installed program*, GHC finds most of this support
107 stuff in the installed library tree. The path to this tree is passed
108 to GHC via the -B flag, and given to initSysTools .
110 * When running *in-place* in a build tree, GHC finds most of this support
111 stuff in the build tree. The path to the build tree is, again passed
114 GHC tells which of the two is the case by seeing whether package.conf
115 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
118 SysTools.initSysProgs figures out exactly where all the auxiliary programs
119 are, and initialises mutable variables to make it easy to call them.
120 To to this, it makes use of definitions in Config.hs, which is a Haskell
121 file containing variables whose value is figured out by the build system.
123 Config.hs contains two sorts of things
125 cGCC, The *names* of the programs
128 etc They do *not* include paths
131 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
132 cSPLIT_DIR_REL *relative* to the root of the build tree,
133 for use when running *in-place* in a build tree (only)
137 ---------------------------------------------
138 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
140 Another hair-brained scheme for simplifying the current tool location
141 nightmare in GHC: Simon originally suggested using another
142 configuration file along the lines of GCC's specs file - which is fine
143 except that it means adding code to read yet another configuration
144 file. What I didn't notice is that the current package.conf is
145 general enough to do this:
148 {name = "tools", import_dirs = [], source_dirs = [],
149 library_dirs = [], hs_libraries = [], extra_libraries = [],
150 include_dirs = [], c_includes = [], package_deps = [],
151 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
152 extra_cc_opts = [], extra_ld_opts = []}
154 Which would have the advantage that we get to collect together in one
155 place the path-specific package stuff with the path-specific tool
158 ---------------------------------------------
160 %************************************************************************
162 \subsection{Initialisation}
164 %************************************************************************
167 initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
170 -> IO DynFlags -- Set all the mutable variables above, holding
171 -- (a) the system programs
172 -- (b) the package-config file
173 -- (c) the GHC usage message
176 initSysTools mbMinusB dflags
177 = do { (am_installed, top_dir) <- findTopDir mbMinusB
179 -- for "installed" this is the root of GHC's support files
180 -- for "in-place" it is the root of the build tree
181 -- NB: top_dir is assumed to be in standard Unix
182 -- format, '/' separated
184 ; let installed, installed_bin :: FilePath -> FilePath
185 installed_bin pgm = pgmPath top_dir pgm
186 installed file = pgmPath top_dir file
187 inplace dir pgm = pgmPath (top_dir `joinFileName`
188 cPROJECT_DIR `joinFileName` dir) pgm
191 | am_installed = installed "package.conf"
192 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
195 | am_installed = installed "ghc-usage.txt"
196 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
199 | am_installed = installed "ghci-usage.txt"
200 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
202 -- For all systems, unlit, split, mangle are GHC utilities
203 -- architecture-specific stuff is done when building Config.hs
205 | am_installed = installed_bin cGHC_UNLIT_PGM
206 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
208 -- split and mangle are Perl scripts
210 | am_installed = installed_bin cGHC_SPLIT_PGM
211 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
214 | am_installed = installed_bin cGHC_MANGLER_PGM
215 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
217 ; let dflags0 = defaultDynFlags
218 #ifndef mingw32_HOST_OS
219 -- check whether TMPDIR is set in the environment
220 ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
222 -- On Win32, consult GetTempPath() for a temp dir.
223 -- => it first tries TMP, TEMP, then finally the
224 -- Windows directory(!). The directory is in short-path
228 let len = (2048::Int)
229 buf <- mallocArray len
230 ret <- getTempPath len buf
232 -- failed, consult TMPDIR.
240 ; let dflags1 = case e_tmpdir of
242 Right d -> setTmpDir d dflags0
244 -- Check that the package config exists
245 ; config_exists <- doesFileExist pkgconfig_path
246 ; when (not config_exists) $
247 throwDyn (InstallationError
248 ("Can't find package.conf as " ++ pkgconfig_path))
250 #if defined(mingw32_HOST_OS)
251 -- WINDOWS-SPECIFIC STUFF
252 -- On Windows, gcc and friends are distributed with GHC,
253 -- so when "installed" we look in TopDir/bin
254 -- When "in-place" we look wherever the build-time configure
256 -- When "install" we tell gcc where its specs file + exes are (-B)
257 -- and also some places to pick up include files. We need
258 -- to be careful to put all necessary exes in the -B place
259 -- (as, ld, cc1, etc) since if they don't get found there, gcc
260 -- then tries to run unadorned "as", "ld", etc, and will
261 -- pick up whatever happens to be lying around in the path,
262 -- possibly including those from a cygwin install on the target,
263 -- which is exactly what we're trying to avoid.
264 ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
266 | am_installed = (installed_bin "gcc", [gcc_b_arg])
267 | otherwise = (cGCC, [])
268 -- The trailing "/" is absolutely essential; gcc seems
269 -- to construct file names simply by concatenating to
270 -- this -B path with no extra slash We use "/" rather
271 -- than "\\" because otherwise "\\\" is mangled
272 -- later on; although gcc_args are in NATIVE format,
274 -- (see comments with declarations of global variables)
276 -- The quotes round the -B argument are in case TopDir
279 perl_path | am_installed = installed_bin cGHC_PERL
280 | otherwise = cGHC_PERL
282 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
283 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
284 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
286 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
287 -- a call to Perl to get the invocation of split and mangle
288 ; let (split_prog, split_args) = (perl_path, [Option split_script])
289 (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
291 ; let (mkdll_prog, mkdll_args)
293 (pgmPath (installed "gcc-lib/") cMKDLL,
294 [ Option "--dlltool-name",
295 Option (pgmPath (installed "gcc-lib/") "dlltool"),
296 Option "--driver-name",
297 Option gcc_prog, gcc_b_arg ])
298 | otherwise = (cMKDLL, [])
300 -- UNIX-SPECIFIC STUFF
301 -- On Unix, the "standard" tools are assumed to be
302 -- in the same place whether we are running "in-place" or "installed"
303 -- That place is wherever the build-time configure script found them.
304 ; let gcc_prog = cGCC
307 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
310 -- On Unix, scripts are invoked using the '#!' method. Binary
311 -- installations of GHC on Unix place the correct line on the front
312 -- of the script at installation time, so we don't want to wire-in
313 -- our knowledge of $(PERL) on the host system here.
314 ; let (split_prog, split_args) = (split_script, [])
315 (mangle_prog, mangle_args) = (mangle_script, [])
318 -- cpp is derived from gcc on all platforms
319 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
320 -- Config.hs one day.
321 ; let cpp_path = (gcc_prog, gcc_args ++
322 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
324 -- For all systems, copy and remove are provided by the host
325 -- system; architecture-specific stuff is done when building Config.hs
326 ; let cp_path = cGHC_CP
328 -- Other things being equal, as and ld are simply gcc
329 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
330 (ld_prog,ld_args) = (gcc_prog,gcc_args)
333 ghcUsagePath = ghc_usage_msg_path,
334 ghciUsagePath = ghci_usage_msg_path,
336 systemPackageConfig = pkgconfig_path,
340 pgm_c = (gcc_prog,gcc_args),
341 pgm_m = (mangle_prog,mangle_args),
342 pgm_s = (split_prog,split_args),
343 pgm_a = (as_prog,as_args),
344 pgm_l = (ld_prog,ld_args),
345 pgm_dll = (mkdll_prog,mkdll_args),
347 pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan"
348 -- Hans: this isn't right in general, but you can
349 -- elaborate it in the same way as the others
353 #if defined(mingw32_HOST_OS)
354 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
360 -- for "installed" this is the root of GHC's support files
361 -- for "in-place" it is the root of the build tree
364 -- 1. Set proto_top_dir
365 -- if there is no given TopDir path, get the directory
366 -- where GHC is running (only on Windows)
368 -- 2. If package.conf exists in proto_top_dir, we are running
369 -- installed; and TopDir = proto_top_dir
371 -- 3. Otherwise we are running in-place, so
372 -- proto_top_dir will be /...stuff.../ghc/compiler
373 -- Set TopDir to /...stuff..., which is the root of the build tree
375 -- This is very gruesome indeed
377 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
378 -> IO (Bool, -- True <=> am installed, False <=> in-place
379 String) -- TopDir (in Unix format '/' separated)
382 = do { top_dir <- get_proto
383 -- Discover whether we're running in a build tree or in an installation,
384 -- by looking for the package configuration file.
385 ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf")
387 ; return (am_installed, top_dir)
390 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
391 get_proto = case mbMinusB of
392 Just minusb -> return (normalisePath minusb)
394 -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
395 case maybe_exec_dir of -- (only works on Windows;
396 -- returns Nothing on Unix)
397 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
398 Just dir -> return dir
402 %************************************************************************
404 \subsection{Running an external program}
406 %************************************************************************
410 runUnlit :: DynFlags -> [Option] -> IO ()
411 runUnlit dflags args = do
413 runSomething dflags "Literate pre-processor" p args
415 runCpp :: DynFlags -> [Option] -> IO ()
416 runCpp dflags args = do
417 let (p,args0) = pgm_P dflags
418 runSomething dflags "C pre-processor" p (args0 ++ args)
420 runPp :: DynFlags -> [Option] -> IO ()
421 runPp dflags args = do
423 runSomething dflags "Haskell pre-processor" p args
425 runCc :: DynFlags -> [Option] -> IO ()
426 runCc dflags args = do
427 let (p,args0) = pgm_c dflags
428 runSomethingFiltered dflags cc_filter "C Compiler" p (args0++args)
430 -- discard some harmless warnings from gcc that we can't turn off
431 cc_filter str = unlines (do_filter (lines str))
435 | (w:rest) <- dropWhile (isJust .matchRegex r_from) ls,
436 isJust (matchRegex r_warn w)
441 r_from = mkRegex "from.*:[0-9]+"
442 r_warn = mkRegex "warning: call-clobbered register used"
444 runMangle :: DynFlags -> [Option] -> IO ()
445 runMangle dflags args = do
446 let (p,args0) = pgm_m dflags
447 runSomething dflags "Mangler" p (args0++args)
449 runSplit :: DynFlags -> [Option] -> IO ()
450 runSplit dflags args = do
451 let (p,args0) = pgm_s dflags
452 runSomething dflags "Splitter" p (args0++args)
454 runAs :: DynFlags -> [Option] -> IO ()
455 runAs dflags args = do
456 let (p,args0) = pgm_a dflags
457 runSomething dflags "Assembler" p (args0++args)
459 runLink :: DynFlags -> [Option] -> IO ()
460 runLink dflags args = do
461 let (p,args0) = pgm_l dflags
462 runSomething dflags "Linker" p (args0++args)
464 runMkDLL :: DynFlags -> [Option] -> IO ()
465 runMkDLL dflags args = do
466 let (p,args0) = pgm_dll dflags
467 runSomething dflags "Make DLL" p (args0++args)
469 touch :: DynFlags -> String -> String -> IO ()
470 touch dflags purpose arg =
471 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
473 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
474 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
476 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
478 copyWithHeader dflags purpose maybe_header from to = do
479 showPass dflags purpose
481 h <- openFile to WriteMode
482 ls <- readFile from -- inefficient, but it'll do for now.
483 -- ToDo: speed up via slurping.
484 maybe (return ()) (hPutStr h) maybe_header
490 %************************************************************************
492 \subsection{Managing temporary files
494 %************************************************************************
497 GLOBAL_VAR(v_FilesToClean, [], [String] )
498 GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
502 cleanTempDirs :: DynFlags -> IO ()
504 = unless (dopt Opt_KeepTmpFiles dflags)
505 $ do ds <- readIORef v_DirsToClean
506 removeTmpDirs dflags (eltsFM ds)
507 writeIORef v_DirsToClean emptyFM
509 cleanTempFiles :: DynFlags -> IO ()
510 cleanTempFiles dflags
511 = unless (dopt Opt_KeepTmpFiles dflags)
512 $ do fs <- readIORef v_FilesToClean
513 removeTmpFiles dflags fs
514 writeIORef v_FilesToClean []
516 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
517 cleanTempFilesExcept dflags dont_delete
518 = unless (dopt Opt_KeepTmpFiles dflags)
519 $ do files <- readIORef v_FilesToClean
520 let (to_keep, to_delete) = partition (`elem` dont_delete) files
521 removeTmpFiles dflags to_delete
522 writeIORef v_FilesToClean to_keep
525 -- find a temporary name that doesn't already exist.
526 newTempName :: DynFlags -> Suffix -> IO FilePath
527 newTempName dflags extn
528 = do d <- getTempDir dflags
530 findTempName (d ++ "/ghc" ++ show x ++ "_") 0
532 findTempName prefix x
533 = do let filename = (prefix ++ show x) `joinFileExt` extn
534 b <- doesFileExist filename
535 if b then findTempName prefix (x+1)
536 else do consIORef v_FilesToClean filename -- clean it up later
539 -- return our temporary directory within tmp_dir, creating one if we
540 -- don't have one yet
541 getTempDir :: DynFlags -> IO FilePath
542 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
543 = do mapping <- readIORef v_DirsToClean
544 case lookupFM mapping tmp_dir of
547 let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
549 = let dirname = prefix ++ show x
550 in do createDirectory dirname
551 let mapping' = addToFM mapping tmp_dir dirname
552 writeIORef v_DirsToClean mapping'
553 debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
556 if isAlreadyExistsError e
562 addFilesToClean :: [FilePath] -> IO ()
563 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
564 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
566 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
567 removeTmpDirs dflags ds
568 = traceCmd dflags "Deleting temp dirs"
569 ("Deleting: " ++ unwords ds)
570 (mapM_ (removeWith dflags removeDirectory) ds)
572 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
573 removeTmpFiles dflags fs
575 traceCmd dflags "Deleting temp files"
576 ("Deleting: " ++ unwords deletees)
577 (mapM_ (removeWith dflags removeFile) deletees)
579 -- Flat out refuse to delete files that are likely to be source input
580 -- files (is there a worse bug than having a compiler delete your source
583 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
586 | null non_deletees = act
588 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
591 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
593 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
594 removeWith dflags remover f = remover f `IO.catch`
596 let msg = if isDoesNotExistError e
597 then ptext SLIT("Warning: deleting non-existent") <+> text f
598 else ptext SLIT("Warning: exception raised when deleting")
601 in debugTraceMsg dflags 2 msg
604 -----------------------------------------------------------------------------
605 -- Running an external program
607 runSomething :: DynFlags
608 -> String -- For -v message
609 -> String -- Command name (possibly a full path)
610 -- assumed already dos-ified
611 -> [Option] -- Arguments
612 -- runSomething will dos-ify them
615 runSomething dflags phase_name pgm args =
616 runSomethingFiltered dflags id phase_name pgm args
619 :: DynFlags -> (String->String) -> String -> String -> [Option] -> IO ()
621 runSomethingFiltered dflags filter_fn phase_name pgm args = do
622 let real_args = filter notNull (map showOpt args)
623 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
624 (exit_code, doesn'tExist) <-
626 rc <- builderMainLoop dflags filter_fn pgm real_args
628 ExitSuccess{} -> return (rc, False)
630 -- rawSystem returns (ExitFailure 127) if the exec failed for any
631 -- reason (eg. the program doesn't exist). This is the only clue
632 -- we have, but we need to report something to the user because in
633 -- the case of a missing program there will otherwise be no output
635 | n == 127 -> return (rc, True)
636 | otherwise -> return (rc, False))
637 -- Should 'rawSystem' generate an IO exception indicating that
638 -- 'pgm' couldn't be run rather than a funky return code, catch
639 -- this here (the win32 version does this, but it doesn't hurt
640 -- to test for this in general.)
642 if IO.isDoesNotExistError err
643 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
644 -- the 'compat' version of rawSystem under mingw32 always
645 -- maps 'errno' to EINVAL to failure.
646 || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
648 then return (ExitFailure 1, True)
650 case (doesn'tExist, exit_code) of
651 (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
652 (_, ExitSuccess) -> return ()
653 _ -> throwDyn (PhaseFailed phase_name exit_code)
657 #if __GLASGOW_HASKELL__ < 603
658 builderMainLoop dflags filter_fn pgm real_args = do
659 rawSystem pgm real_args
661 builderMainLoop dflags filter_fn pgm real_args = do
663 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing
665 -- and run a loop piping the output from the compiler to the log_action in DynFlags
666 hSetBuffering hStdOut LineBuffering
667 hSetBuffering hStdErr LineBuffering
668 forkIO (readerProc chan hStdOut filter_fn)
669 forkIO (readerProc chan hStdErr filter_fn)
670 rc <- loop chan hProcess 2 1 ExitSuccess
676 -- status starts at zero, and increments each time either
677 -- a reader process gets EOF, or the build proc exits. We wait
678 -- for all of these to happen (status==3).
679 -- ToDo: we should really have a contingency plan in case any of
680 -- the threads dies, such as a timeout.
681 loop chan hProcess 0 0 exitcode = return exitcode
682 loop chan hProcess t p exitcode = do
684 then getProcessExitCode hProcess
687 Just code -> loop chan hProcess t (p-1) code
693 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
694 loop chan hProcess t p exitcode
695 BuildError loc msg -> do
696 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
697 loop chan hProcess t p exitcode
699 loop chan hProcess (t-1) p exitcode
700 | otherwise -> loop chan hProcess t p exitcode
702 readerProc chan hdl filter_fn =
703 (do str <- hGetContents hdl
704 loop (linesPlatform (filter_fn str)) Nothing)
707 -- ToDo: check errors more carefully
708 -- ToDo: in the future, the filter should be implemented as
709 -- a stream transformer.
711 loop [] Nothing = return ()
712 loop [] (Just err) = writeChan chan err
715 Just err@(BuildError srcLoc msg)
716 | leading_whitespace l -> do
717 loop ls (Just (BuildError srcLoc (msg $$ text l)))
725 = case matchRegex errRegex l of
727 writeChan chan (BuildMsg (text l))
729 Just (file':lineno':colno':msg:_) -> do
730 let file = mkFastString file'
731 lineno = read lineno'::Int
732 colno = case colno' of
734 _ -> read (init colno') :: Int
735 srcLoc = mkSrcLoc file lineno colno
736 loop ls (Just (BuildError srcLoc (text msg)))
738 leading_whitespace [] = False
739 leading_whitespace (x:_) = isSpace x
741 errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"
745 | BuildError !SrcLoc !SDoc
749 showOpt (FileOption pre f) = pre ++ platformPath f
750 showOpt (Option "") = ""
751 showOpt (Option s) = s
753 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
754 -- a) trace the command (at two levels of verbosity)
755 -- b) don't do it at all if dry-run is set
756 traceCmd dflags phase_name cmd_line action
757 = do { let verb = verbosity dflags
758 ; showPass dflags phase_name
759 ; debugTraceMsg dflags 3 (text cmd_line)
763 ; unless (dopt Opt_DryRun dflags) $ do {
766 ; action `IO.catch` handle_exn verb
769 handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
770 ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
771 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
774 %************************************************************************
776 \subsection{Support code}
778 %************************************************************************
781 -----------------------------------------------------------------------------
782 -- Define getBaseDir :: IO (Maybe String)
784 getBaseDir :: IO (Maybe String)
785 #if defined(mingw32_HOST_OS)
786 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
787 -- return the path $(stuff). Note that we drop the "bin/" directory too.
788 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
789 buf <- mallocArray len
790 ret <- getModuleFileName nullPtr buf len
791 if ret == 0 then free buf >> return Nothing
792 else do s <- peekCString buf
794 return (Just (rootDir s))
796 rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
798 foreign import stdcall unsafe "GetModuleFileNameA"
799 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
801 getBaseDir = return Nothing
804 #ifdef mingw32_HOST_OS
805 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
806 #elif __GLASGOW_HASKELL__ > 504
807 getProcessID :: IO Int
808 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
810 getProcessID :: IO Int
811 getProcessID = Posix.getProcessID
814 -- Divvy up text stream into lines, taking platform dependent
815 -- line termination into account.
816 linesPlatform :: String -> [String]
817 #if !defined(mingw32_HOST_OS)
818 linesPlatform ls = lines ls
820 linesPlatform "" = []
823 (as,xs1) -> as : linesPlatform xs1
825 lineBreak "" = ("","")
826 lineBreak ('\r':'\n':xs) = ([],xs)
827 lineBreak ('\n':xs) = ([],xs)
828 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)