compiler/main/SysTools.lhs

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