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