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