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