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