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