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 )
58 import DATA_IOREF ( IORef, readIORef, writeIORef )
61 import Monad ( when, unless )
62 import System ( ExitCode(..), getEnv, system )
63 import IO ( try, catch,
64 openFile, hPutStr, hClose, hFlush, IOMode(..),
65 stderr, ioError, isDoesNotExistError )
66 import Directory ( doesFileExist, removeFile )
67 import List ( partition )
69 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
70 -- lines on mingw32, so we disallow it now.
71 #if __GLASGOW_HASKELL__ < 500
72 #error GHC >= 5.00 is required for bootstrapping GHC
75 #ifndef mingw32_HOST_OS
76 #if __GLASGOW_HASKELL__ > 504
77 import qualified System.Posix.Internals
79 import qualified Posix
81 #else /* Must be Win32 */
82 import List ( isPrefixOf )
83 import Util ( dropList )
85 import CString ( CString, peekCString )
88 #if __GLASGOW_HASKELL__ < 603
89 -- rawSystem comes from libghccompat.a in stage1
90 import Compat.RawSystem ( rawSystem )
91 import GHC.IOBase ( IOErrorType(..) )
92 import System.IO.Error ( ioeGetErrorType )
94 import System.Process ( runInteractiveProcess, getProcessExitCode )
95 import System.IO ( hSetBuffering, hGetLine, BufferMode(..) )
96 import Control.Concurrent( forkIO, newChan, readChan, writeChan )
98 import Data.Char ( isSpace )
99 import FastString ( mkFastString )
100 import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
105 The configuration story
106 ~~~~~~~~~~~~~~~~~~~~~~~
108 GHC needs various support files (library packages, RTS etc), plus
109 various auxiliary programs (cp, gcc, etc). It finds these in one
112 * When running as an *installed program*, GHC finds most of this support
113 stuff in the installed library tree. The path to this tree is passed
114 to GHC via the -B flag, and given to initSysTools .
116 * When running *in-place* in a build tree, GHC finds most of this support
117 stuff in the build tree. The path to the build tree is, again passed
120 GHC tells which of the two is the case by seeing whether package.conf
121 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
124 SysTools.initSysProgs figures out exactly where all the auxiliary programs
125 are, and initialises mutable variables to make it easy to call them.
126 To to this, it makes use of definitions in Config.hs, which is a Haskell
127 file containing variables whose value is figured out by the build system.
129 Config.hs contains two sorts of things
131 cGCC, The *names* of the programs
134 etc They do *not* include paths
137 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
138 cSPLIT_DIR_REL *relative* to the root of the build tree,
139 for use when running *in-place* in a build tree (only)
143 ---------------------------------------------
144 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
146 Another hair-brained scheme for simplifying the current tool location
147 nightmare in GHC: Simon originally suggested using another
148 configuration file along the lines of GCC's specs file - which is fine
149 except that it means adding code to read yet another configuration
150 file. What I didn't notice is that the current package.conf is
151 general enough to do this:
154 {name = "tools", import_dirs = [], source_dirs = [],
155 library_dirs = [], hs_libraries = [], extra_libraries = [],
156 include_dirs = [], c_includes = [], package_deps = [],
157 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
158 extra_cc_opts = [], extra_ld_opts = []}
160 Which would have the advantage that we get to collect together in one
161 place the path-specific package stuff with the path-specific tool
164 ---------------------------------------------
167 %************************************************************************
169 \subsection{Global variables to contain system programs}
171 %************************************************************************
173 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
174 (See remarks under pathnames below)
177 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
178 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
180 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
181 GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String))
183 GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
185 -- Parallel system only
186 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
188 -- ways to get at some of these variables from outside this module
189 getPackageConfigPath = readIORef v_Path_package_config
190 getTopDir = readIORef v_TopDir
194 %************************************************************************
196 \subsection{Initialisation}
198 %************************************************************************
201 initSysTools :: [String] -- Command-line arguments starting "-B"
204 -> IO DynFlags -- Set all the mutable variables above, holding
205 -- (a) the system programs
206 -- (b) the package-config file
207 -- (c) the GHC usage message
210 initSysTools minusB_args dflags
211 = do { (am_installed, top_dir) <- findTopDir minusB_args
212 ; writeIORef v_TopDir top_dir
214 -- for "installed" this is the root of GHC's support files
215 -- for "in-place" it is the root of the build tree
216 -- NB: top_dir is assumed to be in standard Unix format '/' separated
218 ; let installed, installed_bin :: FilePath -> FilePath
219 installed_bin pgm = pgmPath top_dir pgm
220 installed file = pgmPath top_dir file
221 inplace dir pgm = pgmPath (top_dir `joinFileName`
222 cPROJECT_DIR `joinFileName` dir) pgm
225 | am_installed = installed "package.conf"
226 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
229 | am_installed = installed "ghc-usage.txt"
230 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
233 | am_installed = installed "ghci-usage.txt"
234 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
236 -- For all systems, unlit, split, mangle are GHC utilities
237 -- architecture-specific stuff is done when building Config.hs
239 | am_installed = installed_bin cGHC_UNLIT_PGM
240 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
242 -- split and mangle are Perl scripts
244 | am_installed = installed_bin cGHC_SPLIT_PGM
245 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
248 | am_installed = installed_bin cGHC_MANGLER_PGM
249 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
251 ; let dflags0 = defaultDynFlags
252 #ifndef mingw32_HOST_OS
253 -- check whether TMPDIR is set in the environment
254 ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
256 -- On Win32, consult GetTempPath() for a temp dir.
257 -- => it first tries TMP, TEMP, then finally the
258 -- Windows directory(!). The directory is in short-path
262 let len = (2048::Int)
263 buf <- mallocArray len
264 ret <- getTempPath len buf
266 -- failed, consult TMPDIR.
274 ; let dflags1 = case e_tmpdir of
276 Right d -> setTmpDir d dflags0
278 -- Check that the package config exists
279 ; config_exists <- doesFileExist pkgconfig_path
280 ; when (not config_exists) $
281 throwDyn (InstallationError
282 ("Can't find package.conf as " ++ pkgconfig_path))
284 #if defined(mingw32_HOST_OS)
285 -- WINDOWS-SPECIFIC STUFF
286 -- On Windows, gcc and friends are distributed with GHC,
287 -- so when "installed" we look in TopDir/bin
288 -- When "in-place" we look wherever the build-time configure
290 -- When "install" we tell gcc where its specs file + exes are (-B)
291 -- and also some places to pick up include files. We need
292 -- to be careful to put all necessary exes in the -B place
293 -- (as, ld, cc1, etc) since if they don't get found there, gcc
294 -- then tries to run unadorned "as", "ld", etc, and will
295 -- pick up whatever happens to be lying around in the path,
296 -- possibly including those from a cygwin install on the target,
297 -- which is exactly what we're trying to avoid.
298 ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
300 | am_installed = (installed_bin "gcc", [gcc_b_arg])
301 | otherwise = (cGCC, [])
302 -- The trailing "/" is absolutely essential; gcc seems
303 -- to construct file names simply by concatenating to
304 -- this -B path with no extra slash We use "/" rather
305 -- than "\\" because otherwise "\\\" is mangled
306 -- later on; although gcc_args are in NATIVE format,
308 -- (see comments with declarations of global variables)
310 -- The quotes round the -B argument are in case TopDir
313 perl_path | am_installed = installed_bin cGHC_PERL
314 | otherwise = cGHC_PERL
316 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
317 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
318 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
320 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
321 -- a call to Perl to get the invocation of split and mangle
322 ; let (split_prog, split_args) = (perl_path, [Option split_script])
323 (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
325 ; let (mkdll_prog, mkdll_args)
327 (pgmPath (installed "gcc-lib/") cMKDLL,
328 [ Option "--dlltool-name",
329 Option (pgmPath (installed "gcc-lib/") "dlltool"),
330 Option "--driver-name",
331 Option gcc_prog, gcc_b_arg ])
332 | otherwise = (cMKDLL, [])
334 -- UNIX-SPECIFIC STUFF
335 -- On Unix, the "standard" tools are assumed to be
336 -- in the same place whether we are running "in-place" or "installed"
337 -- That place is wherever the build-time configure script found them.
338 ; let gcc_prog = cGCC
341 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
344 -- On Unix, scripts are invoked using the '#!' method. Binary
345 -- installations of GHC on Unix place the correct line on the front
346 -- of the script at installation time, so we don't want to wire-in
347 -- our knowledge of $(PERL) on the host system here.
348 ; let (split_prog, split_args) = (split_script, [])
349 (mangle_prog, mangle_args) = (mangle_script, [])
352 -- cpp is derived from gcc on all platforms
353 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
354 -- Config.hs one day.
355 ; let cpp_path = (gcc_prog, gcc_args ++
356 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
358 -- For all systems, copy and remove are provided by the host
359 -- system; architecture-specific stuff is done when building Config.hs
360 ; let cp_path = cGHC_CP
362 -- Other things being equal, as and ld are simply gcc
363 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
364 (ld_prog,ld_args) = (gcc_prog,gcc_args)
366 -- Initialise the global vars
367 ; writeIORef v_Path_package_config pkgconfig_path
368 ; writeIORef v_Path_usages (ghc_usage_msg_path,
371 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
372 -- Hans: this isn't right in general, but you can
373 -- elaborate it in the same way as the others
375 ; writeIORef v_Pgm_T touch_path
376 ; writeIORef v_Pgm_CP cp_path
382 pgm_c = (gcc_prog,gcc_args),
383 pgm_m = (mangle_prog,mangle_args),
384 pgm_s = (split_prog,split_args),
385 pgm_a = (as_prog,as_args),
386 pgm_l = (ld_prog,ld_args),
387 pgm_dll = (mkdll_prog,mkdll_args) }
390 #if defined(mingw32_HOST_OS)
391 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
397 -- for "installed" this is the root of GHC's support files
398 -- for "in-place" it is the root of the build tree
401 -- 1. Set proto_top_dir
402 -- a) look for (the last) -B flag, and use it
403 -- b) if there are no -B flags, get the directory
404 -- where GHC is running (only on Windows)
406 -- 2. If package.conf exists in proto_top_dir, we are running
407 -- installed; and TopDir = proto_top_dir
409 -- 3. Otherwise we are running in-place, so
410 -- proto_top_dir will be /...stuff.../ghc/compiler
411 -- Set TopDir to /...stuff..., which is the root of the build tree
413 -- This is very gruesome indeed
415 findTopDir :: [String]
416 -> IO (Bool, -- True <=> am installed, False <=> in-place
417 String) -- TopDir (in Unix format '/' separated)
420 = do { top_dir <- get_proto
421 -- Discover whether we're running in a build tree or in an installation,
422 -- by looking for the package configuration file.
423 ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf")
425 ; return (am_installed, top_dir)
428 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
429 get_proto | notNull minusbs
430 = return (normalisePath (drop 2 (last minusbs))) -- 2 for "-B"
432 = do { maybe_exec_dir <- getBaseDir -- Get directory of executable
433 ; case maybe_exec_dir of -- (only works on Windows;
434 -- returns Nothing on Unix)
435 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
436 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 runSomething dflags "C Compiler" p (args0++args)
469 runMangle :: DynFlags -> [Option] -> IO ()
470 runMangle dflags args = do
471 let (p,args0) = pgm_m dflags
472 runSomething dflags "Mangler" p (args0++args)
474 runSplit :: DynFlags -> [Option] -> IO ()
475 runSplit dflags args = do
476 let (p,args0) = pgm_s dflags
477 runSomething dflags "Splitter" p (args0++args)
479 runAs :: DynFlags -> [Option] -> IO ()
480 runAs dflags args = do
481 let (p,args0) = pgm_a dflags
482 runSomething dflags "Assembler" p (args0++args)
484 runLink :: DynFlags -> [Option] -> IO ()
485 runLink dflags args = do
486 let (p,args0) = pgm_l dflags
487 runSomething dflags "Linker" p (args0++args)
489 runMkDLL :: DynFlags -> [Option] -> IO ()
490 runMkDLL dflags args = do
491 let (p,args0) = pgm_dll dflags
492 runSomething dflags "Make DLL" p (args0++args)
494 touch :: DynFlags -> String -> String -> IO ()
495 touch dflags purpose arg = do
496 p <- readIORef v_Pgm_T
497 runSomething dflags purpose p [FileOption "" arg]
499 copy :: DynFlags -> String -> String -> String -> IO ()
500 copy dflags purpose from to = do
501 showPass dflags purpose
503 h <- openFile to WriteMode
504 ls <- readFile from -- inefficient, but it'll do for now.
505 -- ToDo: speed up via slurping.
512 getSysMan :: IO String -- How to invoke the system manager
513 -- (parallel system only)
514 getSysMan = readIORef v_Pgm_sysman
518 getUsageMsgPaths :: IO (FilePath,FilePath)
519 -- the filenames of the usage messages (ghc, ghci)
520 getUsageMsgPaths = readIORef v_Path_usages
524 %************************************************************************
526 \subsection{Managing temporary files
528 %************************************************************************
531 GLOBAL_VAR(v_FilesToClean, [], [String] )
535 cleanTempFiles :: DynFlags -> IO ()
536 cleanTempFiles dflags
537 = do fs <- readIORef v_FilesToClean
538 removeTmpFiles dflags fs
539 writeIORef v_FilesToClean []
541 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
542 cleanTempFilesExcept dflags dont_delete
543 = do files <- readIORef v_FilesToClean
544 let (to_keep, to_delete) = partition (`elem` dont_delete) files
545 removeTmpFiles dflags to_delete
546 writeIORef v_FilesToClean to_keep
549 -- find a temporary name that doesn't already exist.
550 newTempName :: DynFlags -> Suffix -> IO FilePath
551 newTempName DynFlags{tmpDir=tmp_dir} extn
552 = do x <- getProcessID
553 findTempName (tmp_dir ++ "/ghc" ++ show x ++ "_") 0
555 findTempName prefix x
556 = do let filename = (prefix ++ show x) `joinFileExt` extn
557 b <- doesFileExist filename
558 if b then findTempName prefix (x+1)
559 else do consIORef v_FilesToClean filename -- clean it up later
562 addFilesToClean :: [FilePath] -> IO ()
563 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
564 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
566 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
567 removeTmpFiles dflags fs
569 traceCmd dflags "Deleting temp files"
570 ("Deleting: " ++ unwords deletees)
573 -- Flat out refuse to delete files that are likely to be source input
574 -- files (is there a worse bug than having a compiler delete your source
577 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
580 | null non_deletees = act
582 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
585 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
587 rm f = removeFile f `IO.catch`
589 debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
593 -----------------------------------------------------------------------------
594 -- Running an external program
596 runSomething :: DynFlags
597 -> String -- For -v message
598 -> String -- Command name (possibly a full path)
599 -- assumed already dos-ified
600 -> [Option] -- Arguments
601 -- runSomething will dos-ify them
604 runSomething dflags phase_name pgm args = do
605 let real_args = filter notNull (map showOpt args)
606 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
607 (exit_code, doesn'tExist) <-
609 rc <- builderMainLoop dflags pgm real_args
611 ExitSuccess{} -> return (rc, False)
613 -- rawSystem returns (ExitFailure 127) if the exec failed for any
614 -- reason (eg. the program doesn't exist). This is the only clue
615 -- we have, but we need to report something to the user because in
616 -- the case of a missing program there will otherwise be no output
618 | n == 127 -> return (rc, True)
619 | otherwise -> return (rc, False))
620 -- Should 'rawSystem' generate an IO exception indicating that
621 -- 'pgm' couldn't be run rather than a funky return code, catch
622 -- this here (the win32 version does this, but it doesn't hurt
623 -- to test for this in general.)
625 if IO.isDoesNotExistError err
626 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
627 -- the 'compat' version of rawSystem under mingw32 always
628 -- maps 'errno' to EINVAL to failure.
629 || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
631 then return (ExitFailure 1, True)
633 case (doesn'tExist, exit_code) of
634 (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
635 (_, ExitSuccess) -> return ()
636 _ -> throwDyn (PhaseFailed phase_name exit_code)
640 #if __GLASGOW_HASKELL__ < 603
641 builderMainLoop dflags pgm real_args = do
642 rawSystem pgm real_args
644 builderMainLoop dflags pgm real_args = do
646 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing
648 -- and run a loop piping the output from the compiler to the log_action in DynFlags
649 hSetBuffering hStdOut LineBuffering
650 hSetBuffering hStdErr LineBuffering
651 forkIO (readerProc chan hStdOut)
652 forkIO (readerProc chan hStdErr)
653 rc <- loop chan hProcess 2 1 ExitSuccess
659 -- status starts at zero, and increments each time either
660 -- a reader process gets EOF, or the build proc exits. We wait
661 -- for all of these to happen (status==3).
662 -- ToDo: we should really have a contingency plan in case any of
663 -- the threads dies, such as a timeout.
664 loop chan hProcess 0 0 exitcode = return exitcode
665 loop chan hProcess t p exitcode = do
667 then getProcessExitCode hProcess
670 Just code -> loop chan hProcess t (p-1) code
676 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
677 loop chan hProcess t p exitcode
678 BuildError loc msg -> do
679 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
680 loop chan hProcess t p exitcode
682 loop chan hProcess (t-1) p exitcode
683 | otherwise -> loop chan hProcess t p exitcode
685 readerProc chan hdl = loop Nothing `catch` \e -> writeChan chan EOF
686 -- ToDo: check errors more carefully
689 l <- hGetLine hdl `catch` \e -> do
691 Just err -> writeChan chan err
695 Just err@(BuildError srcLoc msg)
696 | leading_whitespace l -> do
697 loop (Just (BuildError srcLoc (msg $$ text l)))
705 = case matchRegex errRegex l of
707 writeChan chan (BuildMsg (text l))
709 Just (file':lineno':colno':msg:_) -> do
710 let file = mkFastString file'
711 lineno = read lineno'::Int
712 colno = case colno' of
714 _ -> read (init colno') :: Int
715 srcLoc = mkSrcLoc file lineno colno
716 loop (Just (BuildError srcLoc (text msg)))
718 leading_whitespace [] = False
719 leading_whitespace (x:_) = isSpace x
721 errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"
725 | BuildError !SrcLoc !SDoc
729 showOpt (FileOption pre f) = pre ++ platformPath f
730 showOpt (Option "") = ""
731 showOpt (Option s) = s
733 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
734 -- a) trace the command (at two levels of verbosity)
735 -- b) don't do it at all if dry-run is set
736 traceCmd dflags phase_name cmd_line action
737 = do { let verb = verbosity dflags
738 ; showPass dflags phase_name
739 ; debugTraceMsg dflags 3 (text cmd_line)
743 ; unless (dopt Opt_DryRun dflags) $ do {
746 ; action `IO.catch` handle_exn verb
749 handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
750 ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
751 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
754 %************************************************************************
756 \subsection{Support code}
758 %************************************************************************
761 -----------------------------------------------------------------------------
762 -- Define getBaseDir :: IO (Maybe String)
764 getBaseDir :: IO (Maybe String)
765 #if defined(mingw32_HOST_OS)
766 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
767 -- return the path $(stuff). Note that we drop the "bin/" directory too.
768 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
769 buf <- mallocArray len
770 ret <- getModuleFileName nullPtr buf len
771 if ret == 0 then free buf >> return Nothing
772 else do s <- peekCString buf
774 return (Just (rootDir s))
776 rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
778 foreign import stdcall unsafe "GetModuleFileNameA"
779 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
781 getBaseDir = return Nothing
784 #ifdef mingw32_HOST_OS
785 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
786 #elif __GLASGOW_HASKELL__ > 504
787 getProcessID :: IO Int
788 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
790 getProcessID :: IO Int
791 getProcessID = Posix.getProcessID