compiler/main/SysTools.lhs

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