compiler/main/SysTools.lhs

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