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