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