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"
53 import System.Environment
54 import System.FilePath
56 import System.IO.Error as IO
57 import System.Directory
60 import qualified Data.Map as Map
62 #ifndef mingw32_HOST_OS
63 import qualified System.Posix.Internals
64 #else /* Must be Win32 */
66 import Foreign.C.String
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 (Map.elems ds)
476 writeIORef ref Map.empty
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 Map.lookup tmp_dir mapping 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' = Map.insert tmp_dir dirname mapping
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 `catchIO`
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 #if __GLASGOW_HASKELL__ >= 701
601 cmdLine = showCommandForUser pgm real_args
603 cmdLine = unwords (pgm:real_args)
605 traceCmd dflags phase_name cmdLine $ do
606 (exit_code, doesn'tExist) <-
608 rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
610 ExitSuccess{} -> return (rc, False)
612 -- rawSystem returns (ExitFailure 127) if the exec failed for any
613 -- reason (eg. the program doesn't exist). This is the only clue
614 -- we have, but we need to report something to the user because in
615 -- the case of a missing program there will otherwise be no output
617 | n == 127 -> return (rc, True)
618 | otherwise -> return (rc, False))
619 -- Should 'rawSystem' generate an IO exception indicating that
620 -- 'pgm' couldn't be run rather than a funky return code, catch
621 -- this here (the win32 version does this, but it doesn't hurt
622 -- to test for this in general.)
624 if IO.isDoesNotExistError err
625 then return (ExitFailure 1, True)
627 case (doesn'tExist, exit_code) of
628 (True, _) -> ghcError (InstallationError ("could not execute: " ++ pgm))
629 (_, ExitSuccess) -> return ()
630 _ -> ghcError (PhaseFailed phase_name exit_code)
632 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
633 -> [String] -> Maybe [(String, String)]
635 builderMainLoop dflags filter_fn pgm real_args mb_env = do
637 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
639 -- and run a loop piping the output from the compiler to the log_action in DynFlags
640 hSetBuffering hStdOut LineBuffering
641 hSetBuffering hStdErr LineBuffering
642 _ <- forkIO (readerProc chan hStdOut filter_fn)
643 _ <- forkIO (readerProc chan hStdErr filter_fn)
644 -- we don't want to finish until 2 streams have been completed
645 -- (stdout and stderr)
646 -- nor until 1 exit code has been retrieved.
647 rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
648 -- after that, we're done here.
654 -- status starts at zero, and increments each time either
655 -- a reader process gets EOF, or the build proc exits. We wait
656 -- for all of these to happen (status==3).
657 -- ToDo: we should really have a contingency plan in case any of
658 -- the threads dies, such as a timeout.
659 loop _ _ 0 0 exitcode = return exitcode
660 loop chan hProcess t p exitcode = do
662 then getProcessExitCode hProcess
665 Just code -> loop chan hProcess t (p-1) code
671 log_action dflags SevInfo noSrcSpan defaultUserStyle msg
672 loop chan hProcess t p exitcode
673 BuildError loc msg -> do
674 log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
675 loop chan hProcess t p exitcode
677 loop chan hProcess (t-1) p exitcode
678 | otherwise -> loop chan hProcess t p exitcode
680 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
681 readerProc chan hdl filter_fn =
682 (do str <- hGetContents hdl
683 loop (linesPlatform (filter_fn str)) Nothing)
686 -- ToDo: check errors more carefully
687 -- ToDo: in the future, the filter should be implemented as
688 -- a stream transformer.
690 loop [] Nothing = return ()
691 loop [] (Just err) = writeChan chan err
694 Just err@(BuildError srcLoc msg)
695 | leading_whitespace l -> do
696 loop ls (Just (BuildError srcLoc (msg $$ text l)))
702 _ -> panic "readerProc/loop"
705 = case parseError l of
707 writeChan chan (BuildMsg (text l))
709 Just (file, lineNum, colNum, msg) -> do
710 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
711 loop ls (Just (BuildError srcLoc (text msg)))
713 leading_whitespace [] = False
714 leading_whitespace (x:_) = isSpace x
716 parseError :: String -> Maybe (String, Int, Int, String)
717 parseError s0 = case breakColon s0 of
718 Just (filename, s1) ->
719 case breakIntColon s1 of
720 Just (lineNum, s2) ->
721 case breakIntColon s2 of
722 Just (columnNum, s3) ->
723 Just (filename, lineNum, columnNum, s3)
725 Just (filename, lineNum, 0, s2)
729 breakColon :: String -> Maybe (String, String)
730 breakColon xs = case break (':' ==) xs of
731 (ys, _:zs) -> Just (ys, zs)
734 breakIntColon :: String -> Maybe (Int, String)
735 breakIntColon xs = case break (':' ==) xs of
737 | not (null ys) && all isAscii ys && all isDigit ys ->
743 | BuildError !SrcLoc !SDoc
746 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
747 -- a) trace the command (at two levels of verbosity)
748 -- b) don't do it at all if dry-run is set
749 traceCmd dflags phase_name cmd_line action
750 = do { let verb = verbosity dflags
751 ; showPass dflags phase_name
752 ; debugTraceMsg dflags 3 (text cmd_line)
756 ; unless (dopt Opt_DryRun dflags) $ do {
759 ; action `catchIO` handle_exn verb
762 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
763 ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
764 ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
767 %************************************************************************
769 \subsection{Support code}
771 %************************************************************************
774 -----------------------------------------------------------------------------
775 -- Define getBaseDir :: IO (Maybe String)
777 getBaseDir :: IO (Maybe String)
778 #if defined(mingw32_HOST_OS)
779 -- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe,
780 -- return the path $(stuff)/lib.
781 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
782 buf <- mallocArray len
783 ret <- getModuleFileName nullPtr buf len
784 if ret == 0 then free buf >> return Nothing
785 else do s <- peekCString buf
787 return (Just (rootDir s))
789 rootDir s = case splitFileName $ normalise s of
791 | lower ghc_exe `elem` ["ghc.exe",
795 case splitFileName $ takeDirectory d of
796 -- ghc is in $topdir/bin/ghc.exe
797 (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
800 where fail = panic ("can't decompose ghc.exe path: " ++ show s)
803 foreign import stdcall unsafe "GetModuleFileNameA"
804 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
806 getBaseDir = return Nothing
809 #ifdef mingw32_HOST_OS
810 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
812 getProcessID :: IO Int
813 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
816 -- Divvy up text stream into lines, taking platform dependent
817 -- line termination into account.
818 linesPlatform :: String -> [String]
819 #if !defined(mingw32_HOST_OS)
820 linesPlatform ls = lines ls
822 linesPlatform "" = []
825 (as,xs1) -> as : linesPlatform xs1
827 lineBreak "" = ("","")
828 lineBreak ('\r':'\n':xs) = ([],xs)
829 lineBreak ('\n':xs) = ([],xs)
830 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)