compiler/main/SysTools.lhs

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