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