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