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