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