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