compiler/main/SysTools.lhs

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