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 :: [String]        -- Command-line arguments starting "-B"
 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 minusB_args dflags
 211   = do  { (am_installed, top_dir) <- findTopDir minusB_args
 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 --      a) look for (the last) -B flag, and use it
 403 --      b) if there are no -B flags, 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 :: [String]
 416           -> IO (Bool,          -- True <=> am installed, False <=> in-place
 417                  String)        -- TopDir (in Unix format '/' separated)
 418
 419 findTopDir minusbs
 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 | notNull minusbs
 430               = return (normalisePath (drop 2 (last minusbs)))  -- 2 for "-B"
 431               | otherwise
 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                    }
 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   runSomething dflags "C Compiler" p (args0++args)
 468
 469 runMangle :: DynFlags -> [Option] -> IO ()
 470 runMangle dflags args = do
 471   let (p,args0) = pgm_m dflags
 472   runSomething dflags "Mangler" p (args0++args)
 473
 474 runSplit :: DynFlags -> [Option] -> IO ()
 475 runSplit dflags args = do
 476   let (p,args0) = pgm_s dflags
 477   runSomething dflags "Splitter" p (args0++args)
 478
 479 runAs :: DynFlags -> [Option] -> IO ()
 480 runAs dflags args = do
 481   let (p,args0) = pgm_a dflags
 482   runSomething dflags "Assembler" p (args0++args)
 483
 484 runLink :: DynFlags -> [Option] -> IO ()
 485 runLink dflags args = do
 486   let (p,args0) = pgm_l dflags
 487   runSomething dflags "Linker" p (args0++args)
 488
 489 runMkDLL :: DynFlags -> [Option] -> IO ()
 490 runMkDLL dflags args = do
 491   let (p,args0) = pgm_dll dflags
 492   runSomething dflags "Make DLL" p (args0++args)
 493
 494 touch :: DynFlags -> String -> String -> IO ()
 495 touch dflags purpose arg =  do
 496   p <- readIORef v_Pgm_T
 497   runSomething dflags purpose p [FileOption "" arg]
 498
 499 copy :: DynFlags -> String -> String -> String -> IO ()
 500 copy dflags purpose from to = do
 501   showPass dflags purpose
 502
 503   h <- openFile to WriteMode
 504   ls <- readFile from -- inefficient, but it'll do for now.
 505                       -- ToDo: speed up via slurping.
 506   hPutStr h ls
 507   hClose h
 508
 509 \end{code}
 510
 511 \begin{code}
 512 getSysMan :: IO String  -- How to invoke the system manager
 513                         -- (parallel system only)
 514 getSysMan = readIORef v_Pgm_sysman
 515 \end{code}
 516
 517 \begin{code}
 518 getUsageMsgPaths :: IO (FilePath,FilePath)
 519           -- the filenames of the usage messages (ghc, ghci)
 520 getUsageMsgPaths = readIORef v_Path_usages
 521 \end{code}
 522
 523
 524 %************************************************************************
 525 %*                                                                      *
 526 \subsection{Managing temporary files
 527 %*                                                                      *
 528 %************************************************************************
 529
 530 \begin{code}
 531 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 532 \end{code}
 533
 534 \begin{code}
 535 cleanTempFiles :: DynFlags -> IO ()
 536 cleanTempFiles dflags
 537    = do fs <- readIORef v_FilesToClean
 538         removeTmpFiles dflags fs
 539         writeIORef v_FilesToClean []
 540
 541 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
 542 cleanTempFilesExcept dflags dont_delete
 543    = do files <- readIORef v_FilesToClean
 544         let (to_keep, to_delete) = partition (`elem` dont_delete) files
 545         removeTmpFiles dflags to_delete
 546         writeIORef v_FilesToClean to_keep
 547
 548
 549 -- find a temporary name that doesn't already exist.
 550 newTempName :: DynFlags -> Suffix -> IO FilePath
 551 newTempName DynFlags{tmpDir=tmp_dir} extn
 552   = do x <- getProcessID
 553        findTempName (tmp_dir ++ "/ghc" ++ show x ++ "_") 0
 554   where
 555     findTempName prefix x
 556       = do let filename = (prefix ++ show x) `joinFileExt` extn
 557            b  <- doesFileExist filename
 558            if b then findTempName prefix (x+1)
 559                 else do consIORef v_FilesToClean filename -- clean it up later
 560                         return filename
 561
 562 addFilesToClean :: [FilePath] -> IO ()
 563 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 564 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
 565
 566 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
 567 removeTmpFiles dflags fs
 568   = warnNon $
 569     traceCmd dflags "Deleting temp files"
 570              ("Deleting: " ++ unwords deletees)
 571              (mapM_ rm deletees)
 572   where
 573      -- Flat out refuse to delete files that are likely to be source input
 574      -- files (is there a worse bug than having a compiler delete your source
 575      -- files?)
 576      --
 577      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
 578      -- the condition.
 579     warnNon act
 580      | null non_deletees = act
 581      | otherwise         = do
 582         putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
 583         act
 584
 585     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 586
 587     rm f = removeFile f `IO.catch`
 588                 (\_ignored ->
 589                     debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
 590                 )
 591
 592
 593 -----------------------------------------------------------------------------
 594 -- Running an external program
 595
 596 runSomething :: DynFlags
 597              -> String          -- For -v message
 598              -> String          -- Command name (possibly a full path)
 599                                 --      assumed already dos-ified
 600              -> [Option]        -- Arguments
 601                                 --      runSomething will dos-ify them
 602              -> IO ()
 603
 604 runSomething dflags phase_name pgm args = do
 605   let real_args = filter notNull (map showOpt args)
 606   traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
 607   (exit_code, doesn'tExist) <-
 608      IO.catch (do
 609          rc <- builderMainLoop dflags pgm real_args
 610          case rc of
 611            ExitSuccess{} -> return (rc, False)
 612            ExitFailure n
 613              -- rawSystem returns (ExitFailure 127) if the exec failed for any
 614              -- reason (eg. the program doesn't exist).  This is the only clue
 615              -- we have, but we need to report something to the user because in
 616              -- the case of a missing program there will otherwise be no output
 617              -- at all.
 618             | n == 127  -> return (rc, True)
 619             | otherwise -> return (rc, False))
 620                 -- Should 'rawSystem' generate an IO exception indicating that
 621                 -- 'pgm' couldn't be run rather than a funky return code, catch
 622                 -- this here (the win32 version does this, but it doesn't hurt
 623                 -- to test for this in general.)
 624               (\ err ->
 625                 if IO.isDoesNotExistError err
 626 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
 627                 -- the 'compat' version of rawSystem under mingw32 always
 628                 -- maps 'errno' to EINVAL to failure.
 629                    || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
 630 #endif
 631                  then return (ExitFailure 1, True)
 632                  else IO.ioError err)
 633   case (doesn'tExist, exit_code) of
 634      (True, _)        -> throwDyn (InstallationError ("could not execute: " ++ pgm))
 635      (_, ExitSuccess) -> return ()
 636      _                -> throwDyn (PhaseFailed phase_name exit_code)
 637
 638
 639
 640 #if __GLASGOW_HASKELL__ < 603
 641 builderMainLoop dflags pgm real_args = do
 642   rawSystem pgm real_args
 643 #else
 644 builderMainLoop dflags pgm real_args = do
 645   chan <- newChan
 646   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing
 647
 648   -- and run a loop piping the output from the compiler to the log_action in DynFlags
 649   hSetBuffering hStdOut LineBuffering
 650   hSetBuffering hStdErr LineBuffering
 651   forkIO (readerProc chan hStdOut)
 652   forkIO (readerProc chan hStdErr)
 653   rc <- loop chan hProcess 2 1 ExitSuccess
 654   hClose hStdIn
 655   hClose hStdOut
 656   hClose hStdErr
 657   return rc
 658   where
 659     -- status starts at zero, and increments each time either
 660     -- a reader process gets EOF, or the build proc exits.  We wait
 661     -- for all of these to happen (status==3).
 662     -- ToDo: we should really have a contingency plan in case any of
 663     -- the threads dies, such as a timeout.
 664     loop chan hProcess 0 0 exitcode = return exitcode
 665     loop chan hProcess t p exitcode = do
 666       mb_code <- if p > 0
 667                    then getProcessExitCode hProcess
 668                    else return Nothing
 669       case mb_code of
 670         Just code -> loop chan hProcess t (p-1) code
 671         Nothing
 672           | t > 0 -> do
 673               msg <- readChan chan
 674               case msg of
 675                 BuildMsg msg -> do
 676                   log_action dflags SevInfo noSrcSpan defaultUserStyle msg
 677                   loop chan hProcess t p exitcode
 678                 BuildError loc msg -> do
 679                   log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
 680                   loop chan hProcess t p exitcode
 681                 EOF ->
 682                   loop chan hProcess (t-1) p exitcode
 683           | otherwise -> loop chan hProcess t p exitcode
 684
 685 readerProc chan hdl = loop Nothing `catch` \e -> writeChan chan EOF
 686         -- ToDo: check errors more carefully
 687     where
 688          loop in_err = do
 689                 l <- hGetLine hdl `catch` \e -> do
 690                         case in_err of
 691                           Just err -> writeChan chan err
 692                           Nothing  -> return ()
 693                         ioError e
 694                 case in_err of
 695                   Just err@(BuildError srcLoc msg)
 696                     | leading_whitespace l -> do
 697                         loop (Just (BuildError srcLoc (msg $$ text l)))
 698                     | otherwise -> do
 699                         writeChan chan err
 700                         checkError l
 701                   Nothing -> do
 702                         checkError l
 703
 704          checkError l
 705            = case matchRegex errRegex l of
 706                 Nothing -> do
 707                     writeChan chan (BuildMsg (text l))
 708                     loop Nothing
 709                 Just (file':lineno':colno':msg:_) -> do
 710                     let file   = mkFastString file'
 711                         lineno = read lineno'::Int
 712                         colno  = case colno' of
 713                                    "" -> 0
 714                                    _  -> read (init colno') :: Int
 715                         srcLoc = mkSrcLoc file lineno colno
 716                     loop (Just (BuildError srcLoc (text msg)))
 717
 718          leading_whitespace []    = False
 719          leading_whitespace (x:_) = isSpace x
 720
 721 errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"
 722
 723 data BuildMessage
 724   = BuildMsg   !SDoc
 725   | BuildError !SrcLoc !SDoc
 726   | EOF
 727 #endif
 728
 729 showOpt (FileOption pre f) = pre ++ platformPath f
 730 showOpt (Option "") = ""
 731 showOpt (Option s)  = s
 732
 733 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
 734 -- a) trace the command (at two levels of verbosity)
 735 -- b) don't do it at all if dry-run is set
 736 traceCmd dflags phase_name cmd_line action
 737  = do   { let verb = verbosity dflags
 738         ; showPass dflags phase_name
 739         ; debugTraceMsg dflags 3 (text cmd_line)
 740         ; hFlush stderr
 741
 742            -- Test for -n flag
 743         ; unless (dopt Opt_DryRun dflags) $ do {
 744
 745            -- And run it!
 746         ; action `IO.catch` handle_exn verb
 747         }}
 748   where
 749     handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
 750                              ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
 751                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 752 \end{code}
 753
 754 %************************************************************************
 755 %*                                                                      *
 756 \subsection{Support code}
 757 %*                                                                      *
 758 %************************************************************************
 759
 760 \begin{code}
 761 -----------------------------------------------------------------------------
 762 -- Define       getBaseDir     :: IO (Maybe String)
 763
 764 getBaseDir :: IO (Maybe String)
 765 #if defined(mingw32_HOST_OS)
 766 -- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
 767 -- return the path $(stuff).  Note that we drop the "bin/" directory too.
 768 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 769                 buf <- mallocArray len
 770                 ret <- getModuleFileName nullPtr buf len
 771                 if ret == 0 then free buf >> return Nothing
 772                             else do s <- peekCString buf
 773                                     free buf
 774                                     return (Just (rootDir s))
 775   where
 776     rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
 777
 778 foreign import stdcall unsafe "GetModuleFileNameA"
 779   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 780 #else
 781 getBaseDir = return Nothing
 782 #endif
 783
 784 #ifdef mingw32_HOST_OS
 785 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 786 #elif __GLASGOW_HASKELL__ > 504
 787 getProcessID :: IO Int
 788 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 789 #else
 790 getProcessID :: IO Int
 791 getProcessID = Posix.getProcessID
 792 #endif
 793
 794 \end{code}