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