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