compiler/main/SysTools.lhs

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