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