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