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 module SysTools (
  11         -- Initialisation
  12         initSysTools,
  13
  14         -- Interface to system tools
  15         runUnlit, runCpp, runCc, -- [Option] -> IO ()
  16         runPp,                   -- [Option] -> IO ()
  17         runMangle, runSplit,     -- [Option] -> IO ()
  18         runAs, runLink,          -- [Option] -> IO ()
  19         runMkDLL,
  20         runWindres,
  21
  22         touch,                  -- String -> String -> IO ()
  23         copy,
  24         copyWithHeader,
  25         getExtraViaCOpts,
  26
  27         -- Temporary-file management
  28         setTmpDir,
  29         newTempName,
  30         cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
  31         addFilesToClean,
  32
  33         Option(..)
  34
  35  ) where
  36
  37 #include "HsVersions.h"
  38
  39 import DriverPhases
  40 import Config
  41 import Outputable
  42 import ErrUtils
  43 import Panic
  44 import Util
  45 import DynFlags
  46 import FiniteMap
  47
  48 import Exception
  49 import Data.IORef
  50 import Control.Monad
  51 import System.Exit
  52 import System.Environment
  53 import System.FilePath
  54 import System.IO
  55 import System.IO.Error as IO
  56 import System.Directory
  57 import Data.Char
  58 import Data.Maybe
  59 import Data.List
  60
  61 #ifndef mingw32_HOST_OS
  62 import qualified System.Posix.Internals
  63 #else /* Must be Win32 */
  64 import Foreign
  65 import CString          ( CString, peekCString )
  66 #endif
  67
  68 import System.Process   ( runInteractiveProcess, getProcessExitCode )
  69 import Control.Concurrent
  70 import FastString
  71 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
  72 \end{code}
  73
  74 How GHC finds its files
  75 ~~~~~~~~~~~~~~~~~~~~~~~
  76
  77 [Note topdir]
  78
  79 GHC needs various support files (library packages, RTS etc), plus
  80 various auxiliary programs (cp, gcc, etc).  It starts by finding topdir:
  81
  82      for "installed" topdir is the root of GHC's support files ($libdir)
  83      for "in-place"  topdir is the root of the build tree
  84
  85 On Unix:
  86   - ghc always has a shell wrapper that passes a -B<dir> option
  87   - in an installation, <dir> is $libdir
  88   - in a build tree, <dir> is $TOP/inplace-datadir
  89   - so we detect the build-tree case and add ".." to get us back to $TOP
  90
  91 On Windows:
  92   - ghc never has a shell wrapper.
  93   - we can find the location of the ghc binary, which is
  94         $topdir/bin/ghc.exe                   in an installation, or
  95         $topdir/ghc/stage1-inplace/ghc.exe    in a build tree.
  96   - we detect which one of these we have, and calculate $topdir.
  97
  98
  99 from topdir we can find package.conf, which contains the locations of
 100 almost everything else, whether we're in a build tree or installed.
 101
 102
 103 SysTools.initSysProgs figures out exactly where all the auxiliary programs
 104 are, and initialises mutable variables to make it easy to call them.
 105 To to this, it makes use of definitions in Config.hs, which is a Haskell
 106 file containing variables whose value is figured out by the build system.
 107
 108 Config.hs contains two sorts of things
 109
 110   cGCC,         The *names* of the programs
 111   cCPP            e.g.  cGCC = gcc
 112   cUNLIT                cCPP = gcc -E
 113   etc           They do *not* include paths
 114
 115
 116   cUNLIT_DIR_REL   The *path* to the directory containing unlit, split etc
 117   cSPLIT_DIR_REL   *relative* to the root of the build tree,
 118                    for use when running *in-place* in a build tree (only)
 119
 120
 121
 122 ---------------------------------------------
 123 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
 124
 125 Another hair-brained scheme for simplifying the current tool location
 126 nightmare in GHC: Simon originally suggested using another
 127 configuration file along the lines of GCC's specs file - which is fine
 128 except that it means adding code to read yet another configuration
 129 file.  What I didn't notice is that the current package.conf is
 130 general enough to do this:
 131
 132 Package
 133     {name = "tools",    import_dirs = [],  source_dirs = [],
 134      library_dirs = [], hs_libraries = [], extra_libraries = [],
 135      include_dirs = [], c_includes = [],   package_deps = [],
 136      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
 137      extra_cc_opts = [], extra_ld_opts = []}
 138
 139 Which would have the advantage that we get to collect together in one
 140 place the path-specific package stuff with the path-specific tool
 141 stuff.
 142                 End of NOTES
 143 ---------------------------------------------
 144
 145 %************************************************************************
 146 %*                                                                      *
 147 \subsection{Initialisation}
 148 %*                                                                      *
 149 %************************************************************************
 150
 151 \begin{code}
 152 initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
 153
 154              -> DynFlags
 155              -> IO DynFlags     -- Set all the mutable variables above, holding
 156                                 --      (a) the system programs
 157                                 --      (b) the package-config file
 158                                 --      (c) the GHC usage message
 159
 160
 161 initSysTools mbMinusB dflags0
 162   = do  { (am_installed, top_dir) <- findTopDir mbMinusB
 163                 -- see [Note topdir]
 164                 -- NB: top_dir is assumed to be in standard Unix
 165                 -- format, '/' separated
 166
 167         ; let installed, installed_bin :: FilePath -> FilePath
 168               installed_bin pgm  = top_dir </> pgm
 169               installed     file = top_dir </> file
 170               inplace dir   pgm  = top_dir </> dir </> pgm
 171
 172         ; let pkgconfig_path
 173                 | am_installed = installed "package.conf"
 174                 | otherwise    = inplace "inplace-datadir" "package.conf"
 175
 176               ghc_usage_msg_path
 177                 | am_installed = installed "ghc-usage.txt"
 178                 | otherwise    = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
 179
 180               ghci_usage_msg_path
 181                 | am_installed = installed "ghci-usage.txt"
 182                 | otherwise    = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
 183
 184                 -- For all systems, unlit, split, mangle are GHC utilities
 185                 -- architecture-specific stuff is done when building Config.hs
 186               unlit_path
 187                 | am_installed = installed_bin cGHC_UNLIT_PGM
 188                 | otherwise    = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
 189
 190                 -- split and mangle are Perl scripts
 191               split_script
 192                 | am_installed = installed_bin cGHC_SPLIT_PGM
 193                 | otherwise    = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
 194
 195               mangle_script
 196                 | am_installed = installed_bin cGHC_MANGLER_PGM
 197                 | otherwise    = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
 198
 199               windres_path
 200                 | am_installed = installed_bin "bin/windres"
 201                 | otherwise    = "windres"
 202
 203         ; tmpdir <- getTemporaryDirectory
 204         ; let dflags1 = setTmpDir tmpdir dflags0
 205
 206         -- Check that the package config exists
 207         ; config_exists <- doesFileExist pkgconfig_path
 208         ; when (not config_exists) $
 209              ghcError (InstallationError
 210                          ("Can't find package.conf as " ++ pkgconfig_path))
 211
 212         -- On Windows, gcc and friends are distributed with GHC,
 213         --      so when "installed" we look in TopDir/bin
 214         -- When "in-place", or when not on Windows, we look wherever
 215         --      the build-time configure script found them
 216         ; let
 217               -- The trailing "/" is absolutely essential; gcc seems
 218               -- to construct file names simply by concatenating to
 219               -- this -B path with no extra slash We use "/" rather
 220               -- than "\\" because otherwise "\\\" is mangled
 221               -- later on; although gcc_args are in NATIVE format,
 222               -- gcc can cope
 223               --      (see comments with declarations of global variables)
 224               gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
 225               gcc_mingw_include_arg = Option ("-I" ++ installed "include/mingw/")
 226               (gcc_prog,gcc_args)
 227                 | isWindowsHost && am_installed
 228                     -- We tell gcc where its specs file + exes are (-B)
 229                     -- and also some places to pick up include files.  We need
 230                     -- to be careful to put all necessary exes in the -B place
 231                     -- (as, ld, cc1, etc) since if they don't get found there,
 232                     -- gcc then tries to run unadorned "as", "ld", etc, and
 233                     -- will pick up whatever happens to be lying around in
 234                     -- the path, possibly including those from a cygwin
 235                     -- install on the target, which is exactly what we're
 236                     -- trying to avoid.
 237                     = (installed_bin "gcc", [gcc_b_arg, gcc_mingw_include_arg])
 238                 | otherwise = (cGCC, [])
 239               perl_path
 240                 | isWindowsHost && am_installed = installed_bin cGHC_PERL
 241                 | otherwise = cGHC_PERL
 242               -- 'touch' is a GHC util for Windows
 243               touch_path
 244                 | isWindowsHost
 245                     = if am_installed
 246                       then installed_bin cGHC_TOUCHY_PGM
 247                       else inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
 248                 | otherwise = "touch"
 249               -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 250               -- a call to Perl to get the invocation of split and mangle.
 251               -- On Unix, scripts are invoked using the '#!' method.  Binary
 252               -- installations of GHC on Unix place the correct line on the
 253               -- front of the script at installation time, so we don't want
 254               -- to wire-in our knowledge of $(PERL) on the host system here.
 255               (split_prog,  split_args)
 256                 | isWindowsHost = (perl_path,    [Option split_script])
 257                 | otherwise     = (split_script, [])
 258               (mangle_prog, mangle_args)
 259                 | isWindowsHost = (perl_path,   [Option mangle_script])
 260                 | otherwise     = (mangle_script, [])
 261               (mkdll_prog, mkdll_args)
 262                 | not isWindowsHost
 263                     = panic "Can't build DLLs on a non-Win32 system"
 264                 | am_installed =
 265                     (installed "gcc-lib/" </> cMKDLL,
 266                      [ Option "--dlltool-name",
 267                        Option (installed "gcc-lib/" </> "dlltool"),
 268                        Option "--driver-name",
 269                        Option gcc_prog, gcc_b_arg, gcc_mingw_include_arg ])
 270                 | otherwise    = (cMKDLL, [])
 271
 272         -- cpp is derived from gcc on all platforms
 273         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
 274         -- Config.hs one day.
 275         ; let cpp_path  = (gcc_prog, gcc_args ++
 276                            (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
 277
 278         -- Other things being equal, as and ld are simply gcc
 279         ; let   (as_prog,as_args)  = (gcc_prog,gcc_args)
 280                 (ld_prog,ld_args)  = (gcc_prog,gcc_args)
 281
 282         ; return dflags1{
 283                         ghcUsagePath = ghc_usage_msg_path,
 284                         ghciUsagePath = ghci_usage_msg_path,
 285                         topDir  = top_dir,
 286                         systemPackageConfig = pkgconfig_path,
 287                         pgm_L   = unlit_path,
 288                         pgm_P   = cpp_path,
 289                         pgm_F   = "",
 290                         pgm_c   = (gcc_prog,gcc_args),
 291                         pgm_m   = (mangle_prog,mangle_args),
 292                         pgm_s   = (split_prog,split_args),
 293                         pgm_a   = (as_prog,as_args),
 294                         pgm_l   = (ld_prog,ld_args),
 295                         pgm_dll = (mkdll_prog,mkdll_args),
 296                         pgm_T   = touch_path,
 297                         pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
 298                         pgm_windres = windres_path
 299                         -- Hans: this isn't right in general, but you can
 300                         -- elaborate it in the same way as the others
 301                 }
 302         }
 303 \end{code}
 304
 305 \begin{code}
 306 findTopDir :: Maybe String   -- Maybe TopDir path (without the '-B' prefix).
 307            -> IO (Bool,      -- True <=> am installed, False <=> in-place
 308                   String)    -- TopDir (in Unix format '/' separated)
 309
 310 findTopDir mbMinusB
 311   = do { top_dir <- get_proto
 312        ; exists1 <- doesFileExist (top_dir </> "package.conf")
 313        ; exists2 <- doesFileExist (top_dir </> "inplace")
 314        ; let amInplace = not exists1 -- On Windows, package.conf doesn't exist
 315                                      -- when we are inplace
 316                       || exists2 -- On Linux, the presence of inplace signals
 317                                  -- that we are inplace
 318
 319        ; let real_top = if exists2 then top_dir </> ".." else top_dir
 320
 321        ; return (not amInplace, real_top)
 322        }
 323   where
 324     -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
 325     get_proto = case mbMinusB of
 326                   Just minusb -> return (normalise minusb)
 327                   Nothing
 328                       -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
 329                             case maybe_exec_dir of       -- (only works on Windows;
 330                                                          --  returns Nothing on Unix)
 331                               Nothing  -> ghcError (InstallationError "missing -B<dir> option")
 332                               Just dir -> return dir
 333 \end{code}
 334
 335
 336 %************************************************************************
 337 %*                                                                      *
 338 \subsection{Running an external program}
 339 %*                                                                      *
 340 %************************************************************************
 341
 342
 343 \begin{code}
 344 runUnlit :: DynFlags -> [Option] -> IO ()
 345 runUnlit dflags args = do
 346   let p = pgm_L dflags
 347   runSomething dflags "Literate pre-processor" p args
 348
 349 runCpp :: DynFlags -> [Option] -> IO ()
 350 runCpp dflags args =   do
 351   let (p,args0) = pgm_P dflags
 352       args1 = args0 ++ args
 353       args2 = if dopt Opt_WarnIsError dflags
 354               then Option "-Werror" : args1
 355               else                    args1
 356   mb_env <- getGccEnv args2
 357   runSomethingFiltered dflags id  "C pre-processor" p args2 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}