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