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