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