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