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