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