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