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