Replace uses of the old catch function with the new one
[ghc.git] / compiler / main / SysTools.lhs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2001-2003
4 --
5 -- Access to system tools: gcc, cp, rm etc
6 --
7 -----------------------------------------------------------------------------
8
9 \begin{code}
10 module SysTools (
11         -- Initialisation
12         initSysTools,
13
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 ()
19         runMkDLL,
20         runWindres,
21         runLlvmOpt,
22         runLlvmLlc,
23
24         touch,                  -- String -> String -> IO ()
25         copy,
26         copyWithHeader,
27         getExtraViaCOpts,
28
29         -- Temporary-file management
30         setTmpDir,
31         newTempName,
32         cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
33         addFilesToClean,
34
35         Option(..)
36
37  ) where
38
39 #include "HsVersions.h"
40
41 import DriverPhases
42 import Config
43 import Outputable
44 import ErrUtils
45 import Panic
46 import Util
47 import DynFlags
48 import Exception
49
50 import Data.IORef
51 import Control.Monad
52 import System.Exit
53 import System.Environment
54 import System.FilePath
55 import System.IO
56 import System.IO.Error as IO
57 import System.Directory
58 import Data.Char
59 import Data.List
60 import qualified Data.Map as Map
61
62 #ifndef mingw32_HOST_OS
63 import qualified System.Posix.Internals
64 #else /* Must be Win32 */
65 import Foreign
66 import Foreign.C.String
67 #endif
68
69 import System.Process
70 import Control.Concurrent
71 import FastString
72 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
73 \end{code}
74
75 How GHC finds its files
76 ~~~~~~~~~~~~~~~~~~~~~~~
77
78 [Note topdir]
79
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
83
84 On Unix:
85   - ghc always has a shell wrapper that passes a -B<dir> option
86
87 On Windows:
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.
93
94 from topdir we can find package.conf, ghc-asm, etc.
95
96
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.
101
102 Config.hs contains two sorts of things
103
104   cGCC,         The *names* of the programs
105   cCPP            e.g.  cGCC = gcc
106   cUNLIT                cCPP = gcc -E
107   etc           They do *not* include paths
108
109
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)
113
114
115
116 ---------------------------------------------
117 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
118
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:
125
126 Package
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 = []}
132
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
135 stuff.
136                 End of NOTES
137 ---------------------------------------------
138
139 %************************************************************************
140 %*                                                                      *
141 \subsection{Initialisation}
142 %*                                                                      *
143 %************************************************************************
144
145 \begin{code}
146 initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
147
148              -> DynFlags
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
153
154
155 initSysTools mbMinusB dflags0
156   = do  { top_dir <- findTopDir mbMinusB
157                 -- see [Note topdir]
158                 -- NB: top_dir is assumed to be in standard Unix
159                 -- format, '/' separated
160
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
165
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"
169
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
173
174                 -- split and mangle are Perl scripts
175               split_script  = installed cGHC_SPLIT_PGM
176               mangle_script = installed cGHC_MANGLER_PGM
177
178               windres_path  = installed_mingw_bin "windres"
179
180         ; tmpdir <- getTemporaryDirectory
181         ; let dflags1 = setTmpDir tmpdir dflags0
182
183         -- On Windows, mingw is distributed with GHC,
184         --      so we look in TopDir/../mingw/bin
185         ; let
186               gcc_prog
187                 | isWindowsHost = installed_mingw_bin "gcc"
188                 | otherwise     = cGCC
189               perl_path
190                 | isWindowsHost = installed_perl_bin cGHC_PERL
191                 | otherwise     = cGHC_PERL
192               -- 'touch' is a GHC util for Windows
193               touch_path
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)
209                 | not isWindowsHost
210                     = panic "Can't build DLLs on a non-Win32 system"
211                 | otherwise =
212                     (installed_mingw_bin cMKDLL, [])
213
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)))
219
220         -- Other things being equal, as and ld are simply gcc
221         ; let   as_prog  = gcc_prog
222                 ld_prog  = gcc_prog
223
224         -- figure out llvm location. (TODO: Acutally implement).
225         ; let lc_prog = "llc"
226               lo_prog = "opt"
227
228         ; return dflags1{
229                         ghcUsagePath = ghc_usage_msg_path,
230                         ghciUsagePath = ghci_usage_msg_path,
231                         topDir  = top_dir,
232                         systemPackageConfig = pkgconfig_path,
233                         pgm_L   = unlit_path,
234                         pgm_P   = cpp_path,
235                         pgm_F   = "",
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),
242                         pgm_T   = touch_path,
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
249                 }
250         }
251 \end{code}
252
253 \begin{code}
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)
258 findTopDir Nothing
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
265 \end{code}
266
267
268 %************************************************************************
269 %*                                                                      *
270 \subsection{Running an external program}
271 %*                                                                      *
272 %************************************************************************
273
274
275 \begin{code}
276 runUnlit :: DynFlags -> [Option] -> IO ()
277 runUnlit dflags args = do
278   let p = pgm_L dflags
279   runSomething dflags "Literate pre-processor" p args
280
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
287               else                    args1
288   mb_env <- getGccEnv args2
289   runSomethingFiltered dflags id  "C pre-processor" p args2 mb_env
290
291 runPp :: DynFlags -> [Option] -> IO ()
292 runPp dflags args =   do
293   let p = pgm_F dflags
294   runSomething dflags "Haskell pre-processor" p args
295
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
302  where
303   -- discard some harmless warnings from gcc that we can't turn off
304   cc_filter = unlines . doFilter . lines
305
306   {-
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,
310                        from wibble.c:33:
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
315   emptied of warnings.
316   -}
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
320   -- location stack.
321   chunkWarnings :: [String] -- The location stack to use for the next
322                             -- list of warnings
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
330             (lsc, xs'') ->
331                 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
332         _ -> [(loc_stack, xs)]
333
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
342
343   unChunkWarnings :: [([String], [String])] -> [String]
344   unChunkWarnings [] = []
345   unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
346
347   loc_stack_start        s = "In file included from " `isPrefixOf` s
348   loc_start_continuation s = "                 from " `isPrefixOf` s
349   wantedWarning w
350    | "warning: call-clobbered register used" `isContainedIn` w = False
351    | otherwise = True
352
353 isContainedIn :: String -> String -> Bool
354 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
355
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)])
360 getGccEnv opts =
361   if null b_dirs
362      then return Nothing
363      else do env <- getEnvironment
364              return (Just (map mangle_path env))
365  where
366   (b_dirs, _) = partitionWith get_b_opt opts
367
368   get_b_opt (Option ('-':'B':dir)) = Left dir
369   get_b_opt other = Right other
370
371   mangle_path (path,paths) | map toUpper path == "PATH"
372         = (path, '\"' : head b_dirs ++ "\";" ++ paths)
373   mangle_path other = other
374
375 runMangle :: DynFlags -> [Option] -> IO ()
376 runMangle dflags args = do
377   let (p,args0) = pgm_m dflags
378   runSomething dflags "Mangler" p (args0++args)
379
380 runSplit :: DynFlags -> [Option] -> IO ()
381 runSplit dflags args = do
382   let (p,args0) = pgm_s dflags
383   runSomething dflags "Splitter" p (args0++args)
384
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
391
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)
396
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)
401
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
408
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
415
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.
431               -- See #1828.
432             : Option "--use-temp-file"
433             : args
434   mb_env <- getGccEnv gcc_args
435   runSomethingFiltered dflags id "Windres" windres args' mb_env
436
437 touch :: DynFlags -> String -> String -> IO ()
438 touch dflags purpose arg =
439   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
440
441 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
442 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
443
444 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
445                -> IO ()
446 copyWithHeader dflags purpose maybe_header from to = do
447   showPass dflags purpose
448
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
453   hPutStr hout ls
454   hClose hout
455   hClose hin
456
457 getExtraViaCOpts :: DynFlags -> IO [String]
458 getExtraViaCOpts dflags = do
459   f <- readFile (topDir dflags </> "extra-gcc-opts")
460   return (words f)
461 \end{code}
462
463 %************************************************************************
464 %*                                                                      *
465 \subsection{Managing temporary files
466 %*                                                                      *
467 %************************************************************************
468
469 \begin{code}
470 cleanTempDirs :: DynFlags -> IO ()
471 cleanTempDirs dflags
472    = unless (dopt Opt_KeepTmpFiles dflags)
473    $ do let ref = dirsToClean dflags
474         ds <- readIORef ref
475         removeTmpDirs dflags (Map.elems ds)
476         writeIORef ref Map.empty
477
478 cleanTempFiles :: DynFlags -> IO ()
479 cleanTempFiles dflags
480    = unless (dopt Opt_KeepTmpFiles dflags)
481    $ do let ref = filesToClean dflags
482         fs <- readIORef ref
483         removeTmpFiles dflags fs
484         writeIORef ref []
485
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
494
495
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
500        x <- getProcessID
501        findTempName (d </> "ghc" ++ show x ++ "_") 0
502   where
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
510                         return filename
511
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
519            Nothing ->
520                do x <- getProcessID
521                   let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
522                   let
523                       mkTempDir :: Integer -> IO FilePath
524                       mkTempDir x
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)
530                                return dirname
531                             `catchIO` \e ->
532                                     if isAlreadyExistsError e
533                                     then mkTempDir (x+1)
534                                     else ioError e
535                   mkTempDir 0
536            Just d -> return d
537
538 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
539 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
540 addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
541
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)
547
548 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
549 removeTmpFiles dflags fs
550   = warnNon $
551     traceCmd dflags "Deleting temp files"
552              ("Deleting: " ++ unwords deletees)
553              (mapM_ (removeWith dflags removeFile) deletees)
554   where
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
557      -- files?)
558      --
559      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
560      -- the condition.
561     warnNon act
562      | null non_deletees = act
563      | otherwise         = do
564         putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
565         act
566
567     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
568
569 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
570 removeWith dflags remover f = remover f `catchIO`
571   (\e ->
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")
575                                             <+> text f <> colon
576                $$ text (show e)
577    in debugTraceMsg dflags 2 msg
578   )
579
580 -----------------------------------------------------------------------------
581 -- Running an external program
582
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
589              -> IO ()
590
591 runSomething dflags phase_name pgm args =
592   runSomethingFiltered dflags id phase_name pgm args Nothing
593
594 runSomethingFiltered
595   :: DynFlags -> (String->String) -> String -> String -> [Option]
596   -> Maybe [(String,String)] -> IO ()
597
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
602 #else
603       cmdLine = unwords (pgm:real_args)
604 #endif
605   traceCmd dflags phase_name cmdLine $ do
606   (exit_code, doesn'tExist) <-
607      catchIO (do
608          rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
609          case rc of
610            ExitSuccess{} -> return (rc, False)
611            ExitFailure n
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
616              -- at all.
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.)
623               (\ err ->
624                 if IO.isDoesNotExistError err
625                  then return (ExitFailure 1, True)
626                  else IO.ioError err)
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)
631
632 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
633                 -> [String] -> Maybe [(String, String)]
634                 -> IO ExitCode
635 builderMainLoop dflags filter_fn pgm real_args mb_env = do
636   chan <- newChan
637   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
638
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.
649   hClose hStdIn
650   hClose hStdOut
651   hClose hStdErr
652   return rc
653   where
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
661       mb_code <- if p > 0
662                    then getProcessExitCode hProcess
663                    else return Nothing
664       case mb_code of
665         Just code -> loop chan hProcess t (p-1) code
666         Nothing
667           | t > 0 -> do
668               msg <- readChan chan
669               case msg of
670                 BuildMsg msg -> do
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
676                 EOF ->
677                   loop chan hProcess (t-1) p exitcode
678           | otherwise -> loop chan hProcess t p exitcode
679
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)
684     `finally`
685        writeChan chan EOF
686         -- ToDo: check errors more carefully
687         -- ToDo: in the future, the filter should be implemented as
688         -- a stream transformer.
689     where
690         loop []     Nothing    = return ()
691         loop []     (Just err) = writeChan chan err
692         loop (l:ls) in_err     =
693                 case in_err of
694                   Just err@(BuildError srcLoc msg)
695                     | leading_whitespace l -> do
696                         loop ls (Just (BuildError srcLoc (msg $$ text l)))
697                     | otherwise -> do
698                         writeChan chan err
699                         checkError l ls
700                   Nothing -> do
701                         checkError l ls
702                   _ -> panic "readerProc/loop"
703
704         checkError l ls
705            = case parseError l of
706                 Nothing -> do
707                     writeChan chan (BuildMsg (text l))
708                     loop ls Nothing
709                 Just (file, lineNum, colNum, msg) -> do
710                     let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
711                     loop ls (Just (BuildError srcLoc (text msg)))
712
713         leading_whitespace []    = False
714         leading_whitespace (x:_) = isSpace x
715
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)
724                         Nothing ->
725                             Just (filename, lineNum, 0, s2)
726                     Nothing -> Nothing
727                 Nothing -> Nothing
728
729 breakColon :: String -> Maybe (String, String)
730 breakColon xs = case break (':' ==) xs of
731                     (ys, _:zs) -> Just (ys, zs)
732                     _ -> Nothing
733
734 breakIntColon :: String -> Maybe (Int, String)
735 breakIntColon xs = case break (':' ==) xs of
736                        (ys, _:zs)
737                         | not (null ys) && all isAscii ys && all isDigit ys ->
738                            Just (read ys, zs)
739                        _ -> Nothing
740
741 data BuildMessage
742   = BuildMsg   !SDoc
743   | BuildError !SrcLoc !SDoc
744   | EOF
745
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)
753         ; hFlush stderr
754
755            -- Test for -n flag
756         ; unless (dopt Opt_DryRun dflags) $ do {
757
758            -- And run it!
759         ; action `catchIO` handle_exn verb
760         }}
761   where
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)) }
765 \end{code}
766
767 %************************************************************************
768 %*                                                                      *
769 \subsection{Support code}
770 %*                                                                      *
771 %************************************************************************
772
773 \begin{code}
774 -----------------------------------------------------------------------------
775 -- Define       getBaseDir     :: IO (Maybe String)
776
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
786                                     free buf
787                                     return (Just (rootDir s))
788   where
789     rootDir s = case splitFileName $ normalise s of
790                 (d, ghc_exe)
791                  | lower ghc_exe `elem` ["ghc.exe",
792                                          "ghc-stage1.exe",
793                                          "ghc-stage2.exe",
794                                          "ghc-stage3.exe"] ->
795                     case splitFileName $ takeDirectory d of
796                     -- ghc is in $topdir/bin/ghc.exe
797                     (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
798                     _ -> fail
799                 _ -> fail
800         where fail = panic ("can't decompose ghc.exe path: " ++ show s)
801               lower = map toLower
802
803 foreign import stdcall unsafe "GetModuleFileNameA"
804   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
805 #else
806 getBaseDir = return Nothing
807 #endif
808
809 #ifdef mingw32_HOST_OS
810 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
811 #else
812 getProcessID :: IO Int
813 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
814 #endif
815
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
821 #else
822 linesPlatform "" = []
823 linesPlatform xs =
824   case lineBreak xs of
825     (as,xs1) -> as : linesPlatform xs1
826   where
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)
831
832 #endif
833
834 \end{code}