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