1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2001-2003
5 -- Access to system tools: gcc, cp, rm etc
7 -----------------------------------------------------------------------------
14 getTopDir, -- IO String -- The value of $topdir
15 getPackageConfigPath, -- IO String -- Where package.conf is
16 getUsageMsgPaths, -- IO (String,String)
18 -- Interface to system tools
19 runUnlit, runCpp, runCc, -- [Option] -> IO ()
20 runPp, -- [Option] -> IO ()
21 runMangle, runSplit, -- [Option] -> IO ()
22 runAs, runLink, -- [Option] -> IO ()
25 touch, -- String -> String -> IO ()
26 copy, -- String -> String -> String -> IO ()
27 normalisePath, -- FilePath -> FilePath
29 -- Temporary-file management
32 cleanTempFiles, cleanTempFilesExcept,
36 system, -- String -> IO ExitCode
39 getSysMan, -- IO String Parallel system only
45 #include "HsVersions.h"
47 import DriverPhases ( isHaskellUserSrcFilename )
50 import ErrUtils ( putMsg, debugTraceMsg, showPass, Severity(..), Messages )
51 import Panic ( GhcException(..) )
52 import Util ( Suffix, global, notNull, consIORef, joinFileName,
53 normalisePath, pgmPath, platformPath, joinFileExt )
54 import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..),
55 setTmpDir, defaultDynFlags )
57 import EXCEPTION ( throwDyn, finally )
58 import DATA_IOREF ( IORef, readIORef, writeIORef )
61 import Monad ( when, unless )
62 import System ( ExitCode(..), getEnv, system )
63 import IO ( try, catch, hGetContents,
64 openFile, hPutStr, hClose, hFlush, IOMode(..),
65 stderr, ioError, isDoesNotExistError )
66 import Directory ( doesFileExist, removeFile )
67 import Maybe ( isJust )
68 import List ( partition )
70 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
71 -- lines on mingw32, so we disallow it now.
72 #if __GLASGOW_HASKELL__ < 500
73 #error GHC >= 5.00 is required for bootstrapping GHC
76 #ifndef mingw32_HOST_OS
77 #if __GLASGOW_HASKELL__ > 504
78 import qualified System.Posix.Internals
80 import qualified Posix
82 #else /* Must be Win32 */
83 import List ( isPrefixOf )
84 import Util ( dropList )
86 import CString ( CString, peekCString )
91 #if __GLASGOW_HASKELL__ < 603
92 -- rawSystem comes from libghccompat.a in stage1
93 import Compat.RawSystem ( rawSystem )
94 import GHC.IOBase ( IOErrorType(..) )
95 import System.IO.Error ( ioeGetErrorType )
97 import System.Process ( runInteractiveProcess, getProcessExitCode )
98 import System.IO ( hSetBuffering, hGetLine, BufferMode(..) )
99 import Control.Concurrent( forkIO, newChan, readChan, writeChan )
100 import Data.Char ( isSpace )
101 import FastString ( mkFastString )
102 import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
107 The configuration story
108 ~~~~~~~~~~~~~~~~~~~~~~~
110 GHC needs various support files (library packages, RTS etc), plus
111 various auxiliary programs (cp, gcc, etc). It finds these in one
114 * When running as an *installed program*, GHC finds most of this support
115 stuff in the installed library tree. The path to this tree is passed
116 to GHC via the -B flag, and given to initSysTools .
118 * When running *in-place* in a build tree, GHC finds most of this support
119 stuff in the build tree. The path to the build tree is, again passed
122 GHC tells which of the two is the case by seeing whether package.conf
123 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
126 SysTools.initSysProgs figures out exactly where all the auxiliary programs
127 are, and initialises mutable variables to make it easy to call them.
128 To to this, it makes use of definitions in Config.hs, which is a Haskell
129 file containing variables whose value is figured out by the build system.
131 Config.hs contains two sorts of things
133 cGCC, The *names* of the programs
136 etc They do *not* include paths
139 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
140 cSPLIT_DIR_REL *relative* to the root of the build tree,
141 for use when running *in-place* in a build tree (only)
145 ---------------------------------------------
146 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
148 Another hair-brained scheme for simplifying the current tool location
149 nightmare in GHC: Simon originally suggested using another
150 configuration file along the lines of GCC's specs file - which is fine
151 except that it means adding code to read yet another configuration
152 file. What I didn't notice is that the current package.conf is
153 general enough to do this:
156 {name = "tools", import_dirs = [], source_dirs = [],
157 library_dirs = [], hs_libraries = [], extra_libraries = [],
158 include_dirs = [], c_includes = [], package_deps = [],
159 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
160 extra_cc_opts = [], extra_ld_opts = []}
162 Which would have the advantage that we get to collect together in one
163 place the path-specific package stuff with the path-specific tool
166 ---------------------------------------------
169 %************************************************************************
171 \subsection{Global variables to contain system programs}
173 %************************************************************************
175 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
176 (See remarks under pathnames below)
179 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
180 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
182 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
183 GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String))
185 GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
187 -- Parallel system only
188 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
190 -- ways to get at some of these variables from outside this module
191 getPackageConfigPath = readIORef v_Path_package_config
192 getTopDir = readIORef v_TopDir
196 %************************************************************************
198 \subsection{Initialisation}
200 %************************************************************************
203 initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
206 -> IO DynFlags -- Set all the mutable variables above, holding
207 -- (a) the system programs
208 -- (b) the package-config file
209 -- (c) the GHC usage message
212 initSysTools mbMinusB dflags
213 = do { (am_installed, top_dir) <- findTopDir mbMinusB
214 ; writeIORef v_TopDir top_dir
216 -- for "installed" this is the root of GHC's support files
217 -- for "in-place" it is the root of the build tree
218 -- NB: top_dir is assumed to be in standard Unix format '/' separated
220 ; let installed, installed_bin :: FilePath -> FilePath
221 installed_bin pgm = pgmPath top_dir pgm
222 installed file = pgmPath top_dir file
223 inplace dir pgm = pgmPath (top_dir `joinFileName`
224 cPROJECT_DIR `joinFileName` dir) pgm
227 | am_installed = installed "package.conf"
228 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
231 | am_installed = installed "ghc-usage.txt"
232 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
235 | am_installed = installed "ghci-usage.txt"
236 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
238 -- For all systems, unlit, split, mangle are GHC utilities
239 -- architecture-specific stuff is done when building Config.hs
241 | am_installed = installed_bin cGHC_UNLIT_PGM
242 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
244 -- split and mangle are Perl scripts
246 | am_installed = installed_bin cGHC_SPLIT_PGM
247 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
250 | am_installed = installed_bin cGHC_MANGLER_PGM
251 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
253 ; let dflags0 = defaultDynFlags
254 #ifndef mingw32_HOST_OS
255 -- check whether TMPDIR is set in the environment
256 ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
258 -- On Win32, consult GetTempPath() for a temp dir.
259 -- => it first tries TMP, TEMP, then finally the
260 -- Windows directory(!). The directory is in short-path
264 let len = (2048::Int)
265 buf <- mallocArray len
266 ret <- getTempPath len buf
268 -- failed, consult TMPDIR.
276 ; let dflags1 = case e_tmpdir of
278 Right d -> setTmpDir d dflags0
280 -- Check that the package config exists
281 ; config_exists <- doesFileExist pkgconfig_path
282 ; when (not config_exists) $
283 throwDyn (InstallationError
284 ("Can't find package.conf as " ++ pkgconfig_path))
286 #if defined(mingw32_HOST_OS)
287 -- WINDOWS-SPECIFIC STUFF
288 -- On Windows, gcc and friends are distributed with GHC,
289 -- so when "installed" we look in TopDir/bin
290 -- When "in-place" we look wherever the build-time configure
292 -- When "install" we tell gcc where its specs file + exes are (-B)
293 -- and also some places to pick up include files. We need
294 -- to be careful to put all necessary exes in the -B place
295 -- (as, ld, cc1, etc) since if they don't get found there, gcc
296 -- then tries to run unadorned "as", "ld", etc, and will
297 -- pick up whatever happens to be lying around in the path,
298 -- possibly including those from a cygwin install on the target,
299 -- which is exactly what we're trying to avoid.
300 ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
302 | am_installed = (installed_bin "gcc", [gcc_b_arg])
303 | otherwise = (cGCC, [])
304 -- The trailing "/" is absolutely essential; gcc seems
305 -- to construct file names simply by concatenating to
306 -- this -B path with no extra slash We use "/" rather
307 -- than "\\" because otherwise "\\\" is mangled
308 -- later on; although gcc_args are in NATIVE format,
310 -- (see comments with declarations of global variables)
312 -- The quotes round the -B argument are in case TopDir
315 perl_path | am_installed = installed_bin cGHC_PERL
316 | otherwise = cGHC_PERL
318 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
319 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
320 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
322 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
323 -- a call to Perl to get the invocation of split and mangle
324 ; let (split_prog, split_args) = (perl_path, [Option split_script])
325 (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
327 ; let (mkdll_prog, mkdll_args)
329 (pgmPath (installed "gcc-lib/") cMKDLL,
330 [ Option "--dlltool-name",
331 Option (pgmPath (installed "gcc-lib/") "dlltool"),
332 Option "--driver-name",
333 Option gcc_prog, gcc_b_arg ])
334 | otherwise = (cMKDLL, [])
336 -- UNIX-SPECIFIC STUFF
337 -- On Unix, the "standard" tools are assumed to be
338 -- in the same place whether we are running "in-place" or "installed"
339 -- That place is wherever the build-time configure script found them.
340 ; let gcc_prog = cGCC
343 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
346 -- On Unix, scripts are invoked using the '#!' method. Binary
347 -- installations of GHC on Unix place the correct line on the front
348 -- of the script at installation time, so we don't want to wire-in
349 -- our knowledge of $(PERL) on the host system here.
350 ; let (split_prog, split_args) = (split_script, [])
351 (mangle_prog, mangle_args) = (mangle_script, [])
354 -- cpp is derived from gcc on all platforms
355 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
356 -- Config.hs one day.
357 ; let cpp_path = (gcc_prog, gcc_args ++
358 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
360 -- For all systems, copy and remove are provided by the host
361 -- system; architecture-specific stuff is done when building Config.hs
362 ; let cp_path = cGHC_CP
364 -- Other things being equal, as and ld are simply gcc
365 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
366 (ld_prog,ld_args) = (gcc_prog,gcc_args)
368 -- Initialise the global vars
369 ; writeIORef v_Path_package_config pkgconfig_path
370 ; writeIORef v_Path_usages (ghc_usage_msg_path,
373 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
374 -- Hans: this isn't right in general, but you can
375 -- elaborate it in the same way as the others
377 ; writeIORef v_Pgm_T touch_path
378 ; writeIORef v_Pgm_CP cp_path
384 pgm_c = (gcc_prog,gcc_args),
385 pgm_m = (mangle_prog,mangle_args),
386 pgm_s = (split_prog,split_args),
387 pgm_a = (as_prog,as_args),
388 pgm_l = (ld_prog,ld_args),
389 pgm_dll = (mkdll_prog,mkdll_args) }
392 #if defined(mingw32_HOST_OS)
393 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
399 -- for "installed" this is the root of GHC's support files
400 -- for "in-place" it is the root of the build tree
403 -- 1. Set proto_top_dir
404 -- if there is no given TopDir path, get the directory
405 -- where GHC is running (only on Windows)
407 -- 2. If package.conf exists in proto_top_dir, we are running
408 -- installed; and TopDir = proto_top_dir
410 -- 3. Otherwise we are running in-place, so
411 -- proto_top_dir will be /...stuff.../ghc/compiler
412 -- Set TopDir to /...stuff..., which is the root of the build tree
414 -- This is very gruesome indeed
416 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
417 -> IO (Bool, -- True <=> am installed, False <=> in-place
418 String) -- TopDir (in Unix format '/' separated)
421 = do { top_dir <- get_proto
422 -- Discover whether we're running in a build tree or in an installation,
423 -- by looking for the package configuration file.
424 ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf")
426 ; return (am_installed, top_dir)
429 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
430 get_proto = case mbMinusB of
431 Just minusb -> return (normalisePath minusb)
433 -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
434 case maybe_exec_dir of -- (only works on Windows;
435 -- returns Nothing on Unix)
436 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
437 Just dir -> return dir
441 %************************************************************************
443 \subsection{Running an external program}
445 %************************************************************************
449 runUnlit :: DynFlags -> [Option] -> IO ()
450 runUnlit dflags args = do
452 runSomething dflags "Literate pre-processor" p args
454 runCpp :: DynFlags -> [Option] -> IO ()
455 runCpp dflags args = do
456 let (p,args0) = pgm_P dflags
457 runSomething dflags "C pre-processor" p (args0 ++ args)
459 runPp :: DynFlags -> [Option] -> IO ()
460 runPp dflags args = do
462 runSomething dflags "Haskell pre-processor" p args
464 runCc :: DynFlags -> [Option] -> IO ()
465 runCc dflags args = do
466 let (p,args0) = pgm_c dflags
467 runSomethingFiltered dflags cc_filter "C Compiler" p (args0++args)
469 -- discard some harmless warnings from gcc that we can't turn off
470 cc_filter str = unlines (do_filter (lines str))
474 | (w:rest) <- dropWhile (isJust .matchRegex r_from) ls,
475 isJust (matchRegex r_warn w)
480 r_from = mkRegex "from.*:[0-9]+"
481 r_warn = mkRegex "warning: call-clobbered register used"
483 runMangle :: DynFlags -> [Option] -> IO ()
484 runMangle dflags args = do
485 let (p,args0) = pgm_m dflags
486 runSomething dflags "Mangler" p (args0++args)
488 runSplit :: DynFlags -> [Option] -> IO ()
489 runSplit dflags args = do
490 let (p,args0) = pgm_s dflags
491 runSomething dflags "Splitter" p (args0++args)
493 runAs :: DynFlags -> [Option] -> IO ()
494 runAs dflags args = do
495 let (p,args0) = pgm_a dflags
496 runSomething dflags "Assembler" p (args0++args)
498 runLink :: DynFlags -> [Option] -> IO ()
499 runLink dflags args = do
500 let (p,args0) = pgm_l dflags
501 runSomething dflags "Linker" p (args0++args)
503 runMkDLL :: DynFlags -> [Option] -> IO ()
504 runMkDLL dflags args = do
505 let (p,args0) = pgm_dll dflags
506 runSomething dflags "Make DLL" p (args0++args)
508 touch :: DynFlags -> String -> String -> IO ()
509 touch dflags purpose arg = do
510 p <- readIORef v_Pgm_T
511 runSomething dflags purpose p [FileOption "" arg]
513 copy :: DynFlags -> String -> String -> String -> IO ()
514 copy dflags purpose from to = do
515 showPass dflags purpose
517 h <- openFile to WriteMode
518 ls <- readFile from -- inefficient, but it'll do for now.
519 -- ToDo: speed up via slurping.
526 getSysMan :: IO String -- How to invoke the system manager
527 -- (parallel system only)
528 getSysMan = readIORef v_Pgm_sysman
532 getUsageMsgPaths :: IO (FilePath,FilePath)
533 -- the filenames of the usage messages (ghc, ghci)
534 getUsageMsgPaths = readIORef v_Path_usages
538 %************************************************************************
540 \subsection{Managing temporary files
542 %************************************************************************
545 GLOBAL_VAR(v_FilesToClean, [], [String] )
549 cleanTempFiles :: DynFlags -> IO ()
550 cleanTempFiles dflags
551 = do fs <- readIORef v_FilesToClean
552 removeTmpFiles dflags fs
553 writeIORef v_FilesToClean []
555 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
556 cleanTempFilesExcept dflags dont_delete
557 = do files <- readIORef v_FilesToClean
558 let (to_keep, to_delete) = partition (`elem` dont_delete) files
559 removeTmpFiles dflags to_delete
560 writeIORef v_FilesToClean to_keep
563 -- find a temporary name that doesn't already exist.
564 newTempName :: DynFlags -> Suffix -> IO FilePath
565 newTempName DynFlags{tmpDir=tmp_dir} extn
566 = do x <- getProcessID
567 findTempName (tmp_dir ++ "/ghc" ++ show x ++ "_") 0
569 findTempName prefix x
570 = do let filename = (prefix ++ show x) `joinFileExt` extn
571 b <- doesFileExist filename
572 if b then findTempName prefix (x+1)
573 else do consIORef v_FilesToClean filename -- clean it up later
576 addFilesToClean :: [FilePath] -> IO ()
577 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
578 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
580 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
581 removeTmpFiles dflags fs
583 traceCmd dflags "Deleting temp files"
584 ("Deleting: " ++ unwords deletees)
587 -- Flat out refuse to delete files that are likely to be source input
588 -- files (is there a worse bug than having a compiler delete your source
591 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
594 | null non_deletees = act
596 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
599 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
601 rm f = removeFile f `IO.catch`
603 debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
607 -----------------------------------------------------------------------------
608 -- Running an external program
610 runSomething :: DynFlags
611 -> String -- For -v message
612 -> String -- Command name (possibly a full path)
613 -- assumed already dos-ified
614 -> [Option] -- Arguments
615 -- runSomething will dos-ify them
618 runSomething dflags phase_name pgm args =
619 runSomethingFiltered dflags id phase_name pgm args
622 :: DynFlags -> (String->String) -> String -> String -> [Option] -> IO ()
624 runSomethingFiltered dflags filter_fn phase_name pgm args = do
625 let real_args = filter notNull (map showOpt args)
626 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
627 (exit_code, doesn'tExist) <-
629 rc <- builderMainLoop dflags filter_fn pgm real_args
631 ExitSuccess{} -> return (rc, False)
633 -- rawSystem returns (ExitFailure 127) if the exec failed for any
634 -- reason (eg. the program doesn't exist). This is the only clue
635 -- we have, but we need to report something to the user because in
636 -- the case of a missing program there will otherwise be no output
638 | n == 127 -> return (rc, True)
639 | otherwise -> return (rc, False))
640 -- Should 'rawSystem' generate an IO exception indicating that
641 -- 'pgm' couldn't be run rather than a funky return code, catch
642 -- this here (the win32 version does this, but it doesn't hurt
643 -- to test for this in general.)
645 if IO.isDoesNotExistError err
646 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
647 -- the 'compat' version of rawSystem under mingw32 always
648 -- maps 'errno' to EINVAL to failure.
649 || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
651 then return (ExitFailure 1, True)
653 case (doesn'tExist, exit_code) of
654 (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
655 (_, ExitSuccess) -> return ()
656 _ -> throwDyn (PhaseFailed phase_name exit_code)
660 #if __GLASGOW_HASKELL__ < 603
661 builderMainLoop dflags filter_fn pgm real_args = do
662 rawSystem pgm real_args
664 builderMainLoop dflags filter_fn pgm real_args = do
666 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing
668 -- and run a loop piping the output from the compiler to the log_action in DynFlags
669 hSetBuffering hStdOut LineBuffering
670 hSetBuffering hStdErr LineBuffering
671 forkIO (readerProc chan hStdOut filter_fn)
672 forkIO (readerProc chan hStdErr filter_fn)
673 rc <- loop chan hProcess 2 1 ExitSuccess
679 -- status starts at zero, and increments each time either
680 -- a reader process gets EOF, or the build proc exits. We wait
681 -- for all of these to happen (status==3).
682 -- ToDo: we should really have a contingency plan in case any of
683 -- the threads dies, such as a timeout.
684 loop chan hProcess 0 0 exitcode = return exitcode
685 loop chan hProcess t p exitcode = do
687 then getProcessExitCode hProcess
690 Just code -> loop chan hProcess t (p-1) code
696 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
697 loop chan hProcess t p exitcode
698 BuildError loc msg -> do
699 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
700 loop chan hProcess t p exitcode
702 loop chan hProcess (t-1) p exitcode
703 | otherwise -> loop chan hProcess t p exitcode
705 readerProc chan hdl filter_fn =
706 (do str <- hGetContents hdl
707 loop (linesPlatform (filter_fn str)) Nothing)
710 -- ToDo: check errors more carefully
711 -- ToDo: in the future, the filter should be implemented as
712 -- a stream transformer.
714 loop [] Nothing = return ()
715 loop [] (Just err) = writeChan chan err
718 Just err@(BuildError srcLoc msg)
719 | leading_whitespace l -> do
720 loop ls (Just (BuildError srcLoc (msg $$ text l)))
728 = case matchRegex errRegex l of
730 writeChan chan (BuildMsg (text l))
732 Just (file':lineno':colno':msg:_) -> do
733 let file = mkFastString file'
734 lineno = read lineno'::Int
735 colno = case colno' of
737 _ -> read (init colno') :: Int
738 srcLoc = mkSrcLoc file lineno colno
739 loop ls (Just (BuildError srcLoc (text msg)))
741 leading_whitespace [] = False
742 leading_whitespace (x:_) = isSpace x
744 errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"
748 | BuildError !SrcLoc !SDoc
752 showOpt (FileOption pre f) = pre ++ platformPath f
753 showOpt (Option "") = ""
754 showOpt (Option s) = s
756 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
757 -- a) trace the command (at two levels of verbosity)
758 -- b) don't do it at all if dry-run is set
759 traceCmd dflags phase_name cmd_line action
760 = do { let verb = verbosity dflags
761 ; showPass dflags phase_name
762 ; debugTraceMsg dflags 3 (text cmd_line)
766 ; unless (dopt Opt_DryRun dflags) $ do {
769 ; action `IO.catch` handle_exn verb
772 handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
773 ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
774 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
777 %************************************************************************
779 \subsection{Support code}
781 %************************************************************************
784 -----------------------------------------------------------------------------
785 -- Define getBaseDir :: IO (Maybe String)
787 getBaseDir :: IO (Maybe String)
788 #if defined(mingw32_HOST_OS)
789 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
790 -- return the path $(stuff). Note that we drop the "bin/" directory too.
791 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
792 buf <- mallocArray len
793 ret <- getModuleFileName nullPtr buf len
794 if ret == 0 then free buf >> return Nothing
795 else do s <- peekCString buf
797 return (Just (rootDir s))
799 rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
801 foreign import stdcall unsafe "GetModuleFileNameA"
802 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
804 getBaseDir = return Nothing
807 #ifdef mingw32_HOST_OS
808 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
809 #elif __GLASGOW_HASKELL__ > 504
810 getProcessID :: IO Int
811 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
813 getProcessID :: IO Int
814 getProcessID = Posix.getProcessID
817 -- Divvy up text stream into lines, taking platform dependent
818 -- line termination into account.
819 linesPlatform :: String -> [String]
820 #if !defined(mingw32_HOST_OS)
821 linesPlatform ls = lines ls
823 linesPlatform "" = []
826 (as,xs1) -> as : linesPlatform xs1
828 lineBreak "" = ("","")
829 lineBreak ('\r':'\n':xs) = ([],xs)
830 lineBreak ('\n':xs) = ([],xs)
831 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)