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
  21         touch,                  -- String -> String -> IO ()
  22         copy,
  23         copyWithHeader,
  24         normalisePath,          -- FilePath -> FilePath
  25         getExtraViaCOpts,
  26
  27         -- Temporary-file management
  28         setTmpDir,
  29         newTempName,
  30         cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
  31         addFilesToClean,
  32
  33         Option(..)
  34
  35  ) where
  36
  37 #include "HsVersions.h"
  38
  39 import DriverPhases
  40 import Config
  41 import Outputable
  42 import ErrUtils
  43 import Panic
  44 import Util
  45 import DynFlags
  46 import FiniteMap
  47
  48 import Control.Exception
  49 import Data.IORef
  50 import Control.Monad
  51 import System.Exit
  52 import System.Environment
  53 import System.IO
  54 import SYSTEM_IO_ERROR as IO
  55 import System.Directory
  56 import Data.Char
  57 import Data.Maybe
  58 import Data.List
  59
  60 #ifndef mingw32_HOST_OS
  61 import qualified System.Posix.Internals
  62 #else /* Must be Win32 */
  63 import Foreign
  64 import CString          ( CString, peekCString )
  65 #endif
  66
  67 #if __GLASGOW_HASKELL__ < 603
  68 -- rawSystem comes from libghccompat.a in stage1
  69 import Compat.RawSystem ( rawSystem )
  70 import System.Cmd       ( system )
  71 import GHC.IOBase       ( IOErrorType(..) )
  72 #else
  73 import System.Process   ( runInteractiveProcess, getProcessExitCode )
  74 import Control.Concurrent( forkIO, newChan, readChan, writeChan )
  75 import FastString       ( mkFastString )
  76 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
  77 #endif
  78 \end{code}
  79
  80
  81                 The configuration story
  82                 ~~~~~~~~~~~~~~~~~~~~~~~
  83
  84 GHC needs various support files (library packages, RTS etc), plus
  85 various auxiliary programs (cp, gcc, etc).  It finds these in one
  86 of two places:
  87
  88 * When running as an *installed program*, GHC finds most of this support
  89   stuff in the installed library tree.  The path to this tree is passed
  90   to GHC via the -B flag, and given to initSysTools .
  91
  92 * When running *in-place* in a build tree, GHC finds most of this support
  93   stuff in the build tree.  The path to the build tree is, again passed
  94   to GHC via -B.
  95
  96 GHC tells which of the two is the case by seeing whether package.conf
  97 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
  98
  99
 100 SysTools.initSysProgs figures out exactly where all the auxiliary programs
 101 are, and initialises mutable variables to make it easy to call them.
 102 To to this, it makes use of definitions in Config.hs, which is a Haskell
 103 file containing variables whose value is figured out by the build system.
 104
 105 Config.hs contains two sorts of things
 106
 107   cGCC,         The *names* of the programs
 108   cCPP            e.g.  cGCC = gcc
 109   cUNLIT                cCPP = gcc -E
 110   etc           They do *not* include paths
 111
 112
 113   cUNLIT_DIR_REL   The *path* to the directory containing unlit, split etc
 114   cSPLIT_DIR_REL   *relative* to the root of the build tree,
 115                    for use when running *in-place* in a build tree (only)
 116
 117
 118
 119 ---------------------------------------------
 120 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
 121
 122 Another hair-brained scheme for simplifying the current tool location
 123 nightmare in GHC: Simon originally suggested using another
 124 configuration file along the lines of GCC's specs file - which is fine
 125 except that it means adding code to read yet another configuration
 126 file.  What I didn't notice is that the current package.conf is
 127 general enough to do this:
 128
 129 Package
 130     {name = "tools",    import_dirs = [],  source_dirs = [],
 131      library_dirs = [], hs_libraries = [], extra_libraries = [],
 132      include_dirs = [], c_includes = [],   package_deps = [],
 133      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
 134      extra_cc_opts = [], extra_ld_opts = []}
 135
 136 Which would have the advantage that we get to collect together in one
 137 place the path-specific package stuff with the path-specific tool
 138 stuff.
 139                 End of NOTES
 140 ---------------------------------------------
 141
 142 %************************************************************************
 143 %*                                                                      *
 144 \subsection{Initialisation}
 145 %*                                                                      *
 146 %************************************************************************
 147
 148 \begin{code}
 149 initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
 150
 151              -> DynFlags
 152              -> IO DynFlags     -- Set all the mutable variables above, holding
 153                                 --      (a) the system programs
 154                                 --      (b) the package-config file
 155                                 --      (c) the GHC usage message
 156
 157
 158 initSysTools mbMinusB dflags
 159   = do  { (am_installed, top_dir) <- findTopDir mbMinusB
 160                 -- top_dir
 161                 --      for "installed" this is the root of GHC's support files
 162                 --      for "in-place" it is the root of the build tree
 163                 -- NB: top_dir is assumed to be in standard Unix
 164                 -- format, '/' separated
 165
 166         ; let installed, installed_bin :: FilePath -> FilePath
 167               installed_bin pgm   =  pgmPath top_dir pgm
 168               installed     file  =  pgmPath top_dir file
 169               inplace dir   pgm   =  pgmPath (top_dir `joinFileName`
 170                                                 cPROJECT_DIR `joinFileName` 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         ; let dflags0 = defaultDynFlags
 200 #ifndef mingw32_HOST_OS
 201         -- check whether TMPDIR is set in the environment
 202         ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
 203 #else
 204           -- On Win32, consult GetTempPath() for a temp dir.
 205           --  => it first tries TMP, TEMP, then finally the
 206           --   Windows directory(!). The directory is in short-path
 207           --   form.
 208         ; e_tmpdir <-
 209             IO.try (do
 210                 let len = (2048::Int)
 211                 buf  <- mallocArray len
 212                 ret  <- getTempPath len buf
 213                 if ret == 0 then do
 214                       -- failed, consult TMPDIR.
 215                      free buf
 216                      getEnv "TMPDIR"
 217                   else do
 218                      s <- peekCString buf
 219                      free buf
 220                      return s)
 221 #endif
 222         ; let dflags1 = case e_tmpdir of
 223                           Left _  -> dflags0
 224                           Right d -> setTmpDir d dflags0
 225
 226         -- Check that the package config exists
 227         ; config_exists <- doesFileExist pkgconfig_path
 228         ; when (not config_exists) $
 229              throwDyn (InstallationError
 230                          ("Can't find package.conf as " ++ pkgconfig_path))
 231
 232 #if defined(mingw32_HOST_OS)
 233         --              WINDOWS-SPECIFIC STUFF
 234         -- On Windows, gcc and friends are distributed with GHC,
 235         --      so when "installed" we look in TopDir/bin
 236         -- When "in-place" we look wherever the build-time configure
 237         --      script found them
 238         -- When "install" we tell gcc where its specs file + exes are (-B)
 239         --      and also some places to pick up include files.  We need
 240         --      to be careful to put all necessary exes in the -B place
 241         --      (as, ld, cc1, etc) since if they don't get found there, gcc
 242         --      then tries to run unadorned "as", "ld", etc, and will
 243         --      pick up whatever happens to be lying around in the path,
 244         --      possibly including those from a cygwin install on the target,
 245         --      which is exactly what we're trying to avoid.
 246         ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
 247               (gcc_prog,gcc_args)
 248                 | am_installed = (installed_bin "gcc", [gcc_b_arg])
 249                 | otherwise    = (cGCC, [])
 250                 -- The trailing "/" is absolutely essential; gcc seems
 251                 -- to construct file names simply by concatenating to
 252                 -- this -B path with no extra slash We use "/" rather
 253                 -- than "\\" because otherwise "\\\" is mangled
 254                 -- later on; although gcc_args are in NATIVE format,
 255                 -- gcc can cope
 256                 --      (see comments with declarations of global variables)
 257                 --
 258                 -- The quotes round the -B argument are in case TopDir
 259                 -- has spaces in it
 260
 261               perl_path | am_installed = installed_bin cGHC_PERL
 262                         | otherwise    = cGHC_PERL
 263
 264         -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
 265         ; let touch_path  | am_installed = installed_bin cGHC_TOUCHY_PGM
 266                           | otherwise    = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
 267
 268         -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
 269         -- a call to Perl to get the invocation of split and mangle
 270         ; let (split_prog,  split_args)  = (perl_path, [Option split_script])
 271               (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
 272
 273         ; let (mkdll_prog, mkdll_args)
 274                 | am_installed =
 275                     (pgmPath (installed "gcc-lib/") cMKDLL,
 276                      [ Option "--dlltool-name",
 277                        Option (pgmPath (installed "gcc-lib/") "dlltool"),
 278                        Option "--driver-name",
 279                        Option gcc_prog, gcc_b_arg ])
 280                 | otherwise    = (cMKDLL, [])
 281 #else
 282         --              UNIX-SPECIFIC STUFF
 283         -- On Unix, the "standard" tools are assumed to be
 284         -- in the same place whether we are running "in-place" or "installed"
 285         -- That place is wherever the build-time configure script found them.
 286         ; let   gcc_prog   = cGCC
 287                 gcc_args   = []
 288                 touch_path = "touch"
 289                 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
 290                 mkdll_args = []
 291
 292         -- On Unix, scripts are invoked using the '#!' method.  Binary
 293         -- installations of GHC on Unix place the correct line on the front
 294         -- of the script at installation time, so we don't want to wire-in
 295         -- our knowledge of $(PERL) on the host system here.
 296         ; let (split_prog,  split_args)  = (split_script,  [])
 297               (mangle_prog, mangle_args) = (mangle_script, [])
 298 #endif
 299
 300         -- cpp is derived from gcc on all platforms
 301         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
 302         -- Config.hs one day.
 303         ; let cpp_path  = (gcc_prog, gcc_args ++
 304                            (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
 305
 306         -- For all systems, copy and remove are provided by the host
 307         -- system; architecture-specific stuff is done when building Config.hs
 308         ; let   cp_path = cGHC_CP
 309
 310         -- Other things being equal, as and ld are simply gcc
 311         ; let   (as_prog,as_args)  = (gcc_prog,gcc_args)
 312                 (ld_prog,ld_args)  = (gcc_prog,gcc_args)
 313
 314         ; return dflags1{
 315                         ghcUsagePath = ghc_usage_msg_path,
 316                         ghciUsagePath = ghci_usage_msg_path,
 317                         topDir  = top_dir,
 318                         systemPackageConfig = pkgconfig_path,
 319                         pgm_L   = unlit_path,
 320                         pgm_P   = cpp_path,
 321                         pgm_F   = "",
 322                         pgm_c   = (gcc_prog,gcc_args),
 323                         pgm_m   = (mangle_prog,mangle_args),
 324                         pgm_s   = (split_prog,split_args),
 325                         pgm_a   = (as_prog,as_args),
 326                         pgm_l   = (ld_prog,ld_args),
 327                         pgm_dll = (mkdll_prog,mkdll_args),
 328                         pgm_T   = touch_path,
 329                         pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan"
 330                         -- Hans: this isn't right in general, but you can
 331                         -- elaborate it in the same way as the others
 332                 }
 333         }
 334
 335 #if defined(mingw32_HOST_OS)
 336 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
 337 #endif
 338 \end{code}
 339
 340 \begin{code}
 341 -- Find TopDir
 342 --      for "installed" this is the root of GHC's support files
 343 --      for "in-place" it is the root of the build tree
 344 --
 345 -- Plan of action:
 346 -- 1. Set proto_top_dir
 347 --      if there is no given TopDir path, get the directory
 348 --      where GHC is running (only on Windows)
 349 --
 350 -- 2. If package.conf exists in proto_top_dir, we are running
 351 --      installed; and TopDir = proto_top_dir
 352 --
 353 -- 3. Otherwise we are running in-place, so
 354 --      proto_top_dir will be /...stuff.../ghc/compiler
 355 --      Set TopDir to /...stuff..., which is the root of the build tree
 356 --
 357 -- This is very gruesome indeed
 358
 359 findTopDir :: Maybe String   -- Maybe TopDir path (without the '-B' prefix).
 360            -> IO (Bool,      -- True <=> am installed, False <=> in-place
 361                   String)    -- TopDir (in Unix format '/' separated)
 362
 363 findTopDir mbMinusB
 364   = do { top_dir <- get_proto
 365         -- Discover whether we're running in a build tree or in an installation,
 366         -- by looking for the package configuration file.
 367        ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf")
 368
 369        ; return (am_installed, top_dir)
 370        }
 371   where
 372     -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
 373     get_proto = case mbMinusB of
 374                   Just minusb -> return (normalisePath minusb)
 375                   Nothing
 376                       -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
 377                             case maybe_exec_dir of       -- (only works on Windows;
 378                                                          --  returns Nothing on Unix)
 379                               Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
 380                               Just dir -> return dir
 381 \end{code}
 382
 383
 384 %************************************************************************
 385 %*                                                                      *
 386 \subsection{Running an external program}
 387 %*                                                                      *
 388 %************************************************************************
 389
 390
 391 \begin{code}
 392 runUnlit :: DynFlags -> [Option] -> IO ()
 393 runUnlit dflags args = do
 394   let p = pgm_L dflags
 395   runSomething dflags "Literate pre-processor" p args
 396
 397 runCpp :: DynFlags -> [Option] -> IO ()
 398 runCpp dflags args =   do
 399   let (p,args0) = pgm_P dflags
 400   runSomething dflags "C pre-processor" p (args0 ++ args)
 401
 402 runPp :: DynFlags -> [Option] -> IO ()
 403 runPp dflags args =   do
 404   let p = pgm_F dflags
 405   runSomething dflags "Haskell pre-processor" p args
 406
 407 runCc :: DynFlags -> [Option] -> IO ()
 408 runCc dflags args =   do
 409   let (p,args0) = pgm_c dflags
 410       args1 = args0 ++ args
 411   mb_env <- getGccEnv args1
 412   runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
 413  where
 414   -- discard some harmless warnings from gcc that we can't turn off
 415   cc_filter = unlines . doFilter . lines
 416
 417   {-
 418   gcc gives warnings in chunks like so:
 419       In file included from /foo/bar/baz.h:11,
 420                        from /foo/bar/baz2.h:22,
 421                        from wibble.c:33:
 422       /foo/flibble:14: global register variable ...
 423       /foo/flibble:15: warning: call-clobbered r...
 424   We break it up into its chunks, remove any call-clobbered register
 425   warnings from each chunk, and then delete any chunks that we have
 426   emptied of warnings.
 427   -}
 428   doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
 429   -- We can't assume that the output will start with an "In file inc..."
 430   -- line, so we start off expecting a list of warnings rather than a
 431   -- location stack.
 432   chunkWarnings :: [String] -- The location stack to use for the next
 433                             -- list of warnings
 434                 -> [String] -- The remaining lines to look at
 435                 -> [([String], [String])]
 436   chunkWarnings loc_stack [] = [(loc_stack, [])]
 437   chunkWarnings loc_stack xs
 438       = case break loc_stack_start xs of
 439         (warnings, lss:xs') ->
 440             case span loc_start_continuation xs' of
 441             (lsc, xs'') ->
 442                 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
 443         _ -> [(loc_stack, xs)]
 444
 445   filterWarnings :: [([String], [String])] -> [([String], [String])]
 446   filterWarnings [] = []
 447   -- If the warnings are already empty then we are probably doing
 448   -- something wrong, so don't delete anything
 449   filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
 450   filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
 451                                        [] -> filterWarnings zs
 452                                        ys' -> (xs, ys') : filterWarnings zs
 453
 454   unChunkWarnings :: [([String], [String])] -> [String]
 455   unChunkWarnings [] = []
 456   unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
 457
 458   loc_stack_start        s = "In file included from " `isPrefixOf` s
 459   loc_start_continuation s = "                 from " `isPrefixOf` s
 460   wantedWarning w
 461    | "warning: call-clobbered register used" `isContainedIn` w = False
 462    | otherwise = True
 463
 464 isContainedIn :: String -> String -> Bool
 465 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
 466
 467 -- If the -B<dir> option is set, add <dir> to PATH.  This works around
 468 -- a bug in gcc on Windows Vista where it can't find its auxiliary
 469 -- binaries (see bug #1110).
 470 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
 471 getGccEnv opts =
 472 #if __GLASGOW_HASKELL__ < 603
 473   return Nothing
 474 #else
 475   if null b_dirs
 476      then return Nothing
 477      else do env <- getEnvironment
 478              return (Just (map mangle_path env))
 479  where
 480   (b_dirs, _) = partitionWith get_b_opt opts
 481
 482   get_b_opt (Option ('-':'B':dir)) = Left dir
 483   get_b_opt other = Right other
 484
 485   mangle_path (path,paths) | map toUpper path == "PATH"
 486         = (path, '\"' : head b_dirs ++ "\";" ++ paths)
 487   mangle_path other = other
 488 #endif
 489
 490 runMangle :: DynFlags -> [Option] -> IO ()
 491 runMangle dflags args = do
 492   let (p,args0) = pgm_m dflags
 493   runSomething dflags "Mangler" p (args0++args)
 494
 495 runSplit :: DynFlags -> [Option] -> IO ()
 496 runSplit dflags args = do
 497   let (p,args0) = pgm_s dflags
 498   runSomething dflags "Splitter" p (args0++args)
 499
 500 runAs :: DynFlags -> [Option] -> IO ()
 501 runAs dflags args = do
 502   let (p,args0) = pgm_a dflags
 503       args1 = args0 ++ args
 504   mb_env <- getGccEnv args1
 505   runSomethingFiltered dflags id "Assembler" p args1 mb_env
 506
 507 runLink :: DynFlags -> [Option] -> IO ()
 508 runLink dflags args = do
 509   let (p,args0) = pgm_l dflags
 510       args1 = args0 ++ args
 511   mb_env <- getGccEnv args1
 512   runSomethingFiltered dflags id "Linker" p args1 mb_env
 513
 514 runMkDLL :: DynFlags -> [Option] -> IO ()
 515 runMkDLL dflags args = do
 516   let (p,args0) = pgm_dll dflags
 517       args1 = args0 ++ args
 518   mb_env <- getGccEnv (args0++args)
 519   runSomethingFiltered dflags id "Make DLL" p args1 mb_env
 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 `joinFileName` "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) `joinFileExt` 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 __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 ++ platformPath f
 832 showOpt (Option "") = ""
 833 showOpt (Option s)  = s
 834
 835 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
 836 -- a) trace the command (at two levels of verbosity)
 837 -- b) don't do it at all if dry-run is set
 838 traceCmd dflags phase_name cmd_line action
 839  = do   { let verb = verbosity dflags
 840         ; showPass dflags phase_name
 841         ; debugTraceMsg dflags 3 (text cmd_line)
 842         ; hFlush stderr
 843
 844            -- Test for -n flag
 845         ; unless (dopt Opt_DryRun dflags) $ do {
 846
 847            -- And run it!
 848         ; action `IO.catch` handle_exn verb
 849         }}
 850   where
 851     handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
 852                              ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
 853                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 854 \end{code}
 855
 856 %************************************************************************
 857 %*                                                                      *
 858 \subsection{Support code}
 859 %*                                                                      *
 860 %************************************************************************
 861
 862 \begin{code}
 863 -----------------------------------------------------------------------------
 864 -- Define       getBaseDir     :: IO (Maybe String)
 865
 866 getBaseDir :: IO (Maybe String)
 867 #if defined(mingw32_HOST_OS)
 868 -- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
 869 -- return the path $(stuff).  Note that we drop the "bin/" directory too.
 870 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 871                 buf <- mallocArray len
 872                 ret <- getModuleFileName nullPtr buf len
 873                 if ret == 0 then free buf >> return Nothing
 874                             else do s <- peekCString buf
 875                                     free buf
 876                                     return (Just (rootDir s))
 877   where
 878     rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
 879
 880 foreign import stdcall unsafe "GetModuleFileNameA"
 881   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 882 #else
 883 getBaseDir = return Nothing
 884 #endif
 885
 886 #ifdef mingw32_HOST_OS
 887 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 888 #else
 889 getProcessID :: IO Int
 890 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 891 #endif
 892
 893 -- Divvy up text stream into lines, taking platform dependent
 894 -- line termination into account.
 895 linesPlatform :: String -> [String]
 896 #if !defined(mingw32_HOST_OS)
 897 linesPlatform ls = lines ls
 898 #else
 899 linesPlatform "" = []
 900 linesPlatform xs =
 901   case lineBreak xs of
 902     (as,xs1) -> as : linesPlatform xs1
 903   where
 904    lineBreak "" = ("","")
 905    lineBreak ('\r':'\n':xs) = ([],xs)
 906    lineBreak ('\n':xs) = ([],xs)
 907    lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
 908
 909 #endif
 910
 911 \end{code}