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