Change another / to </> to avoid building paths containing \/
[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
22         touch,                  -- String -> String -> IO ()
23         copy,
24         copyWithHeader,
25         getExtraViaCOpts,
26
27         -- Temporary-file management
28         setTmpDir,
29         newTempName,
30         cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
31         addFilesToClean,
32
33         Option(..)
34
35  ) where
36
37 #include "HsVersions.h"
38
39 import DriverPhases
40 import Config
41 import Outputable
42 import ErrUtils
43 import Panic
44 import Util
45 import DynFlags
46 import FiniteMap
47
48 import Exception
49 import Data.IORef
50 import Control.Monad
51 import System.Exit
52 import System.Environment
53 import System.FilePath
54 import System.IO
55 import System.IO.Error as IO
56 import System.Directory
57 import Data.Char
58 import Data.List
59
60 #ifndef mingw32_HOST_OS
61 import qualified System.Posix.Internals
62 #else /* Must be Win32 */
63 import Foreign
64 import Foreign.C.String
65 #endif
66
67 import System.Process   ( runInteractiveProcess, getProcessExitCode )
68 import Control.Concurrent
69 import FastString
70 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
71 \end{code}
72
73 How GHC finds its files
74 ~~~~~~~~~~~~~~~~~~~~~~~
75
76 [Note topdir]
77
78 GHC needs various support files (library packages, RTS etc), plus
79 various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,
80 the root of GHC's support files
81
82 On Unix:
83   - ghc always has a shell wrapper that passes a -B<dir> option
84
85 On Windows:
86   - ghc never has a shell wrapper.
87   - we can find the location of the ghc binary, which is
88         $topdir/bin/<something>.exe
89     where <something> may be "ghc", "ghc-stage2", or similar
90   - we strip off the "bin/<something>.exe" to leave $topdir.
91
92 from topdir we can find package.conf, ghc-asm, etc.
93
94
95 SysTools.initSysProgs figures out exactly where all the auxiliary programs
96 are, and initialises mutable variables to make it easy to call them.
97 To to this, it makes use of definitions in Config.hs, which is a Haskell
98 file containing variables whose value is figured out by the build system.
99
100 Config.hs contains two sorts of things
101
102   cGCC,         The *names* of the programs
103   cCPP            e.g.  cGCC = gcc
104   cUNLIT                cCPP = gcc -E
105   etc           They do *not* include paths
106
107
108   cUNLIT_DIR   The *path* to the directory containing unlit, split etc
109   cSPLIT_DIR   *relative* to the root of the build tree,
110                    for use when running *in-place* in a build tree (only)
111
112
113
114 ---------------------------------------------
115 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
116
117 Another hair-brained scheme for simplifying the current tool location
118 nightmare in GHC: Simon originally suggested using another
119 configuration file along the lines of GCC's specs file - which is fine
120 except that it means adding code to read yet another configuration
121 file.  What I didn't notice is that the current package.conf is
122 general enough to do this:
123
124 Package
125     {name = "tools",    import_dirs = [],  source_dirs = [],
126      library_dirs = [], hs_libraries = [], extra_libraries = [],
127      include_dirs = [], c_includes = [],   package_deps = [],
128      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
129      extra_cc_opts = [], extra_ld_opts = []}
130
131 Which would have the advantage that we get to collect together in one
132 place the path-specific package stuff with the path-specific tool
133 stuff.
134                 End of NOTES
135 ---------------------------------------------
136
137 %************************************************************************
138 %*                                                                      *
139 \subsection{Initialisation}
140 %*                                                                      *
141 %************************************************************************
142
143 \begin{code}
144 initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
145
146              -> DynFlags
147              -> IO DynFlags     -- Set all the mutable variables above, holding
148                                 --      (a) the system programs
149                                 --      (b) the package-config file
150                                 --      (c) the GHC usage message
151
152
153 initSysTools mbMinusB dflags0
154   = do  { top_dir <- findTopDir mbMinusB
155                 -- see [Note topdir]
156                 -- NB: top_dir is assumed to be in standard Unix
157                 -- format, '/' separated
158
159         ; let installed :: FilePath -> FilePath
160               installed file = top_dir </> file
161               installed_mingw_bin file = top_dir </> ".." </> "mingw" </> "bin" </> file
162               installed_perl_bin file = top_dir </> ".." </> "perl" </> file
163
164         ; let pkgconfig_path = installed "package.conf.d"
165               ghc_usage_msg_path  = installed "ghc-usage.txt"
166               ghci_usage_msg_path = installed "ghci-usage.txt"
167
168                 -- For all systems, unlit, split, mangle are GHC utilities
169                 -- architecture-specific stuff is done when building Config.hs
170               unlit_path = installed cGHC_UNLIT_PGM
171
172                 -- split and mangle are Perl scripts
173               split_script  = installed cGHC_SPLIT_PGM
174               mangle_script = installed cGHC_MANGLER_PGM
175
176               windres_path  = installed_mingw_bin "windres"
177
178         ; tmpdir <- getTemporaryDirectory
179         ; let dflags1 = setTmpDir tmpdir dflags0
180
181         -- On Windows, mingw is distributed with GHC,
182         --      so we look in TopDir/../mingw/bin
183         ; let
184               gcc_prog
185                 | isWindowsHost = installed_mingw_bin "gcc"
186                 | otherwise     = cGCC
187               perl_path
188                 | isWindowsHost = installed_perl_bin cGHC_PERL
189                 | otherwise     = cGHC_PERL
190               -- 'touch' is a GHC util for Windows
191               touch_path
192                 | isWindowsHost = installed cGHC_TOUCHY_PGM
193                 | otherwise     = "touch"
194               -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
195               -- a call to Perl to get the invocation of split and mangle.
196               -- On Unix, scripts are invoked using the '#!' method.  Binary
197               -- installations of GHC on Unix place the correct line on the
198               -- front of the script at installation time, so we don't want
199               -- to wire-in our knowledge of $(PERL) on the host system here.
200               (split_prog,  split_args)
201                 | isWindowsHost = (perl_path,    [Option split_script])
202                 | otherwise     = (split_script, [])
203               (mangle_prog, mangle_args)
204                 | isWindowsHost = (perl_path,   [Option mangle_script])
205                 | otherwise     = (mangle_script, [])
206               (mkdll_prog, mkdll_args)
207                 | not isWindowsHost
208                     = panic "Can't build DLLs on a non-Win32 system"
209                 | otherwise =
210                     (installed_mingw_bin cMKDLL, [])
211
212         -- cpp is derived from gcc on all platforms
213         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
214         -- Config.hs one day.
215         ; let cpp_path  = (gcc_prog,
216                            (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
217
218         -- Other things being equal, as and ld are simply gcc
219         ; let   as_prog  = gcc_prog
220                 ld_prog  = gcc_prog
221
222         ; return dflags1{
223                         ghcUsagePath = ghc_usage_msg_path,
224                         ghciUsagePath = ghci_usage_msg_path,
225                         topDir  = top_dir,
226                         systemPackageConfig = pkgconfig_path,
227                         pgm_L   = unlit_path,
228                         pgm_P   = cpp_path,
229                         pgm_F   = "",
230                         pgm_c   = (gcc_prog,[]),
231                         pgm_m   = (mangle_prog,mangle_args),
232                         pgm_s   = (split_prog,split_args),
233                         pgm_a   = (as_prog,[]),
234                         pgm_l   = (ld_prog,[]),
235                         pgm_dll = (mkdll_prog,mkdll_args),
236                         pgm_T   = touch_path,
237                         pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
238                         pgm_windres = windres_path
239                         -- Hans: this isn't right in general, but you can
240                         -- elaborate it in the same way as the others
241                 }
242         }
243 \end{code}
244
245 \begin{code}
246 -- returns a Unix-format path (relying on getBaseDir to do so too)
247 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
248            -> IO String    -- TopDir (in Unix format '/' separated)
249 findTopDir (Just minusb) = return (normalise minusb)
250 findTopDir Nothing
251     = do -- Get directory of executable
252          maybe_exec_dir <- getBaseDir
253          case maybe_exec_dir of
254              -- "Just" on Windows, "Nothing" on unix
255              Nothing  -> ghcError (InstallationError "missing -B<dir> option")
256              Just dir -> return dir
257 \end{code}
258
259
260 %************************************************************************
261 %*                                                                      *
262 \subsection{Running an external program}
263 %*                                                                      *
264 %************************************************************************
265
266
267 \begin{code}
268 runUnlit :: DynFlags -> [Option] -> IO ()
269 runUnlit dflags args = do
270   let p = pgm_L dflags
271   runSomething dflags "Literate pre-processor" p args
272
273 runCpp :: DynFlags -> [Option] -> IO ()
274 runCpp dflags args =   do
275   let (p,args0) = pgm_P dflags
276       args1 = args0 ++ args
277       args2 = if dopt Opt_WarnIsError dflags
278               then Option "-Werror" : args1
279               else                    args1
280   mb_env <- getGccEnv args2
281   runSomethingFiltered dflags id  "C pre-processor" p args2 mb_env
282
283 runPp :: DynFlags -> [Option] -> IO ()
284 runPp dflags args =   do
285   let p = pgm_F dflags
286   runSomething dflags "Haskell pre-processor" p args
287
288 runCc :: DynFlags -> [Option] -> IO ()
289 runCc dflags args =   do
290   let (p,args0) = pgm_c dflags
291       args1 = args0 ++ args
292   mb_env <- getGccEnv args1
293   runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
294  where
295   -- discard some harmless warnings from gcc that we can't turn off
296   cc_filter = unlines . doFilter . lines
297
298   {-
299   gcc gives warnings in chunks like so:
300       In file included from /foo/bar/baz.h:11,
301                        from /foo/bar/baz2.h:22,
302                        from wibble.c:33:
303       /foo/flibble:14: global register variable ...
304       /foo/flibble:15: warning: call-clobbered r...
305   We break it up into its chunks, remove any call-clobbered register
306   warnings from each chunk, and then delete any chunks that we have
307   emptied of warnings.
308   -}
309   doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
310   -- We can't assume that the output will start with an "In file inc..."
311   -- line, so we start off expecting a list of warnings rather than a
312   -- location stack.
313   chunkWarnings :: [String] -- The location stack to use for the next
314                             -- list of warnings
315                 -> [String] -- The remaining lines to look at
316                 -> [([String], [String])]
317   chunkWarnings loc_stack [] = [(loc_stack, [])]
318   chunkWarnings loc_stack xs
319       = case break loc_stack_start xs of
320         (warnings, lss:xs') ->
321             case span loc_start_continuation xs' of
322             (lsc, xs'') ->
323                 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
324         _ -> [(loc_stack, xs)]
325
326   filterWarnings :: [([String], [String])] -> [([String], [String])]
327   filterWarnings [] = []
328   -- If the warnings are already empty then we are probably doing
329   -- something wrong, so don't delete anything
330   filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
331   filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
332                                        [] -> filterWarnings zs
333                                        ys' -> (xs, ys') : filterWarnings zs
334
335   unChunkWarnings :: [([String], [String])] -> [String]
336   unChunkWarnings [] = []
337   unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
338
339   loc_stack_start        s = "In file included from " `isPrefixOf` s
340   loc_start_continuation s = "                 from " `isPrefixOf` s
341   wantedWarning w
342    | "warning: call-clobbered register used" `isContainedIn` w = False
343    | otherwise = True
344
345 isContainedIn :: String -> String -> Bool
346 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
347
348 -- If the -B<dir> option is set, add <dir> to PATH.  This works around
349 -- a bug in gcc on Windows Vista where it can't find its auxiliary
350 -- binaries (see bug #1110).
351 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
352 getGccEnv opts =
353   if null b_dirs
354      then return Nothing
355      else do env <- getEnvironment
356              return (Just (map mangle_path env))
357  where
358   (b_dirs, _) = partitionWith get_b_opt opts
359
360   get_b_opt (Option ('-':'B':dir)) = Left dir
361   get_b_opt other = Right other
362
363   mangle_path (path,paths) | map toUpper path == "PATH"
364         = (path, '\"' : head b_dirs ++ "\";" ++ paths)
365   mangle_path other = other
366
367 runMangle :: DynFlags -> [Option] -> IO ()
368 runMangle dflags args = do
369   let (p,args0) = pgm_m dflags
370   runSomething dflags "Mangler" p (args0++args)
371
372 runSplit :: DynFlags -> [Option] -> IO ()
373 runSplit dflags args = do
374   let (p,args0) = pgm_s dflags
375   runSomething dflags "Splitter" p (args0++args)
376
377 runAs :: DynFlags -> [Option] -> IO ()
378 runAs dflags args = do
379   let (p,args0) = pgm_a dflags
380       args1 = args0 ++ args
381   mb_env <- getGccEnv args1
382   runSomethingFiltered dflags id "Assembler" p args1 mb_env
383
384 runLink :: DynFlags -> [Option] -> IO ()
385 runLink dflags args = do
386   let (p,args0) = pgm_l dflags
387       args1 = args0 ++ args
388   mb_env <- getGccEnv args1
389   runSomethingFiltered dflags id "Linker" p args1 mb_env
390
391 runMkDLL :: DynFlags -> [Option] -> IO ()
392 runMkDLL dflags args = do
393   let (p,args0) = pgm_dll dflags
394       args1 = args0 ++ args
395   mb_env <- getGccEnv (args0++args)
396   runSomethingFiltered dflags id "Make DLL" p args1 mb_env
397
398 runWindres :: DynFlags -> [Option] -> IO ()
399 runWindres dflags args = do
400   let (gcc, gcc_args) = pgm_c dflags
401       windres = pgm_windres dflags
402       quote x = "\"" ++ x ++ "\""
403       args' = -- If windres.exe and gcc.exe are in a directory containing
404               -- spaces then windres fails to run gcc. We therefore need
405               -- to tell it what command to use...
406               Option ("--preprocessor=" ++
407                       unwords (map quote (gcc :
408                                           map showOpt gcc_args ++
409                                           ["-E", "-xc", "-DRC_INVOKED"])))
410               -- ...but if we do that then if windres calls popen then
411               -- it can't understand the quoting, so we have to use
412               -- --use-temp-file so that it interprets it correctly.
413               -- See #1828.
414             : Option "--use-temp-file"
415             : args
416   mb_env <- getGccEnv gcc_args
417   runSomethingFiltered dflags id "Windres" windres args' mb_env
418
419 touch :: DynFlags -> String -> String -> IO ()
420 touch dflags purpose arg =
421   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
422
423 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
424 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
425
426 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
427                -> IO ()
428 copyWithHeader dflags purpose maybe_header from to = do
429   showPass dflags purpose
430
431   hout <- openBinaryFile to   WriteMode
432   hin  <- openBinaryFile from ReadMode
433   ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
434   maybe (return ()) (hPutStr hout) maybe_header
435   hPutStr hout ls
436   hClose hout
437   hClose hin
438
439 getExtraViaCOpts :: DynFlags -> IO [String]
440 getExtraViaCOpts dflags = do
441   f <- readFile (topDir dflags </> "extra-gcc-opts")
442   return (words f)
443 \end{code}
444
445 %************************************************************************
446 %*                                                                      *
447 \subsection{Managing temporary files
448 %*                                                                      *
449 %************************************************************************
450
451 \begin{code}
452 cleanTempDirs :: DynFlags -> IO ()
453 cleanTempDirs dflags
454    = unless (dopt Opt_KeepTmpFiles dflags)
455    $ do let ref = dirsToClean dflags
456         ds <- readIORef ref
457         removeTmpDirs dflags (eltsFM ds)
458         writeIORef ref emptyFM
459
460 cleanTempFiles :: DynFlags -> IO ()
461 cleanTempFiles dflags
462    = unless (dopt Opt_KeepTmpFiles dflags)
463    $ do let ref = filesToClean dflags
464         fs <- readIORef ref
465         removeTmpFiles dflags fs
466         writeIORef ref []
467
468 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
469 cleanTempFilesExcept dflags dont_delete
470    = unless (dopt Opt_KeepTmpFiles dflags)
471    $ do let ref = filesToClean dflags
472         files <- readIORef ref
473         let (to_keep, to_delete) = partition (`elem` dont_delete) files
474         removeTmpFiles dflags to_delete
475         writeIORef ref to_keep
476
477
478 -- find a temporary name that doesn't already exist.
479 newTempName :: DynFlags -> Suffix -> IO FilePath
480 newTempName dflags extn
481   = do d <- getTempDir dflags
482        x <- getProcessID
483        findTempName (d </> "ghc" ++ show x ++ "_") 0
484   where
485     findTempName :: FilePath -> Integer -> IO FilePath
486     findTempName prefix x
487       = do let filename = (prefix ++ show x) <.> extn
488            b  <- doesFileExist filename
489            if b then findTempName prefix (x+1)
490                 else do -- clean it up later
491                         consIORef (filesToClean dflags) filename
492                         return filename
493
494 -- return our temporary directory within tmp_dir, creating one if we
495 -- don't have one yet
496 getTempDir :: DynFlags -> IO FilePath
497 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
498   = do let ref = dirsToClean dflags
499        mapping <- readIORef ref
500        case lookupFM mapping tmp_dir of
501            Nothing ->
502                do x <- getProcessID
503                   let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
504                   let
505                       mkTempDir :: Integer -> IO FilePath
506                       mkTempDir x
507                        = let dirname = prefix ++ show x
508                          in do createDirectory dirname
509                                let mapping' = addToFM mapping tmp_dir dirname
510                                writeIORef ref mapping'
511                                debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
512                                return dirname
513                             `IO.catch` \e ->
514                                     if isAlreadyExistsError e
515                                     then mkTempDir (x+1)
516                                     else ioError e
517                   mkTempDir 0
518            Just d -> return d
519
520 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
521 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
522 addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
523
524 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
525 removeTmpDirs dflags ds
526   = traceCmd dflags "Deleting temp dirs"
527              ("Deleting: " ++ unwords ds)
528              (mapM_ (removeWith dflags removeDirectory) ds)
529
530 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
531 removeTmpFiles dflags fs
532   = warnNon $
533     traceCmd dflags "Deleting temp files"
534              ("Deleting: " ++ unwords deletees)
535              (mapM_ (removeWith dflags removeFile) deletees)
536   where
537      -- Flat out refuse to delete files that are likely to be source input
538      -- files (is there a worse bug than having a compiler delete your source
539      -- files?)
540      --
541      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
542      -- the condition.
543     warnNon act
544      | null non_deletees = act
545      | otherwise         = do
546         putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
547         act
548
549     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
550
551 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
552 removeWith dflags remover f = remover f `IO.catch`
553   (\e ->
554    let msg = if isDoesNotExistError e
555              then ptext (sLit "Warning: deleting non-existent") <+> text f
556              else ptext (sLit "Warning: exception raised when deleting")
557                                             <+> text f <> colon
558                $$ text (show e)
559    in debugTraceMsg dflags 2 msg
560   )
561
562 -----------------------------------------------------------------------------
563 -- Running an external program
564
565 runSomething :: DynFlags
566              -> String          -- For -v message
567              -> String          -- Command name (possibly a full path)
568                                 --      assumed already dos-ified
569              -> [Option]        -- Arguments
570                                 --      runSomething will dos-ify them
571              -> IO ()
572
573 runSomething dflags phase_name pgm args =
574   runSomethingFiltered dflags id phase_name pgm args Nothing
575
576 runSomethingFiltered
577   :: DynFlags -> (String->String) -> String -> String -> [Option]
578   -> Maybe [(String,String)] -> IO ()
579
580 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
581   let real_args = filter notNull (map showOpt args)
582   traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
583   (exit_code, doesn'tExist) <-
584      IO.catch (do
585          rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
586          case rc of
587            ExitSuccess{} -> return (rc, False)
588            ExitFailure n
589              -- rawSystem returns (ExitFailure 127) if the exec failed for any
590              -- reason (eg. the program doesn't exist).  This is the only clue
591              -- we have, but we need to report something to the user because in
592              -- the case of a missing program there will otherwise be no output
593              -- at all.
594             | n == 127  -> return (rc, True)
595             | otherwise -> return (rc, False))
596                 -- Should 'rawSystem' generate an IO exception indicating that
597                 -- 'pgm' couldn't be run rather than a funky return code, catch
598                 -- this here (the win32 version does this, but it doesn't hurt
599                 -- to test for this in general.)
600               (\ err ->
601                 if IO.isDoesNotExistError err
602                  then return (ExitFailure 1, True)
603                  else IO.ioError err)
604   case (doesn'tExist, exit_code) of
605      (True, _)        -> ghcError (InstallationError ("could not execute: " ++ pgm))
606      (_, ExitSuccess) -> return ()
607      _                -> ghcError (PhaseFailed phase_name exit_code)
608
609 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
610                 -> [String] -> Maybe [(String, String)]
611                 -> IO ExitCode
612 builderMainLoop dflags filter_fn pgm real_args mb_env = do
613   chan <- newChan
614   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
615
616   -- and run a loop piping the output from the compiler to the log_action in DynFlags
617   hSetBuffering hStdOut LineBuffering
618   hSetBuffering hStdErr LineBuffering
619   _ <- forkIO (readerProc chan hStdOut filter_fn)
620   _ <- forkIO (readerProc chan hStdErr filter_fn)
621   -- we don't want to finish until 2 streams have been completed
622   -- (stdout and stderr)
623   -- nor until 1 exit code has been retrieved.
624   rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
625   -- after that, we're done here.
626   hClose hStdIn
627   hClose hStdOut
628   hClose hStdErr
629   return rc
630   where
631     -- status starts at zero, and increments each time either
632     -- a reader process gets EOF, or the build proc exits.  We wait
633     -- for all of these to happen (status==3).
634     -- ToDo: we should really have a contingency plan in case any of
635     -- the threads dies, such as a timeout.
636     loop _    _        0 0 exitcode = return exitcode
637     loop chan hProcess t p exitcode = do
638       mb_code <- if p > 0
639                    then getProcessExitCode hProcess
640                    else return Nothing
641       case mb_code of
642         Just code -> loop chan hProcess t (p-1) code
643         Nothing
644           | t > 0 -> do
645               msg <- readChan chan
646               case msg of
647                 BuildMsg msg -> do
648                   log_action dflags SevInfo noSrcSpan defaultUserStyle msg
649                   loop chan hProcess t p exitcode
650                 BuildError loc msg -> do
651                   log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
652                   loop chan hProcess t p exitcode
653                 EOF ->
654                   loop chan hProcess (t-1) p exitcode
655           | otherwise -> loop chan hProcess t p exitcode
656
657 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
658 readerProc chan hdl filter_fn =
659     (do str <- hGetContents hdl
660         loop (linesPlatform (filter_fn str)) Nothing)
661     `finally`
662        writeChan chan EOF
663         -- ToDo: check errors more carefully
664         -- ToDo: in the future, the filter should be implemented as
665         -- a stream transformer.
666     where
667         loop []     Nothing    = return ()
668         loop []     (Just err) = writeChan chan err
669         loop (l:ls) in_err     =
670                 case in_err of
671                   Just err@(BuildError srcLoc msg)
672                     | leading_whitespace l -> do
673                         loop ls (Just (BuildError srcLoc (msg $$ text l)))
674                     | otherwise -> do
675                         writeChan chan err
676                         checkError l ls
677                   Nothing -> do
678                         checkError l ls
679                   _ -> panic "readerProc/loop"
680
681         checkError l ls
682            = case parseError l of
683                 Nothing -> do
684                     writeChan chan (BuildMsg (text l))
685                     loop ls Nothing
686                 Just (file, lineNum, colNum, msg) -> do
687                     let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
688                     loop ls (Just (BuildError srcLoc (text msg)))
689
690         leading_whitespace []    = False
691         leading_whitespace (x:_) = isSpace x
692
693 parseError :: String -> Maybe (String, Int, Int, String)
694 parseError s0 = case breakColon s0 of
695                 Just (filename, s1) ->
696                     case breakIntColon s1 of
697                     Just (lineNum, s2) ->
698                         case breakIntColon s2 of
699                         Just (columnNum, s3) ->
700                             Just (filename, lineNum, columnNum, s3)
701                         Nothing ->
702                             Just (filename, lineNum, 0, s2)
703                     Nothing -> Nothing
704                 Nothing -> Nothing
705
706 breakColon :: String -> Maybe (String, String)
707 breakColon xs = case break (':' ==) xs of
708                     (ys, _:zs) -> Just (ys, zs)
709                     _ -> Nothing
710
711 breakIntColon :: String -> Maybe (Int, String)
712 breakIntColon xs = case break (':' ==) xs of
713                        (ys, _:zs)
714                         | not (null ys) && all isAscii ys && all isDigit ys ->
715                            Just (read ys, zs)
716                        _ -> Nothing
717
718 data BuildMessage
719   = BuildMsg   !SDoc
720   | BuildError !SrcLoc !SDoc
721   | EOF
722
723 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
724 -- a) trace the command (at two levels of verbosity)
725 -- b) don't do it at all if dry-run is set
726 traceCmd dflags phase_name cmd_line action
727  = do   { let verb = verbosity dflags
728         ; showPass dflags phase_name
729         ; debugTraceMsg dflags 3 (text cmd_line)
730         ; hFlush stderr
731
732            -- Test for -n flag
733         ; unless (dopt Opt_DryRun dflags) $ do {
734
735            -- And run it!
736         ; action `IO.catch` handle_exn verb
737         }}
738   where
739     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
740                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
741                               ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
742 \end{code}
743
744 %************************************************************************
745 %*                                                                      *
746 \subsection{Support code}
747 %*                                                                      *
748 %************************************************************************
749
750 \begin{code}
751 -----------------------------------------------------------------------------
752 -- Define       getBaseDir     :: IO (Maybe String)
753
754 getBaseDir :: IO (Maybe String)
755 #if defined(mingw32_HOST_OS)
756 -- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
757 -- return the path $(stuff)/lib.
758 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
759                 buf <- mallocArray len
760                 ret <- getModuleFileName nullPtr buf len
761                 if ret == 0 then free buf >> return Nothing
762                             else do s <- peekCString buf
763                                     free buf
764                                     return (Just (rootDir s))
765   where
766     rootDir s = case splitFileName $ normalise s of
767                 (d, ghc_exe)
768                  | lower ghc_exe `elem` ["ghc.exe",
769                                          "ghc-stage1.exe",
770                                          "ghc-stage2.exe",
771                                          "ghc-stage3.exe"] ->
772                     case splitFileName $ takeDirectory d of
773                     -- ghc is in $topdir/bin/ghc.exe
774                     (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
775                     _ -> fail
776                 _ -> fail
777         where fail = panic ("can't decompose ghc.exe path: " ++ show s)
778               lower = map toLower
779
780 foreign import stdcall unsafe "GetModuleFileNameA"
781   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
782 #else
783 getBaseDir = return Nothing
784 #endif
785
786 #ifdef mingw32_HOST_OS
787 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
788 #else
789 getProcessID :: IO Int
790 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
791 #endif
792
793 -- Divvy up text stream into lines, taking platform dependent
794 -- line termination into account.
795 linesPlatform :: String -> [String]
796 #if !defined(mingw32_HOST_OS)
797 linesPlatform ls = lines ls
798 #else
799 linesPlatform "" = []
800 linesPlatform xs =
801   case lineBreak xs of
802     (as,xs1) -> as : linesPlatform xs1
803   where
804    lineBreak "" = ("","")
805    lineBreak ('\r':'\n':xs) = ([],xs)
806    lineBreak ('\n':xs) = ([],xs)
807    lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
808
809 #endif
810
811 \end{code}