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