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