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