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