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