compiler/main/SysTools.lhs

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