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