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 "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   mb_env <- getGccEnv gcc_args
 532   runSomethingFiltered dflags id "Windres" windres
 533         -- we must tell windres where to find gcc: it might not be on PATH
 534         (Option ("--preprocessor=" ++ gcc ++ " " ++
 535                                       unwords (map showOpt gcc_args) ++
 536                  " -E -xc -DRC_INVOKED")
 537          : args)
 538         -- we must use the PATH workaround here too, since windres invokes gcc
 539         mb_env
 540
 541 touch :: DynFlags -> String -> String -> IO ()
 542 touch dflags purpose arg =
 543   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
 544
 545 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
 546 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
 547
 548 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
 549                -> IO ()
 550 copyWithHeader dflags purpose maybe_header from to = do
 551   showPass dflags purpose
 552
 553   h <- openFile to WriteMode
 554   ls <- readFile from -- inefficient, but it'll do for now.
 555                       -- ToDo: speed up via slurping.
 556   maybe (return ()) (hPutStr h) maybe_header
 557   hPutStr h ls
 558   hClose h
 559
 560 getExtraViaCOpts :: DynFlags -> IO [String]
 561 getExtraViaCOpts dflags = do
 562   f <- readFile (topDir dflags `joinFileName` "extra-gcc-opts")
 563   return (words f)
 564 \end{code}
 565
 566 %************************************************************************
 567 %*                                                                      *
 568 \subsection{Managing temporary files
 569 %*                                                                      *
 570 %************************************************************************
 571
 572 \begin{code}
 573 GLOBAL_VAR(v_FilesToClean, [],               [String] )
 574 GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
 575 \end{code}
 576
 577 \begin{code}
 578 cleanTempDirs :: DynFlags -> IO ()
 579 cleanTempDirs dflags
 580    = unless (dopt Opt_KeepTmpFiles dflags)
 581    $ do ds <- readIORef v_DirsToClean
 582         removeTmpDirs dflags (eltsFM ds)
 583         writeIORef v_DirsToClean emptyFM
 584
 585 cleanTempFiles :: DynFlags -> IO ()
 586 cleanTempFiles dflags
 587    = unless (dopt Opt_KeepTmpFiles dflags)
 588    $ do fs <- readIORef v_FilesToClean
 589         removeTmpFiles dflags fs
 590         writeIORef v_FilesToClean []
 591
 592 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
 593 cleanTempFilesExcept dflags dont_delete
 594    = unless (dopt Opt_KeepTmpFiles dflags)
 595    $ do files <- readIORef v_FilesToClean
 596         let (to_keep, to_delete) = partition (`elem` dont_delete) files
 597         removeTmpFiles dflags to_delete
 598         writeIORef v_FilesToClean to_keep
 599
 600
 601 -- find a temporary name that doesn't already exist.
 602 newTempName :: DynFlags -> Suffix -> IO FilePath
 603 newTempName dflags extn
 604   = do d <- getTempDir dflags
 605        x <- getProcessID
 606        findTempName (d ++ "/ghc" ++ show x ++ "_") 0
 607   where
 608     findTempName :: FilePath -> Integer -> IO FilePath
 609     findTempName prefix x
 610       = do let filename = (prefix ++ show x) `joinFileExt` extn
 611            b  <- doesFileExist filename
 612            if b then findTempName prefix (x+1)
 613                 else do consIORef v_FilesToClean filename -- clean it up later
 614                         return filename
 615
 616 -- return our temporary directory within tmp_dir, creating one if we
 617 -- don't have one yet
 618 getTempDir :: DynFlags -> IO FilePath
 619 getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
 620   = do mapping <- readIORef v_DirsToClean
 621        case lookupFM mapping tmp_dir of
 622            Nothing ->
 623                do x <- getProcessID
 624                   let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
 625                   let
 626                       mkTempDir :: Integer -> IO FilePath
 627                       mkTempDir x
 628                        = let dirname = prefix ++ show x
 629                          in do createDirectory dirname
 630                                let mapping' = addToFM mapping tmp_dir dirname
 631                                writeIORef v_DirsToClean mapping'
 632                                debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
 633                                return dirname
 634                             `IO.catch` \e ->
 635                                     if isAlreadyExistsError e
 636                                     then mkTempDir (x+1)
 637                                     else ioError e
 638                   mkTempDir 0
 639            Just d -> return d
 640
 641 addFilesToClean :: [FilePath] -> IO ()
 642 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
 643 addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
 644
 645 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
 646 removeTmpDirs dflags ds
 647   = traceCmd dflags "Deleting temp dirs"
 648              ("Deleting: " ++ unwords ds)
 649              (mapM_ (removeWith dflags removeDirectory) ds)
 650
 651 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
 652 removeTmpFiles dflags fs
 653   = warnNon $
 654     traceCmd dflags "Deleting temp files"
 655              ("Deleting: " ++ unwords deletees)
 656              (mapM_ (removeWith dflags removeFile) deletees)
 657   where
 658      -- Flat out refuse to delete files that are likely to be source input
 659      -- files (is there a worse bug than having a compiler delete your source
 660      -- files?)
 661      --
 662      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
 663      -- the condition.
 664     warnNon act
 665      | null non_deletees = act
 666      | otherwise         = do
 667         putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
 668         act
 669
 670     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
 671
 672 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
 673 removeWith dflags remover f = remover f `IO.catch`
 674   (\e ->
 675    let msg = if isDoesNotExistError e
 676              then ptext SLIT("Warning: deleting non-existent") <+> text f
 677              else ptext SLIT("Warning: exception raised when deleting")
 678                                             <+> text f <> colon
 679                $$ text (show e)
 680    in debugTraceMsg dflags 2 msg
 681   )
 682
 683 -----------------------------------------------------------------------------
 684 -- Running an external program
 685
 686 runSomething :: DynFlags
 687              -> String          -- For -v message
 688              -> String          -- Command name (possibly a full path)
 689                                 --      assumed already dos-ified
 690              -> [Option]        -- Arguments
 691                                 --      runSomething will dos-ify them
 692              -> IO ()
 693
 694 runSomething dflags phase_name pgm args =
 695   runSomethingFiltered dflags id phase_name pgm args Nothing
 696
 697 runSomethingFiltered
 698   :: DynFlags -> (String->String) -> String -> String -> [Option]
 699   -> Maybe [(String,String)] -> IO ()
 700
 701 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
 702   let real_args = filter notNull (map showOpt args)
 703   traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
 704   (exit_code, doesn'tExist) <-
 705      IO.catch (do
 706          rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
 707          case rc of
 708            ExitSuccess{} -> return (rc, False)
 709            ExitFailure n
 710              -- rawSystem returns (ExitFailure 127) if the exec failed for any
 711              -- reason (eg. the program doesn't exist).  This is the only clue
 712              -- we have, but we need to report something to the user because in
 713              -- the case of a missing program there will otherwise be no output
 714              -- at all.
 715             | n == 127  -> return (rc, True)
 716             | otherwise -> return (rc, False))
 717                 -- Should 'rawSystem' generate an IO exception indicating that
 718                 -- 'pgm' couldn't be run rather than a funky return code, catch
 719                 -- this here (the win32 version does this, but it doesn't hurt
 720                 -- to test for this in general.)
 721               (\ err ->
 722                 if IO.isDoesNotExistError err
 723 #if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
 724                 -- the 'compat' version of rawSystem under mingw32 always
 725                 -- maps 'errno' to EINVAL to failure.
 726                    || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
 727 #endif
 728                  then return (ExitFailure 1, True)
 729                  else IO.ioError err)
 730   case (doesn'tExist, exit_code) of
 731      (True, _)        -> throwDyn (InstallationError ("could not execute: " ++ pgm))
 732      (_, ExitSuccess) -> return ()
 733      _                -> throwDyn (PhaseFailed phase_name exit_code)
 734
 735
 736
 737 #if __GLASGOW_HASKELL__ < 603
 738 builderMainLoop dflags filter_fn pgm real_args mb_env = do
 739   rawSystem pgm real_args
 740 #else
 741 builderMainLoop dflags filter_fn pgm real_args mb_env = do
 742   chan <- newChan
 743   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
 744
 745   -- and run a loop piping the output from the compiler to the log_action in DynFlags
 746   hSetBuffering hStdOut LineBuffering
 747   hSetBuffering hStdErr LineBuffering
 748   forkIO (readerProc chan hStdOut filter_fn)
 749   forkIO (readerProc chan hStdErr filter_fn)
 750   -- we don't want to finish until 2 streams have been completed
 751   -- (stdout and stderr)
 752   -- nor until 1 exit code has been retrieved.
 753   rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
 754   -- after that, we're done here.
 755   hClose hStdIn
 756   hClose hStdOut
 757   hClose hStdErr
 758   return rc
 759   where
 760     -- status starts at zero, and increments each time either
 761     -- a reader process gets EOF, or the build proc exits.  We wait
 762     -- for all of these to happen (status==3).
 763     -- ToDo: we should really have a contingency plan in case any of
 764     -- the threads dies, such as a timeout.
 765     loop chan hProcess 0 0 exitcode = return exitcode
 766     loop chan hProcess t p exitcode = do
 767       mb_code <- if p > 0
 768                    then getProcessExitCode hProcess
 769                    else return Nothing
 770       case mb_code of
 771         Just code -> loop chan hProcess t (p-1) code
 772         Nothing
 773           | t > 0 -> do
 774               msg <- readChan chan
 775               case msg of
 776                 BuildMsg msg -> do
 777                   log_action dflags SevInfo noSrcSpan defaultUserStyle msg
 778                   loop chan hProcess t p exitcode
 779                 BuildError loc msg -> do
 780                   log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
 781                   loop chan hProcess t p exitcode
 782                 EOF ->
 783                   loop chan hProcess (t-1) p exitcode
 784           | otherwise -> loop chan hProcess t p exitcode
 785
 786 readerProc chan hdl filter_fn =
 787     (do str <- hGetContents hdl
 788         loop (linesPlatform (filter_fn str)) Nothing)
 789     `finally`
 790        writeChan chan EOF
 791         -- ToDo: check errors more carefully
 792         -- ToDo: in the future, the filter should be implemented as
 793         -- a stream transformer.
 794     where
 795         loop []     Nothing    = return ()
 796         loop []     (Just err) = writeChan chan err
 797         loop (l:ls) in_err     =
 798                 case in_err of
 799                   Just err@(BuildError srcLoc msg)
 800                     | leading_whitespace l -> do
 801                         loop ls (Just (BuildError srcLoc (msg $$ text l)))
 802                     | otherwise -> do
 803                         writeChan chan err
 804                         checkError l ls
 805                   Nothing -> do
 806                         checkError l ls
 807
 808         checkError l ls
 809            = case parseError l of
 810                 Nothing -> do
 811                     writeChan chan (BuildMsg (text l))
 812                     loop ls Nothing
 813                 Just (file, lineNum, colNum, msg) -> do
 814                     let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
 815                     loop ls (Just (BuildError srcLoc (text msg)))
 816
 817         leading_whitespace []    = False
 818         leading_whitespace (x:_) = isSpace x
 819
 820 parseError :: String -> Maybe (String, Int, Int, String)
 821 parseError s0 = case breakColon s0 of
 822                 Just (filename, s1) ->
 823                     case breakIntColon s1 of
 824                     Just (lineNum, s2) ->
 825                         case breakIntColon s2 of
 826                         Just (columnNum, s3) ->
 827                             Just (filename, lineNum, columnNum, s3)
 828                         Nothing ->
 829                             Just (filename, lineNum, 0, s2)
 830                     Nothing -> Nothing
 831                 Nothing -> Nothing
 832
 833 breakColon :: String -> Maybe (String, String)
 834 breakColon xs = case break (':' ==) xs of
 835                     (ys, _:zs) -> Just (ys, zs)
 836                     _ -> Nothing
 837
 838 breakIntColon :: String -> Maybe (Int, String)
 839 breakIntColon xs = case break (':' ==) xs of
 840                        (ys, _:zs)
 841                         | not (null ys) && all isAscii ys && all isDigit ys ->
 842                            Just (read ys, zs)
 843                        _ -> Nothing
 844
 845 data BuildMessage
 846   = BuildMsg   !SDoc
 847   | BuildError !SrcLoc !SDoc
 848   | EOF
 849 #endif
 850
 851 showOpt (FileOption pre f) = pre ++ platformPath f
 852 showOpt (Option "") = ""
 853 showOpt (Option s)  = s
 854
 855 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
 856 -- a) trace the command (at two levels of verbosity)
 857 -- b) don't do it at all if dry-run is set
 858 traceCmd dflags phase_name cmd_line action
 859  = do   { let verb = verbosity dflags
 860         ; showPass dflags phase_name
 861         ; debugTraceMsg dflags 3 (text cmd_line)
 862         ; hFlush stderr
 863
 864            -- Test for -n flag
 865         ; unless (dopt Opt_DryRun dflags) $ do {
 866
 867            -- And run it!
 868         ; action `IO.catch` handle_exn verb
 869         }}
 870   where
 871     handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
 872                              ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
 873                              ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
 874 \end{code}
 875
 876 %************************************************************************
 877 %*                                                                      *
 878 \subsection{Support code}
 879 %*                                                                      *
 880 %************************************************************************
 881
 882 \begin{code}
 883 -----------------------------------------------------------------------------
 884 -- Define       getBaseDir     :: IO (Maybe String)
 885
 886 getBaseDir :: IO (Maybe String)
 887 #if defined(mingw32_HOST_OS)
 888 -- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
 889 -- return the path $(stuff).  Note that we drop the "bin/" directory too.
 890 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 891                 buf <- mallocArray len
 892                 ret <- getModuleFileName nullPtr buf len
 893                 if ret == 0 then free buf >> return Nothing
 894                             else do s <- peekCString buf
 895                                     free buf
 896                                     return (Just (rootDir s))
 897   where
 898     rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
 899
 900 foreign import stdcall unsafe "GetModuleFileNameA"
 901   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 902 #else
 903 getBaseDir = return Nothing
 904 #endif
 905
 906 #ifdef mingw32_HOST_OS
 907 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
 908 #else
 909 getProcessID :: IO Int
 910 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
 911 #endif
 912
 913 -- Divvy up text stream into lines, taking platform dependent
 914 -- line termination into account.
 915 linesPlatform :: String -> [String]
 916 #if !defined(mingw32_HOST_OS)
 917 linesPlatform ls = lines ls
 918 #else
 919 linesPlatform "" = []
 920 linesPlatform xs =
 921   case lineBreak xs of
 922     (as,xs1) -> as : linesPlatform xs1
 923   where
 924    lineBreak "" = ("","")
 925    lineBreak ('\r':'\n':xs) = ([],xs)
 926    lineBreak ('\n':xs) = ([],xs)
 927    lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
 928
 929 #endif
 930
 931 \end{code}