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 ()
24 touch, -- String -> String -> IO ()
29 -- Temporary-file management
32 cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
39 #include "HsVersions.h"
54 import System.Environment
55 import System.FilePath
57 import System.IO.Error as IO
58 import System.Directory
62 #ifndef mingw32_HOST_OS
63 import qualified System.Posix.Internals
64 #else /* Must be Win32 */
66 import Foreign.C.String
69 import System.Process ( runInteractiveProcess, getProcessExitCode )
70 import Control.Concurrent
72 import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
75 How GHC finds its files
76 ~~~~~~~~~~~~~~~~~~~~~~~
80 GHC needs various support files (library packages, RTS etc), plus
81 various auxiliary programs (cp, gcc, etc). It starts by finding topdir,
82 the root of GHC's support files
85 - ghc always has a shell wrapper that passes a -B<dir> option
88 - ghc never has a shell wrapper.
89 - we can find the location of the ghc binary, which is
90 $topdir/bin/<something>.exe
91 where <something> may be "ghc", "ghc-stage2", or similar
92 - we strip off the "bin/<something>.exe" to leave $topdir.
94 from topdir we can find package.conf, ghc-asm, etc.
97 SysTools.initSysProgs figures out exactly where all the auxiliary programs
98 are, and initialises mutable variables to make it easy to call them.
99 To to this, it makes use of definitions in Config.hs, which is a Haskell
100 file containing variables whose value is figured out by the build system.
102 Config.hs contains two sorts of things
104 cGCC, The *names* of the programs
107 etc They do *not* include paths
110 cUNLIT_DIR The *path* to the directory containing unlit, split etc
111 cSPLIT_DIR *relative* to the root of the build tree,
112 for use when running *in-place* in a build tree (only)
116 ---------------------------------------------
117 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
119 Another hair-brained scheme for simplifying the current tool location
120 nightmare in GHC: Simon originally suggested using another
121 configuration file along the lines of GCC's specs file - which is fine
122 except that it means adding code to read yet another configuration
123 file. What I didn't notice is that the current package.conf is
124 general enough to do this:
127 {name = "tools", import_dirs = [], source_dirs = [],
128 library_dirs = [], hs_libraries = [], extra_libraries = [],
129 include_dirs = [], c_includes = [], package_deps = [],
130 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
131 extra_cc_opts = [], extra_ld_opts = []}
133 Which would have the advantage that we get to collect together in one
134 place the path-specific package stuff with the path-specific tool
137 ---------------------------------------------
139 %************************************************************************
141 \subsection{Initialisation}
143 %************************************************************************
146 initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
149 -> IO DynFlags -- Set all the mutable variables above, holding
150 -- (a) the system programs
151 -- (b) the package-config file
152 -- (c) the GHC usage message
155 initSysTools mbMinusB dflags0
156 = do { top_dir <- findTopDir mbMinusB
158 -- NB: top_dir is assumed to be in standard Unix
159 -- format, '/' separated
161 ; let installed :: FilePath -> FilePath
162 installed file = top_dir </> file
163 installed_mingw_bin file = top_dir </> ".." </> "mingw" </> "bin" </> file
164 installed_perl_bin file = top_dir </> ".." </> "perl" </> file
166 ; let pkgconfig_path = installed "package.conf.d"
167 ghc_usage_msg_path = installed "ghc-usage.txt"
168 ghci_usage_msg_path = installed "ghci-usage.txt"
170 -- For all systems, unlit, split, mangle are GHC utilities
171 -- architecture-specific stuff is done when building Config.hs
172 unlit_path = installed cGHC_UNLIT_PGM
174 -- split and mangle are Perl scripts
175 split_script = installed cGHC_SPLIT_PGM
176 mangle_script = installed cGHC_MANGLER_PGM
178 windres_path = installed_mingw_bin "windres"
180 ; tmpdir <- getTemporaryDirectory
181 ; let dflags1 = setTmpDir tmpdir dflags0
183 -- On Windows, mingw is distributed with GHC,
184 -- so we look in TopDir/../mingw/bin
187 | isWindowsHost = installed_mingw_bin "gcc"
190 | isWindowsHost = installed_perl_bin cGHC_PERL
191 | otherwise = cGHC_PERL
192 -- 'touch' is a GHC util for Windows
194 | isWindowsHost = installed cGHC_TOUCHY_PGM
195 | otherwise = "touch"
196 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
197 -- a call to Perl to get the invocation of split and mangle.
198 -- On Unix, scripts are invoked using the '#!' method. Binary
199 -- installations of GHC on Unix place the correct line on the
200 -- front of the script at installation time, so we don't want
201 -- to wire-in our knowledge of $(PERL) on the host system here.
202 (split_prog, split_args)
203 | isWindowsHost = (perl_path, [Option split_script])
204 | otherwise = (split_script, [])
205 (mangle_prog, mangle_args)
206 | isWindowsHost = (perl_path, [Option mangle_script])
207 | otherwise = (mangle_script, [])
208 (mkdll_prog, mkdll_args)
210 = panic "Can't build DLLs on a non-Win32 system"
212 (installed_mingw_bin cMKDLL, [])
214 -- cpp is derived from gcc on all platforms
215 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
216 -- Config.hs one day.
217 ; let cpp_path = (gcc_prog,
218 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
220 -- Other things being equal, as and ld are simply gcc
221 ; let as_prog = gcc_prog
224 -- figure out llvm location. (TODO: Acutally implement).
225 ; let lc_prog = "llc"
229 ghcUsagePath = ghc_usage_msg_path,
230 ghciUsagePath = ghci_usage_msg_path,
232 systemPackageConfig = pkgconfig_path,
236 pgm_c = (gcc_prog,[]),
237 pgm_m = (mangle_prog,mangle_args),
238 pgm_s = (split_prog,split_args),
239 pgm_a = (as_prog,[]),
240 pgm_l = (ld_prog,[]),
241 pgm_dll = (mkdll_prog,mkdll_args),
243 pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
244 pgm_windres = windres_path,
245 pgm_lo = (lo_prog,[]),
246 pgm_lc = (lc_prog,[])
247 -- Hans: this isn't right in general, but you can
248 -- elaborate it in the same way as the others
254 -- returns a Unix-format path (relying on getBaseDir to do so too)
255 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
256 -> IO String -- TopDir (in Unix format '/' separated)
257 findTopDir (Just minusb) = return (normalise minusb)
259 = do -- Get directory of executable
260 maybe_exec_dir <- getBaseDir
261 case maybe_exec_dir of
262 -- "Just" on Windows, "Nothing" on unix
263 Nothing -> ghcError (InstallationError "missing -B<dir> option")
264 Just dir -> return dir
268 %************************************************************************
270 \subsection{Running an external program}
272 %************************************************************************
276 runUnlit :: DynFlags -> [Option] -> IO ()
277 runUnlit dflags args = do
279 runSomething dflags "Literate pre-processor" p args
281 runCpp :: DynFlags -> [Option] -> IO ()
282 runCpp dflags args = do
283 let (p,args0) = pgm_P dflags
284 args1 = args0 ++ args
285 args2 = if dopt Opt_WarnIsError dflags
286 then Option "-Werror" : args1
288 mb_env <- getGccEnv args2
289 runSomethingFiltered dflags id "C pre-processor" p args2 mb_env
291 runPp :: DynFlags -> [Option] -> IO ()
292 runPp dflags args = do
294 runSomething dflags "Haskell pre-processor" p args
296 runCc :: DynFlags -> [Option] -> IO ()
297 runCc dflags args = do
298 let (p,args0) = pgm_c dflags
299 args1 = args0 ++ args
300 mb_env <- getGccEnv args1
301 runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
303 -- discard some harmless warnings from gcc that we can't turn off
304 cc_filter = unlines . doFilter . lines
307 gcc gives warnings in chunks like so:
308 In file included from /foo/bar/baz.h:11,
309 from /foo/bar/baz2.h:22,
311 /foo/flibble:14: global register variable ...
312 /foo/flibble:15: warning: call-clobbered r...
313 We break it up into its chunks, remove any call-clobbered register
314 warnings from each chunk, and then delete any chunks that we have
317 doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
318 -- We can't assume that the output will start with an "In file inc..."
319 -- line, so we start off expecting a list of warnings rather than a
321 chunkWarnings :: [String] -- The location stack to use for the next
323 -> [String] -- The remaining lines to look at
324 -> [([String], [String])]
325 chunkWarnings loc_stack [] = [(loc_stack, [])]
326 chunkWarnings loc_stack xs
327 = case break loc_stack_start xs of
328 (warnings, lss:xs') ->
329 case span loc_start_continuation xs' of
331 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
332 _ -> [(loc_stack, xs)]
334 filterWarnings :: [([String], [String])] -> [([String], [String])]
335 filterWarnings [] = []
336 -- If the warnings are already empty then we are probably doing
337 -- something wrong, so don't delete anything
338 filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
339 filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
340 [] -> filterWarnings zs
341 ys' -> (xs, ys') : filterWarnings zs
343 unChunkWarnings :: [([String], [String])] -> [String]
344 unChunkWarnings [] = []
345 unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
347 loc_stack_start s = "In file included from " `isPrefixOf` s
348 loc_start_continuation s = " from " `isPrefixOf` s
350 | "warning: call-clobbered register used" `isContainedIn` w = False
353 isContainedIn :: String -> String -> Bool
354 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
356 -- If the -B<dir> option is set, add <dir> to PATH. This works around
357 -- a bug in gcc on Windows Vista where it can't find its auxiliary
358 -- binaries (see bug #1110).
359 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
363 else do env <- getEnvironment
364 return (Just (map mangle_path env))
366 (b_dirs, _) = partitionWith get_b_opt opts
368 get_b_opt (Option ('-':'B':dir)) = Left dir
369 get_b_opt other = Right other
371 mangle_path (path,paths) | map toUpper path == "PATH"
372 = (path, '\"' : head b_dirs ++ "\";" ++ paths)
373 mangle_path other = other
375 runMangle :: DynFlags -> [Option] -> IO ()
376 runMangle dflags args = do
377 let (p,args0) = pgm_m dflags
378 runSomething dflags "Mangler" p (args0++args)
380 runSplit :: DynFlags -> [Option] -> IO ()
381 runSplit dflags args = do
382 let (p,args0) = pgm_s dflags
383 runSomething dflags "Splitter" p (args0++args)
385 runAs :: DynFlags -> [Option] -> IO ()
386 runAs dflags args = do
387 let (p,args0) = pgm_a dflags
388 args1 = args0 ++ args
389 mb_env <- getGccEnv args1
390 runSomethingFiltered dflags id "Assembler" p args1 mb_env
392 runLlvmOpt :: DynFlags -> [Option] -> IO ()
393 runLlvmOpt dflags args = do
394 let (p,args0) = pgm_lo dflags
395 runSomething dflags "LLVM Optimiser" p (args0++args)
397 runLlvmLlc :: DynFlags -> [Option] -> IO ()
398 runLlvmLlc dflags args = do
399 let (p,args0) = pgm_lc dflags
400 runSomething dflags "LLVM Compiler" p (args0++args)
402 runLink :: DynFlags -> [Option] -> IO ()
403 runLink dflags args = do
404 let (p,args0) = pgm_l dflags
405 args1 = args0 ++ args
406 mb_env <- getGccEnv args1
407 runSomethingFiltered dflags id "Linker" p args1 mb_env
409 runMkDLL :: DynFlags -> [Option] -> IO ()
410 runMkDLL dflags args = do
411 let (p,args0) = pgm_dll dflags
412 args1 = args0 ++ args
413 mb_env <- getGccEnv (args0++args)
414 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
416 runWindres :: DynFlags -> [Option] -> IO ()
417 runWindres dflags args = do
418 let (gcc, gcc_args) = pgm_c dflags
419 windres = pgm_windres dflags
420 quote x = "\"" ++ x ++ "\""
421 args' = -- If windres.exe and gcc.exe are in a directory containing
422 -- spaces then windres fails to run gcc. We therefore need
423 -- to tell it what command to use...
424 Option ("--preprocessor=" ++
425 unwords (map quote (gcc :
426 map showOpt gcc_args ++
427 ["-E", "-xc", "-DRC_INVOKED"])))
428 -- ...but if we do that then if windres calls popen then
429 -- it can't understand the quoting, so we have to use
430 -- --use-temp-file so that it interprets it correctly.
432 : Option "--use-temp-file"
434 mb_env <- getGccEnv gcc_args
435 runSomethingFiltered dflags id "Windres" windres args' mb_env
437 touch :: DynFlags -> String -> String -> IO ()
438 touch dflags purpose arg =
439 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
441 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
442 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
444 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
446 copyWithHeader dflags purpose maybe_header from to = do
447 showPass dflags purpose
449 hout <- openBinaryFile to WriteMode
450 hin <- openBinaryFile from ReadMode
451 ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
452 maybe (return ()) (hPutStr hout) maybe_header
457 getExtraViaCOpts :: DynFlags -> IO [String]
458 getExtraViaCOpts dflags = do
459 f <- readFile (topDir dflags </> "extra-gcc-opts")
463 %************************************************************************
465 \subsection{Managing temporary files
467 %************************************************************************
470 cleanTempDirs :: DynFlags -> IO ()
472 = unless (dopt Opt_KeepTmpFiles dflags)
473 $ do let ref = dirsToClean dflags
475 removeTmpDirs dflags (eltsFM ds)
476 writeIORef ref emptyFM
478 cleanTempFiles :: DynFlags -> IO ()
479 cleanTempFiles dflags
480 = unless (dopt Opt_KeepTmpFiles dflags)
481 $ do let ref = filesToClean dflags
483 removeTmpFiles dflags fs
486 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
487 cleanTempFilesExcept dflags dont_delete
488 = unless (dopt Opt_KeepTmpFiles dflags)
489 $ do let ref = filesToClean dflags
490 files <- readIORef ref
491 let (to_keep, to_delete) = partition (`elem` dont_delete) files
492 removeTmpFiles dflags to_delete
493 writeIORef ref to_keep
496 -- find a temporary name that doesn't already exist.
497 newTempName :: DynFlags -> Suffix -> IO FilePath
498 newTempName dflags extn
499 = do d <- getTempDir dflags
501 findTempName (d </> "ghc" ++ show x ++ "_") 0
503 findTempName :: FilePath -> Integer -> IO FilePath
504 findTempName prefix x
505 = do let filename = (prefix ++ show x) <.> extn
506 b <- doesFileExist filename
507 if b then findTempName prefix (x+1)
508 else do -- clean it up later
509 consIORef (filesToClean dflags) filename
512 -- return our temporary directory within tmp_dir, creating one if we
513 -- don't have one yet
514 getTempDir :: DynFlags -> IO FilePath
515 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
516 = do let ref = dirsToClean dflags
517 mapping <- readIORef ref
518 case lookupFM mapping tmp_dir of
521 let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
523 mkTempDir :: Integer -> IO FilePath
525 = let dirname = prefix ++ show x
526 in do createDirectory dirname
527 let mapping' = addToFM mapping tmp_dir dirname
528 writeIORef ref mapping'
529 debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
532 if isAlreadyExistsError e
538 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
539 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
540 addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
542 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
543 removeTmpDirs dflags ds
544 = traceCmd dflags "Deleting temp dirs"
545 ("Deleting: " ++ unwords ds)
546 (mapM_ (removeWith dflags removeDirectory) ds)
548 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
549 removeTmpFiles dflags fs
551 traceCmd dflags "Deleting temp files"
552 ("Deleting: " ++ unwords deletees)
553 (mapM_ (removeWith dflags removeFile) deletees)
555 -- Flat out refuse to delete files that are likely to be source input
556 -- files (is there a worse bug than having a compiler delete your source
559 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
562 | null non_deletees = act
564 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
567 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
569 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
570 removeWith dflags remover f = remover f `IO.catch`
572 let msg = if isDoesNotExistError e
573 then ptext (sLit "Warning: deleting non-existent") <+> text f
574 else ptext (sLit "Warning: exception raised when deleting")
577 in debugTraceMsg dflags 2 msg
580 -----------------------------------------------------------------------------
581 -- Running an external program
583 runSomething :: DynFlags
584 -> String -- For -v message
585 -> String -- Command name (possibly a full path)
586 -- assumed already dos-ified
587 -> [Option] -- Arguments
588 -- runSomething will dos-ify them
591 runSomething dflags phase_name pgm args =
592 runSomethingFiltered dflags id phase_name pgm args Nothing
595 :: DynFlags -> (String->String) -> String -> String -> [Option]
596 -> Maybe [(String,String)] -> IO ()
598 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
599 let real_args = filter notNull (map showOpt args)
600 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
601 (exit_code, doesn'tExist) <-
603 rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
605 ExitSuccess{} -> return (rc, False)
607 -- rawSystem returns (ExitFailure 127) if the exec failed for any
608 -- reason (eg. the program doesn't exist). This is the only clue
609 -- we have, but we need to report something to the user because in
610 -- the case of a missing program there will otherwise be no output
612 | n == 127 -> return (rc, True)
613 | otherwise -> return (rc, False))
614 -- Should 'rawSystem' generate an IO exception indicating that
615 -- 'pgm' couldn't be run rather than a funky return code, catch
616 -- this here (the win32 version does this, but it doesn't hurt
617 -- to test for this in general.)
619 if IO.isDoesNotExistError err
620 then return (ExitFailure 1, True)
622 case (doesn'tExist, exit_code) of
623 (True, _) -> ghcError (InstallationError ("could not execute: " ++ pgm))
624 (_, ExitSuccess) -> return ()
625 _ -> ghcError (PhaseFailed phase_name exit_code)
627 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
628 -> [String] -> Maybe [(String, String)]
630 builderMainLoop dflags filter_fn pgm real_args mb_env = do
632 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
634 -- and run a loop piping the output from the compiler to the log_action in DynFlags
635 hSetBuffering hStdOut LineBuffering
636 hSetBuffering hStdErr LineBuffering
637 _ <- forkIO (readerProc chan hStdOut filter_fn)
638 _ <- forkIO (readerProc chan hStdErr filter_fn)
639 -- we don't want to finish until 2 streams have been completed
640 -- (stdout and stderr)
641 -- nor until 1 exit code has been retrieved.
642 rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
643 -- after that, we're done here.
649 -- status starts at zero, and increments each time either
650 -- a reader process gets EOF, or the build proc exits. We wait
651 -- for all of these to happen (status==3).
652 -- ToDo: we should really have a contingency plan in case any of
653 -- the threads dies, such as a timeout.
654 loop _ _ 0 0 exitcode = return exitcode
655 loop chan hProcess t p exitcode = do
657 then getProcessExitCode hProcess
660 Just code -> loop chan hProcess t (p-1) code
666 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
667 loop chan hProcess t p exitcode
668 BuildError loc msg -> do
669 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
670 loop chan hProcess t p exitcode
672 loop chan hProcess (t-1) p exitcode
673 | otherwise -> loop chan hProcess t p exitcode
675 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
676 readerProc chan hdl filter_fn =
677 (do str <- hGetContents hdl
678 loop (linesPlatform (filter_fn str)) Nothing)
681 -- ToDo: check errors more carefully
682 -- ToDo: in the future, the filter should be implemented as
683 -- a stream transformer.
685 loop [] Nothing = return ()
686 loop [] (Just err) = writeChan chan err
689 Just err@(BuildError srcLoc msg)
690 | leading_whitespace l -> do
691 loop ls (Just (BuildError srcLoc (msg $$ text l)))
697 _ -> panic "readerProc/loop"
700 = case parseError l of
702 writeChan chan (BuildMsg (text l))
704 Just (file, lineNum, colNum, msg) -> do
705 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
706 loop ls (Just (BuildError srcLoc (text msg)))
708 leading_whitespace [] = False
709 leading_whitespace (x:_) = isSpace x
711 parseError :: String -> Maybe (String, Int, Int, String)
712 parseError s0 = case breakColon s0 of
713 Just (filename, s1) ->
714 case breakIntColon s1 of
715 Just (lineNum, s2) ->
716 case breakIntColon s2 of
717 Just (columnNum, s3) ->
718 Just (filename, lineNum, columnNum, s3)
720 Just (filename, lineNum, 0, s2)
724 breakColon :: String -> Maybe (String, String)
725 breakColon xs = case break (':' ==) xs of
726 (ys, _:zs) -> Just (ys, zs)
729 breakIntColon :: String -> Maybe (Int, String)
730 breakIntColon xs = case break (':' ==) xs of
732 | not (null ys) && all isAscii ys && all isDigit ys ->
738 | BuildError !SrcLoc !SDoc
741 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
742 -- a) trace the command (at two levels of verbosity)
743 -- b) don't do it at all if dry-run is set
744 traceCmd dflags phase_name cmd_line action
745 = do { let verb = verbosity dflags
746 ; showPass dflags phase_name
747 ; debugTraceMsg dflags 3 (text cmd_line)
751 ; unless (dopt Opt_DryRun dflags) $ do {
754 ; action `IO.catch` handle_exn verb
757 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
758 ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
759 ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
762 %************************************************************************
764 \subsection{Support code}
766 %************************************************************************
769 -----------------------------------------------------------------------------
770 -- Define getBaseDir :: IO (Maybe String)
772 getBaseDir :: IO (Maybe String)
773 #if defined(mingw32_HOST_OS)
774 -- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe,
775 -- return the path $(stuff)/lib.
776 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
777 buf <- mallocArray len
778 ret <- getModuleFileName nullPtr buf len
779 if ret == 0 then free buf >> return Nothing
780 else do s <- peekCString buf
782 return (Just (rootDir s))
784 rootDir s = case splitFileName $ normalise s of
786 | lower ghc_exe `elem` ["ghc.exe",
790 case splitFileName $ takeDirectory d of
791 -- ghc is in $topdir/bin/ghc.exe
792 (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
795 where fail = panic ("can't decompose ghc.exe path: " ++ show 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
807 getProcessID :: IO Int
808 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
811 -- Divvy up text stream into lines, taking platform dependent
812 -- line termination into account.
813 linesPlatform :: String -> [String]
814 #if !defined(mingw32_HOST_OS)
815 linesPlatform ls = lines ls
817 linesPlatform "" = []
820 (as,xs1) -> as : linesPlatform xs1
822 lineBreak "" = ("","")
823 lineBreak ('\r':'\n':xs) = ([],xs)
824 lineBreak ('\n':xs) = ([],xs)
825 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)