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