SysTools.hs 64 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
{-
2
-----------------------------------------------------------------------------
3
--
4
-- (c) The University of Glasgow 2001-2003
5
--
6
-- Access to system tools: gcc, cp, rm etc
7 8
--
-----------------------------------------------------------------------------
Austin Seipp's avatar
Austin Seipp committed
9
-}
10

11 12
{-# LANGUAGE CPP, ScopedTypeVariables #-}

13
module SysTools (
Ian Lynagh's avatar
Ian Lynagh committed
14 15 16 17 18 19
        -- Initialisation
        initSysTools,

        -- Interface to system tools
        runUnlit, runCpp, runCc, -- [Option] -> IO ()
        runPp,                   -- [Option] -> IO ()
20
        runSplit,                -- [Option] -> IO ()
21
        runAs, runLink, runLibtool, -- [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
22
        runMkDLL,
23
        runWindres,
24 25
        runLlvmOpt,
        runLlvmLlc,
26
        runClang,
27
        figureLlvmVersion,
28
        readElfSection,
29

30
        getLinkerInfo,
Austin Seipp's avatar
Austin Seipp committed
31
        getCompilerInfo,
32

33 34
        linkDynLib,

35 36
        askCc,

Ian Lynagh's avatar
Ian Lynagh committed
37 38
        touch,                  -- String -> String -> IO ()
        copy,
39
        copyWithHeader,
40

Ian Lynagh's avatar
Ian Lynagh committed
41 42
        -- Temporary-file management
        setTmpDir,
Peter Trommler's avatar
Peter Trommler committed
43
        newTempName, newTempLibName,
Ian Lynagh's avatar
Ian Lynagh committed
44 45 46 47
        cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
        addFilesToClean,

        Option(..)
48 49 50

 ) where

51 52
#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
53
import DriverPhases
54 55
import Module
import Packages
56
import Config
57
import Outputable
Simon Marlow's avatar
Simon Marlow committed
58 59
import ErrUtils
import Panic
60
import Platform
Simon Marlow's avatar
Simon Marlow committed
61 62
import Util
import DynFlags
63
import Exception
64

Simon Marlow's avatar
Simon Marlow committed
65 66 67 68
import Data.IORef
import Control.Monad
import System.Exit
import System.Environment
Ian Lynagh's avatar
Ian Lynagh committed
69
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
70
import System.IO
71
import System.IO.Error as IO
Simon Marlow's avatar
Simon Marlow committed
72
import System.Directory
73
import Data.Char
Simon Marlow's avatar
Simon Marlow committed
74
import Data.List
75
import qualified Data.Map as Map
76 77
import Text.ParserCombinators.ReadP hiding (char)
import qualified Text.ParserCombinators.ReadP as R
78

79
#ifndef mingw32_HOST_OS
80
import qualified System.Posix.Internals
81
#else /* Must be Win32 */
sof's avatar
sof committed
82
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
83
import Foreign.C.String
rrt's avatar
rrt committed
84 85
#endif

86
import System.Process
Ian Lynagh's avatar
Ian Lynagh committed
87
import Control.Concurrent
88
import FastString
89
import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
90 91 92 93 94 95 96 97 98 99

#ifdef mingw32_HOST_OS
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif
#endif
100

Austin Seipp's avatar
Austin Seipp committed
101
{-
102 103
How GHC finds its files
~~~~~~~~~~~~~~~~~~~~~~~
104

105
[Note topdir]
106 107

GHC needs various support files (library packages, RTS etc), plus
Ian Lynagh's avatar
Ian Lynagh committed
108 109
various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,
the root of GHC's support files
110

111 112
On Unix:
  - ghc always has a shell wrapper that passes a -B<dir> option
113

114 115 116
On Windows:
  - ghc never has a shell wrapper.
  - we can find the location of the ghc binary, which is
Ian Lynagh's avatar
Ian Lynagh committed
117 118 119
        $topdir/bin/<something>.exe
    where <something> may be "ghc", "ghc-stage2", or similar
  - we strip off the "bin/<something>.exe" to leave $topdir.
120

Ian Lynagh's avatar
Ian Lynagh committed
121
from topdir we can find package.conf, ghc-asm, etc.
122 123 124 125 126 127 128 129 130


SysTools.initSysProgs figures out exactly where all the auxiliary programs
are, and initialises mutable variables to make it easy to call them.
To to this, it makes use of definitions in Config.hs, which is a Haskell
file containing variables whose value is figured out by the build system.

Config.hs contains two sorts of things

Ian Lynagh's avatar
Ian Lynagh committed
131 132 133 134 135
  cGCC,         The *names* of the programs
  cCPP            e.g.  cGCC = gcc
  cUNLIT                cCPP = gcc -E
  etc           They do *not* include paths

136

Ian Lynagh's avatar
Ian Lynagh committed
137 138
  cUNLIT_DIR   The *path* to the directory containing unlit, split etc
  cSPLIT_DIR   *relative* to the root of the build tree,
Ian Lynagh's avatar
Ian Lynagh committed
139 140
                   for use when running *in-place* in a build tree (only)

141 142


143 144 145 146 147 148 149 150 151 152 153 154 155 156
---------------------------------------------
NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):

Another hair-brained scheme for simplifying the current tool location
nightmare in GHC: Simon originally suggested using another
configuration file along the lines of GCC's specs file - which is fine
except that it means adding code to read yet another configuration
file.  What I didn't notice is that the current package.conf is
general enough to do this:

Package
    {name = "tools",    import_dirs = [],  source_dirs = [],
     library_dirs = [], hs_libraries = [], extra_libraries = [],
     include_dirs = [], c_includes = [],   package_deps = [],
157
     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
158 159 160 161 162
     extra_cc_opts = [], extra_ld_opts = []}

Which would have the advantage that we get to collect together in one
place the path-specific package stuff with the path-specific tool
stuff.
Ian Lynagh's avatar
Ian Lynagh committed
163
                End of NOTES
164 165
---------------------------------------------

Austin Seipp's avatar
Austin Seipp committed
166 167
************************************************************************
*                                                                      *
168
\subsection{Initialisation}
Austin Seipp's avatar
Austin Seipp committed
169 170 171
*                                                                      *
************************************************************************
-}
172

Ian Lynagh's avatar
Ian Lynagh committed
173
initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
174
             -> IO Settings     -- Set all the mutable variables above, holding
Ian Lynagh's avatar
Ian Lynagh committed
175 176 177
                                --      (a) the system programs
                                --      (b) the package-config file
                                --      (c) the GHC usage message
178
initSysTools mbMinusB
179 180 181 182 183 184
  = do top_dir <- findTopDir mbMinusB
             -- see [Note topdir]
             -- NB: top_dir is assumed to be in standard Unix
             -- format, '/' separated

       let settingsFile = top_dir </> "settings"
185
           platformConstantsFile = top_dir </> "platformConstants"
186 187 188 189
           installed :: FilePath -> FilePath
           installed file = top_dir </> file

       settingsStr <- readFile settingsFile
190
       platformConstantsStr <- readFile platformConstantsFile
191 192 193 194 195
       mySettings <- case maybeReadFuzzy settingsStr of
                     Just s ->
                         return s
                     Nothing ->
                         pgmError ("Can't parse " ++ show settingsFile)
196 197 198 199 200 201
       platformConstants <- case maybeReadFuzzy platformConstantsStr of
                            Just s ->
                                return s
                            Nothing ->
                                pgmError ("Can't parse " ++
                                          show platformConstantsFile)
202 203 204 205 206 207 208 209 210 211 212
       let getSetting key = case lookup key mySettings of
                            Just xs ->
                                return $ case stripPrefix "$topdir" xs of
                                         Just [] ->
                                             top_dir
                                         Just xs'@(c:_)
                                          | isPathSeparator c ->
                                             top_dir ++ xs'
                                         _ ->
                                             xs
                            Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
213 214 215 216 217
           getBooleanSetting key = case lookup key mySettings of
                                   Just "YES" -> return True
                                   Just "NO" -> return False
                                   Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)
                                   Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
218 219 220 221 222 223
           readSetting key = case lookup key mySettings of
                             Just xs ->
                                 case maybeRead xs of
                                 Just v -> return v
                                 Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
                             Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
224
       crossCompiling <- getBooleanSetting "cross compiling"
225 226 227
       targetArch <- readSetting "target arch"
       targetOS <- readSetting "target os"
       targetWordSize <- readSetting "target word size"
228
       targetUnregisterised <- getBooleanSetting "Unregisterised"
229 230 231 232 233 234 235 236 237 238 239
       targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
       targetHasIdentDirective <- readSetting "target has .ident directive"
       targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
       myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
       -- On Windows, mingw is distributed with GHC,
       -- so we look in TopDir/../mingw/bin
       -- It would perhaps be nice to be able to override this
       -- with the settings file, but it would be a little fiddly
       -- to make that possible, so for now you can't.
       gcc_prog <- getSetting "C compiler command"
       gcc_args_str <- getSetting "C compiler flags"
240 241
       cpp_prog <- getSetting "Haskell CPP command"
       cpp_args_str <- getSetting "Haskell CPP flags"
242 243 244
       let unreg_gcc_args = if targetUnregisterised
                            then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
                            else []
245 246
           -- TABLES_NEXT_TO_CODE affects the info table layout.
           tntc_gcc_args
247 248 249
            | mkTablesNextToCode targetUnregisterised
               = ["-DTABLES_NEXT_TO_CODE"]
            | otherwise = []
250
           cpp_args= map Option (words cpp_args_str)
251 252 253
           gcc_args = map Option (words gcc_args_str
                               ++ unreg_gcc_args
                               ++ tntc_gcc_args)
254 255
       ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
       ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
256
       ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"
257
       ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
258 259 260 261 262 263 264 265 266 267 268 269 270 271
       perl_path <- getSetting "perl command"

       let pkgconfig_path = installed "package.conf.d"
           ghc_usage_msg_path  = installed "ghc-usage.txt"
           ghci_usage_msg_path = installed "ghci-usage.txt"

             -- For all systems, unlit, split, mangle are GHC utilities
             -- architecture-specific stuff is done when building Config.hs
           unlit_path = installed cGHC_UNLIT_PGM

             -- split is a Perl script
           split_script  = installed cGHC_SPLIT_PGM

       windres_path <- getSetting "windres command"
272
       libtool_path <- getSetting "libtool command"
273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292

       tmpdir <- getTemporaryDirectory

       touch_path <- getSetting "touch command"

       let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
           -- a call to Perl to get the invocation of split.
           -- On Unix, scripts are invoked using the '#!' method.  Binary
           -- installations of GHC on Unix place the correct line on the
           -- front of the script at installation time, so we don't want
           -- to wire-in our knowledge of $(PERL) on the host system here.
           (split_prog,  split_args)
             | isWindowsHost = (perl_path,    [Option split_script])
             | otherwise     = (split_script, [])
       mkdll_prog <- getSetting "dllwrap command"
       let mkdll_args = []

       -- cpp is derived from gcc on all platforms
       -- HACK, see setPgmP below. We keep 'words' here to remember to fix
       -- Config.hs one day.
293

294 295

       -- Other things being equal, as and ld are simply gcc
296
       gcc_link_args_str <- getSetting "C compiler link flags"
297 298 299
       let   as_prog  = gcc_prog
             as_args  = gcc_args
             ld_prog  = gcc_prog
300
             ld_args  = gcc_args ++ map Option (words gcc_link_args_str)
301 302 303 304 305 306 307 308 309

       -- We just assume on command line
       lc_prog <- getSetting "LLVM llc command"
       lo_prog <- getSetting "LLVM opt command"

       let platform = Platform {
                          platformArch = targetArch,
                          platformOS   = targetOS,
                          platformWordSize = targetWordSize,
310
                          platformUnregisterised = targetUnregisterised,
311 312
                          platformHasGnuNonexecStack = targetHasGnuNonexecStack,
                          platformHasIdentDirective = targetHasIdentDirective,
313 314
                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,
                          platformIsCrossCompiling = crossCompiling
315 316 317 318 319 320 321 322 323 324 325
                      }

       return $ Settings {
                    sTargetPlatform = platform,
                    sTmpDir         = normalise tmpdir,
                    sGhcUsagePath   = ghc_usage_msg_path,
                    sGhciUsagePath  = ghci_usage_msg_path,
                    sTopDir         = top_dir,
                    sRawSettings    = mySettings,
                    sExtraGccViaCFlags = words myExtraGccViaCFlags,
                    sSystemPackageConfig = pkgconfig_path,
326 327
                    sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
                    sLdSupportsBuildId       = ldSupportsBuildId,
328
                    sLdSupportsFilelist      = ldSupportsFilelist,
329
                    sLdIsGnuLd               = ldIsGnuLd,
330 331
                    sProgramName             = "ghc",
                    sProjectVersion          = cProjectVersion,
332 333 334 335 336 337 338 339 340 341 342
                    sPgm_L   = unlit_path,
                    sPgm_P   = (cpp_prog, cpp_args),
                    sPgm_F   = "",
                    sPgm_c   = (gcc_prog, gcc_args),
                    sPgm_s   = (split_prog,split_args),
                    sPgm_a   = (as_prog, as_args),
                    sPgm_l   = (ld_prog, ld_args),
                    sPgm_dll = (mkdll_prog,mkdll_args),
                    sPgm_T   = touch_path,
                    sPgm_sysman  = top_dir ++ "/ghc/rts/parallel/SysMan",
                    sPgm_windres = windres_path,
343
                    sPgm_libtool = libtool_path,
344 345 346 347 348 349 350 351 352 353 354 355
                    sPgm_lo  = (lo_prog,[]),
                    sPgm_lc  = (lc_prog,[]),
                    -- Hans: this isn't right in general, but you can
                    -- elaborate it in the same way as the others
                    sOpt_L       = [],
                    sOpt_P       = [],
                    sOpt_F       = [],
                    sOpt_c       = [],
                    sOpt_a       = [],
                    sOpt_l       = [],
                    sOpt_windres = [],
                    sOpt_lo      = [],
356 357
                    sOpt_lc      = [],
                    sPlatformConstants = platformConstants
358
             }
359

Ian Lynagh's avatar
Ian Lynagh committed
360 361 362 363 364 365 366 367 368
-- returns a Unix-format path (relying on getBaseDir to do so too)
findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
           -> IO String    -- TopDir (in Unix format '/' separated)
findTopDir (Just minusb) = return (normalise minusb)
findTopDir Nothing
    = do -- Get directory of executable
         maybe_exec_dir <- getBaseDir
         case maybe_exec_dir of
             -- "Just" on Windows, "Nothing" on unix
369
             Nothing  -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
Ian Lynagh's avatar
Ian Lynagh committed
370
             Just dir -> return dir
371

Austin Seipp's avatar
Austin Seipp committed
372 373 374
{-
************************************************************************
*                                                                      *
375
\subsection{Running an external program}
Austin Seipp's avatar
Austin Seipp committed
376 377 378
*                                                                      *
************************************************************************
-}
379

380
runUnlit :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
381
runUnlit dflags args = do
382 383 384 385
  let prog = pgm_L dflags
      opts = getOpts dflags opt_L
  runSomething dflags "Literate pre-processor" prog
               (map Option opts ++ args)
386 387

runCpp :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
388
runCpp dflags args =   do
389
  let (p,args0) = pgm_P dflags
390
      args1 = map Option (getOpts dflags opt_P)
ian@well-typed.com's avatar
ian@well-typed.com committed
391
      args2 = if gopt Opt_WarnIsError dflags
392 393
                 then [Option "-Werror"]
                 else []
394
  mb_env <- getGccEnv args2
395 396
  runSomethingFiltered dflags id  "C pre-processor" p
                       (args0 ++ args1 ++ args2 ++ args) mb_env
397 398

runPp :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
399
runPp dflags args =   do
400 401
  let prog = pgm_F dflags
      opts = map Option (getOpts dflags opt_F)
402
  runSomething dflags "Haskell pre-processor" prog (args ++ opts)
403 404

runCc :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
405
runCc dflags args =   do
406
  let (p,args0) = pgm_c dflags
407 408 409 410
      args1 = map Option (getOpts dflags opt_c)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
  runSomethingFiltered dflags cc_filter "C Compiler" p args2 mb_env
411 412
 where
  -- discard some harmless warnings from gcc that we can't turn off
413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463
  cc_filter = unlines . doFilter . lines

  {-
  gcc gives warnings in chunks like so:
      In file included from /foo/bar/baz.h:11,
                       from /foo/bar/baz2.h:22,
                       from wibble.c:33:
      /foo/flibble:14: global register variable ...
      /foo/flibble:15: warning: call-clobbered r...
  We break it up into its chunks, remove any call-clobbered register
  warnings from each chunk, and then delete any chunks that we have
  emptied of warnings.
  -}
  doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
  -- We can't assume that the output will start with an "In file inc..."
  -- line, so we start off expecting a list of warnings rather than a
  -- location stack.
  chunkWarnings :: [String] -- The location stack to use for the next
                            -- list of warnings
                -> [String] -- The remaining lines to look at
                -> [([String], [String])]
  chunkWarnings loc_stack [] = [(loc_stack, [])]
  chunkWarnings loc_stack xs
      = case break loc_stack_start xs of
        (warnings, lss:xs') ->
            case span loc_start_continuation xs' of
            (lsc, xs'') ->
                (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
        _ -> [(loc_stack, xs)]

  filterWarnings :: [([String], [String])] -> [([String], [String])]
  filterWarnings [] = []
  -- If the warnings are already empty then we are probably doing
  -- something wrong, so don't delete anything
  filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
  filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
                                       [] -> filterWarnings zs
                                       ys' -> (xs, ys') : filterWarnings zs

  unChunkWarnings :: [([String], [String])] -> [String]
  unChunkWarnings [] = []
  unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs

  loc_stack_start        s = "In file included from " `isPrefixOf` s
  loc_start_continuation s = "                 from " `isPrefixOf` s
  wantedWarning w
   | "warning: call-clobbered register used" `isContainedIn` w = False
   | otherwise = True

isContainedIn :: String -> String -> Bool
xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
464

465 466 467
askCc :: DynFlags -> [Option] -> IO String
askCc dflags args = do
  let (p,args0) = pgm_c dflags
468 469 470 471
      args1 = map Option (getOpts dflags opt_c)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
  runSomethingWith dflags "gcc" p args2 $ \real_args ->
thomie's avatar
thomie committed
472
    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
473

thomie's avatar
thomie committed
474 475 476
-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
-- inherited from the parent process, and output to stderr is not captured.
readCreateProcessWithExitCode'
477 478
    :: CreateProcess
    -> IO (ExitCode, String)    -- ^ stdout
thomie's avatar
thomie committed
479
readCreateProcessWithExitCode' proc = do
480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496
    (_, Just outh, _, pid) <-
        createProcess proc{ std_out = CreatePipe }

    -- fork off a thread to start consuming the output
    output  <- hGetContents outh
    outMVar <- newEmptyMVar
    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()

    -- wait on the output
    takeMVar outMVar
    hClose outh

    -- wait on the process
    ex <- waitForProcess pid

    return (ex, output)

497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541
readProcessEnvWithExitCode
    :: String -- ^ program path
    -> [String] -- ^ program args
    -> [(String, String)] -- ^ environment to override
    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
readProcessEnvWithExitCode prog args env_update = do
    current_env <- getEnvironment
    let new_env = env_update ++ [ (k, v)
                                | let overriden_keys = map fst env_update
                                , (k, v) <- current_env
                                , k `notElem` overriden_keys
                                ]
        p       = proc prog args

    (_stdin, Just stdoh, Just stdeh, pid) <-
        createProcess p{ std_out = CreatePipe
                       , std_err = CreatePipe
                       , env     = Just new_env
                       }

    outMVar <- newEmptyMVar
    errMVar <- newEmptyMVar

    _ <- forkIO $ do
        stdo <- hGetContents stdoh
        _ <- evaluate (length stdo)
        putMVar outMVar stdo

    _ <- forkIO $ do
        stde <- hGetContents stdeh
        _ <- evaluate (length stde)
        putMVar errMVar stde

    out <- takeMVar outMVar
    hClose stdoh
    err <- takeMVar errMVar
    hClose stdeh

    ex <- waitForProcess pid

    return (ex, out, err)

-- Don't let gcc localize version info string, #8825
en_locale_env :: [(String, String)]
en_locale_env = [("LANGUAGE", "en")]
542

543 544 545 546
-- If the -B<dir> option is set, add <dir> to PATH.  This works around
-- a bug in gcc on Windows Vista where it can't find its auxiliary
-- binaries (see bug #1110).
getGccEnv :: [Option] -> IO (Maybe [(String,String)])
Ian Lynagh's avatar
Ian Lynagh committed
547
getGccEnv opts =
548
  if null b_dirs
549
     then return Nothing
550
     else do env <- getEnvironment
551
             return (Just (map mangle_path env))
552
 where
553
  (b_dirs, _) = partitionWith get_b_opt opts
554 555

  get_b_opt (Option ('-':'B':dir)) = Left dir
Ian Lynagh's avatar
Ian Lynagh committed
556
  get_b_opt other = Right other
557

Ian Lynagh's avatar
Ian Lynagh committed
558
  mangle_path (path,paths) | map toUpper path == "PATH"
559
        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
560
  mangle_path other = other
561

562
runSplit :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
563
runSplit dflags args = do
564
  let (p,args0) = pgm_s dflags
565 566 567
  runSomething dflags "Splitter" p (args0++args)

runAs :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
568
runAs dflags args = do
569
  let (p,args0) = pgm_a dflags
570 571 572 573
      args1 = map Option (getOpts dflags opt_a)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
  runSomethingFiltered dflags id "Assembler" p args2 mb_env
574

575
-- | Run the LLVM Optimiser
576 577 578
runLlvmOpt :: DynFlags -> [Option] -> IO ()
runLlvmOpt dflags args = do
  let (p,args0) = pgm_lo dflags
579 580
      args1 = map Option (getOpts dflags opt_lo)
  runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args)
581

582
-- | Run the LLVM Compiler
583 584 585
runLlvmLlc :: DynFlags -> [Option] -> IO ()
runLlvmLlc dflags args = do
  let (p,args0) = pgm_lc dflags
586 587
      args1 = map Option (getOpts dflags opt_lc)
  runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
588

589 590 591 592 593 594 595
-- | Run the clang compiler (used as an assembler for the LLVM
-- backend on OS X as LLVM doesn't support the OS X system
-- assembler)
runClang :: DynFlags -> [Option] -> IO ()
runClang dflags args = do
  -- we simply assume its available on the PATH
  let clang = "clang"
596 597 598
      -- be careful what options we call clang with
      -- see #5903 and #7617 for bugs caused by this.
      (_,args0) = pgm_a dflags
599 600 601
      args1 = map Option (getOpts dflags opt_a)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
602
  Exception.catch (do
603
        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env
604 605
    )
    (\(err :: SomeException) -> do
606 607 608 609
        errorMsg dflags $
            text ("Error running clang! you need clang installed to use the" ++
                "LLVM backend") $+$
            text "(or GHC tried to execute clang incorrectly)"
610
        throwIO err
611 612
    )

613 614 615 616 617 618 619 620 621 622 623 624 625
-- | Figure out which version of LLVM we are running this session
figureLlvmVersion :: DynFlags -> IO (Maybe Int)
figureLlvmVersion dflags = do
  let (pgm,opts) = pgm_lc dflags
      args = filter notNull (map showOpt opts)
      -- we grab the args even though they should be useless just in
      -- case the user is using a customised 'llc' that requires some
      -- of the options they've specified. llc doesn't care what other
      -- options are specified when '-version' is used.
      args' = args ++ ["-version"]
  ver <- catchIO (do
             (pin, pout, perr, _) <- runInteractiveProcess pgm args'
                                             Nothing Nothing
dterei's avatar
dterei committed
626
             {- > llc -version
627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643
                  Low Level Virtual Machine (http://llvm.org/):
                    llvm version 2.8 (Ubuntu 2.8-0Ubuntu1)
                    ...
             -}
             hSetBinaryMode pout False
             _     <- hGetLine pout
             vline <- hGetLine pout
             v     <- case filter isDigit vline of
                            []      -> fail "no digits!"
                            [x]     -> fail $ "only 1 digit! (" ++ show x ++ ")"
                            (x:y:_) -> return ((read [x,y]) :: Int)
             hClose pin
             hClose pout
             hClose perr
             return $ Just v
            )
            (\err -> do
644 645 646
                debugTraceMsg dflags 2
                    (text "Error (figuring out LLVM version):" <+>
                     text (show err))
647
                errorMsg dflags $ vcat
648 649 650
                    [ text "Warning:", nest 9 $
                          text "Couldn't figure out LLVM version!" $$
                          text "Make sure you have installed LLVM"]
651 652
                return Nothing)
  return ver
653

Austin Seipp's avatar
Austin Seipp committed
654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689
{- Note [Windows stack usage]

See: Trac #8870 (and #8834 for related info)

On Windows, occasionally we need to grow the stack. In order to do
this, we would normally just bump the stack pointer - but there's a
catch on Windows.

If the stack pointer is bumped by more than a single page, then the
pages between the initial pointer and the resulting location must be
properly committed by the Windows virtual memory subsystem. This is
only needed in the event we bump by more than one page (i.e 4097 bytes
or more).

Windows compilers solve this by emitting a call to a special function
called _chkstk, which does this committing of the pages for you.

The reason this was causing a segfault was because due to the fact the
new code generator tends to generate larger functions, we needed more
stack space in GHC itself. In the x86 codegen, we needed approximately
~12kb of stack space in one go, which caused the process to segfault,
as the intervening pages were not committed.

In the future, we should do the same thing, to make the problem
completely go away. In the mean time, we're using a workaround: we
instruct the linker to specify the generated PE as having an initial
reserved stack size of 8mb, as well as a initial *committed* stack
size of 8mb. The default committed size was previously only 4k.

Theoretically it's possible to still hit this problem if you request a
stack bump of more than 8mb in one go. But the amount of code
necessary is quite large, and 8mb "should be more than enough for
anyone" right now (he said, before millions of lines of code cried out
in terror).

-}
690 691 692

{- Note [Run-time linker info]

693
See also: Trac #5240, Trac #6063, Trac #10110
694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719

Before 'runLink', we need to be sure to get the relevant information
about the linker we're using at runtime to see if we need any extra
options. For example, GNU ld requires '--reduce-memory-overheads' and
'--hash-size=31' in order to use reasonable amounts of memory (see
trac #5240.) But this isn't supported in GNU gold.

Generally, the linker changing from what was detected at ./configure
time has always been possible using -pgml, but on Linux it can happen
'transparently' by installing packages like binutils-gold, which
change what /usr/bin/ld actually points to.

Clang vs GCC notes:

For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
invoke the linker before the version information string. For 'clang',
the version information for 'ld' is all that's output. For this
reason, we typically need to slurp up all of the standard error output
and look through it.

Other notes:

We cache the LinkerInfo inside DynFlags, since clients may link
multiple times. The definition of LinkerInfo is there to avoid a
circular dependency.

720 721 722 723
-}

{- Note [ELF needed shared libs]

724 725 726 727 728 729 730
Some distributions change the link editor's default handling of
ELF DT_NEEDED tags to include only those shared objects that are
needed to resolve undefined symbols. For Template Haskell we need
the last temporary shared library also if it is not needed for the
currently linked temporary shared library. We specify --no-as-needed
to override the default. This flag exists in GNU ld and GNU gold.

731 732
The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
(Mach-O) the flag is not needed.
733

734
-}
735 736 737 738 739

neededLinkArgs :: LinkerInfo -> [Option]
neededLinkArgs (GnuLD o)     = o
neededLinkArgs (GnuGold o)   = o
neededLinkArgs (DarwinLD o)  = o
740
neededLinkArgs (SolarisLD o) = o
741 742 743 744 745
neededLinkArgs UnknownLD     = []

-- Grab linker info and cache it in DynFlags.
getLinkerInfo :: DynFlags -> IO LinkerInfo
getLinkerInfo dflags = do
Austin Seipp's avatar
Austin Seipp committed
746
  info <- readIORef (rtldInfo dflags)
747 748 749 750
  case info of
    Just v  -> return v
    Nothing -> do
      v <- getLinkerInfo' dflags
Austin Seipp's avatar
Austin Seipp committed
751
      writeIORef (rtldInfo dflags) (Just v)
752 753 754 755 756 757 758
      return v

-- See Note [Run-time linker info].
getLinkerInfo' :: DynFlags -> IO LinkerInfo
getLinkerInfo' dflags = do
  let platform = targetPlatform dflags
      os = platformOS platform
759 760 761 762
      (pgm,args0) = pgm_l dflags
      args1     = map Option (getOpts dflags opt_l)
      args2     = args0 ++ args1
      args3     = filter notNull (map showOpt args2)
763 764 765 766 767 768

      -- Try to grab the info from the process output.
      parseLinkerInfo stdo _stde _exitc
        | any ("GNU ld" `isPrefixOf`) stdo =
          -- GNU ld specifically needs to use less memory. This especially
          -- hurts on small object files. Trac #5240.
769
          -- Set DT_NEEDED for all shared libraries. Trac #10110.
770
          return (GnuLD $ map Option ["-Wl,--hash-size=31",
771
                                      "-Wl,--reduce-memory-overheads",
772 773
                                      -- ELF specific flag
                                      -- see Note [ELF needed shared libs]
774
                                      "-Wl,--no-as-needed"])
775 776

        | any ("GNU gold" `isPrefixOf`) stdo =
777
          -- GNU gold only needs --no-as-needed. Trac #10110.
778
          -- ELF specific flag, see Note [ELF needed shared libs]
779
          return (GnuGold [Option "-Wl,--no-as-needed"])
780 781 782 783 784 785 786

         -- Unknown linker.
        | otherwise = fail "invalid --version output, or linker is unsupported"

  -- Process the executable call
  info <- catchIO (do
             case os of
787 788
               OSSolaris2 ->
                 -- Solaris uses its own Solaris linker. Even all
Gabor Greif's avatar
Gabor Greif committed
789
                 -- GNU C are recommended to configure with Solaris
790 791 792 793 794
                 -- linker instead of using GNU binutils linker. Also
                 -- all GCC distributed with Solaris follows this rule
                 -- precisely so we assume here, the Solaris linker is
                 -- used.
                 return $ SolarisLD []
795 796 797 798 799
               OSDarwin ->
                 -- Darwin has neither GNU Gold or GNU LD, but a strange linker
                 -- that doesn't support --version. We can just assume that's
                 -- what we're using.
                 return $ DarwinLD []
Austin Seipp's avatar
Austin Seipp committed
800
               OSiOS ->
801 802
                 -- Ditto for iOS
                 return $ DarwinLD []
803 804 805 806
               OSMinGW32 ->
                 -- GHC doesn't support anything but GNU ld on Windows anyway.
                 -- Process creation is also fairly expensive on win32, so
                 -- we short-circuit here.
Austin Seipp's avatar
Austin Seipp committed
807 808 809 810 811 812 813
                 return $ GnuLD $ map Option
                   [ -- Reduce ld memory usage
                     "-Wl,--hash-size=31"
                   , "-Wl,--reduce-memory-overheads"
                     -- Increase default stack, see
                     -- Note [Windows stack usage]
                   , "-Xlinker", "--stack=0x800000,0x800000" ]
814 815 816
               _ -> do
                 -- In practice, we use the compiler as the linker here. Pass
                 -- -Wl,--version to get linker version info.
817
                 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
818
                                        (["-Wl,--version"] ++ args3)
819
                                        en_locale_env
820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835
                 -- Split the output by lines to make certain kinds
                 -- of processing easier. In particular, 'clang' and 'gcc'
                 -- have slightly different outputs for '-Wl,--version', but
                 -- it's still easy to figure out.
                 parseLinkerInfo (lines stdo) (lines stde) exitc
            )
            (\err -> do
                debugTraceMsg dflags 2
                    (text "Error (figuring out linker information):" <+>
                     text (show err))
                errorMsg dflags $ hang (text "Warning:") 9 $
                  text "Couldn't figure out linker information!" $$
                  text "Make sure you're using GNU ld, GNU gold" <+>
                  text "or the built in OS X linker, etc."
                return UnknownLD)
  return info
836

Austin Seipp's avatar
Austin Seipp committed
837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859
-- Grab compiler info and cache it in DynFlags.
getCompilerInfo :: DynFlags -> IO CompilerInfo
getCompilerInfo dflags = do
  info <- readIORef (rtccInfo dflags)
  case info of
    Just v  -> return v
    Nothing -> do
      v <- getCompilerInfo' dflags
      writeIORef (rtccInfo dflags) (Just v)
      return v

-- See Note [Run-time linker info].
getCompilerInfo' :: DynFlags -> IO CompilerInfo
getCompilerInfo' dflags = do
  let (pgm,_) = pgm_c dflags
      -- Try to grab the info from the process output.
      parseCompilerInfo _stdo stde _exitc
        -- Regular GCC
        | any ("gcc version" `isPrefixOf`) stde =
          return GCC
        -- Regular clang
        | any ("clang version" `isPrefixOf`) stde =
          return Clang
Austin Seipp's avatar
Austin Seipp committed
860 861 862
        -- XCode 5.1 clang
        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
          return AppleClang51
Austin Seipp's avatar
Austin Seipp committed
863 864
        -- XCode 5 clang
        | any ("Apple LLVM version" `isPrefixOf`) stde =
Austin Seipp's avatar
Austin Seipp committed
865
          return AppleClang
Austin Seipp's avatar
Austin Seipp committed
866 867
        -- XCode 4.1 clang
        | any ("Apple clang version" `isPrefixOf`) stde =
Austin Seipp's avatar
Austin Seipp committed
868
          return AppleClang
Austin Seipp's avatar
Austin Seipp committed
869 870 871 872 873
         -- Unknown linker.
        | otherwise = fail "invalid -v output, or compiler is unsupported"

  -- Process the executable call
  info <- catchIO (do
874 875
                (exitc, stdo, stde) <-
                    readProcessEnvWithExitCode pgm ["-v"] en_locale_env
Austin Seipp's avatar
Austin Seipp committed
876 877 878 879 880 881
                -- Split the output by lines to make certain kinds
                -- of processing easier.
                parseCompilerInfo (lines stdo) (lines stde) exitc
            )
            (\err -> do
                debugTraceMsg dflags 2
882
                    (text "Error (figuring out C compiler information):" <+>
Austin Seipp's avatar
Austin Seipp committed
883 884
                     text (show err))
                errorMsg dflags $ hang (text "Warning:") 9 $
885
                  text "Couldn't figure out C compiler information!" $$
Austin Seipp's avatar
Austin Seipp committed
886 887 888 889
                  text "Make sure you're using GNU gcc, or clang"
                return UnknownCC)
  return info

890
runLink :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
891
runLink dflags args = do
892 893
  -- See Note [Run-time linker info]
  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
894
  let (p,args0) = pgm_l dflags
895
      args1     = map Option (getOpts dflags opt_l)
896
      args2     = args0 ++ linkargs ++ args1 ++ args
897
  mb_env <- getGccEnv args2
898 899 900 901 902 903 904
  runSomethingFiltered dflags ld_filter "Linker" p args2 mb_env
  where
    ld_filter = case (platformOS (targetPlatform dflags)) of
                  OSSolaris2 -> sunos_ld_filter
                  _ -> id
{-
  SunOS/Solaris ld emits harmless warning messages about unresolved
Gabor Greif's avatar
Gabor Greif committed
905
  symbols in case of compiling into shared library when we do not
906 907
  link against all the required libs. That is the case of GHC which
  does not link against RTS library explicitly in order to be able to
Gabor Greif's avatar
Gabor Greif committed
908
  choose the library later based on binary application linking
909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931
  parameters. The warnings look like:

Undefined                       first referenced
 symbol                             in file
stg_ap_n_fast                       ./T2386_Lib.o
stg_upd_frame_info                  ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
newCAF                              ./T2386_Lib.o
stg_bh_upd_frame_info               ./T2386_Lib.o
stg_ap_ppp_fast                     ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
stg_ap_p_fast                       ./T2386_Lib.o
stg_ap_pp_fast                      ./T2386_Lib.o
ld: warning: symbol referencing errors

  this is actually coming from T2386 testcase. The emitting of those
  warnings is also a reason why so many TH testcases fail on Solaris.

  Following filter code is SunOS/Solaris linker specific and should
  filter out only linker warnings. Please note that the logic is a
Gabor Greif's avatar
Gabor Greif committed
932
  little bit more complex due to the simple reason that we need to preserve
933 934
  any other linker emitted messages. If there are any. Simply speaking
  if we see "Undefined" and later "ld: warning:..." then we omit all
Gabor Greif's avatar
Gabor Greif committed
935
  text between (including) the marks. Otherwise we copy the whole output.
936 937 938 939 940 941 942 943 944 945 946 947 948
-}
    sunos_ld_filter :: String -> String
    sunos_ld_filter = unlines . sunos_ld_filter' . lines
    sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
                         then (ld_prefix x) ++ (ld_postfix x)
                         else x
    breakStartsWith x y = break (isPrefixOf x) y
    ld_prefix = fst . breakStartsWith "Undefined"
    undefined_found = not . null . snd . breakStartsWith "Undefined"
    ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
    ld_postfix = tail . snd . ld_warn_break
    ld_warning_found = not . null . snd . ld_warn_break

949

950 951 952 953 954
runLibtool :: DynFlags -> [Option] -> IO ()
runLibtool dflags args = do
  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
  let args1      = map Option (getOpts dflags opt_l)
      args2      = [Option "-static"] ++ args1 ++ args ++ linkargs
Austin Seipp's avatar
Austin Seipp committed
955
      libtool    = pgm_libtool dflags
956 957 958
  mb_env <- getGccEnv args2
  runSomethingFiltered dflags id "Linker" libtool args2 mb_env

959 960
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = do
961
  let (p,args0) = pgm_dll dflags
962 963
      args1 = args0 ++ args
  mb_env <- getGccEnv (args0++args)
964
  runSomethingFiltered dflags id "Make DLL" p args1 mb_env
965

966 967
runWindres :: DynFlags -> [Option] -> IO ()
runWindres dflags args = do
968 969
  let (gcc, gcc_args) = pgm_c dflags
      windres = pgm_windres dflags
970
      opts = map Option (getOpts dflags opt_windres)
971 972 973 974 975 976 977
      quote x = "\"" ++ x ++ "\""
      args' = -- If windres.exe and gcc.exe are in a directory containing
              -- spaces then windres fails to run gcc. We therefore need
              -- to tell it what command to use...
              Option ("--preprocessor=" ++
                      unwords (map quote (gcc :
                                          map showOpt gcc_args ++
978
                                          map showOpt opts ++
979 980 981 982 983 984 985
                                          ["-E", "-xc", "-DRC_INVOKED"])))
              -- ...but if we do that then if windres calls popen then
              -- it can't understand the quoting, so we have to use
              -- --use-temp-file so that it interprets it correctly.
              -- See #1828.
            : Option "--use-temp-file"
            : args
986
  mb_env <- getGccEnv gcc_args
987
  runSomethingFiltered dflags id "Windres" windres args' mb_env
988

989
touch :: DynFlags -> String -> String -> IO ()
990 991
touch dflags purpose arg =
  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
992

993 994 995 996 997 998
copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to

copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
               -> IO ()
copyWithHeader dflags purpose maybe_header from to = do
999
  showPass dflags purpose
1000

1001 1002 1003
  hout <- openBinaryFile to   WriteMode
  hin  <- openBinaryFile from ReadMode
  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
1004
  maybe (return ()) (header hout) maybe_header
1005 1006 1007
  hPutStr hout ls
  hClose hout
  hClose hin
1008 1009 1010 1011 1012 1013 1014 1015
 where
  -- write the header string in UTF-8.  The header is something like
  --   {-# LINE "foo.hs" #-}
  -- and we want to make sure a Unicode filename isn't mangled.
  header h str = do
   hSetEncoding h utf8
   hPutStr h str
   hSetBinaryMode h True
1016

1017 1018 1019 1020 1021 1022 1023 1024
-- | read the contents of the named section in an ELF object as a
-- String.
readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
readElfSection _dflags section exe = do
  let
     prog = "readelf"
     args = [Option "-p", Option section, FileOption "" exe]
  --
1025 1026
  r <- readProcessEnvWithExitCode prog (filter notNull (map showOpt args))
                                  en_locale_env
1027 1028 1029 1030 1031 1032 1033 1034 1035
  case r of
    (ExitSuccess, out, _err) -> return (doFilter (lines out))
    _ -> return Nothing
 where
  doFilter [] = Nothing
  doFilter (s:r) = case readP_to_S parse s of
                    [(p,"")] -> Just p
                    _r       -> doFilter r
   where parse = do
Ian Lynagh's avatar
Ian Lynagh committed
1036 1037 1038 1039 1040
           skipSpaces
           _ <- R.char '['
           skipSpaces
           _ <- string "0]"
           skipSpaces
1041
           munch (const True)
1042

Austin Seipp's avatar
Austin Seipp committed
1043 1044 1045
{-
************************************************************************
*                                                                      *
1046
\subsection{Managing temporary files
Austin Seipp's avatar
Austin Seipp committed
1047 1048 1049
*                                                                      *
************************************************************************
-}
1050

1051 1052
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
1053
   = unless (gopt Opt_KeepTmpFiles dflags)
1054
   $ mask_
1055
   $ do let ref = dirsToClean dflags
1056
        ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
1057
        removeTmpDirs dflags (Map.elems ds)
1058

1059 1060
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
1061
   = unless (gopt Opt_KeepTmpFiles dflags)
1062
   $ mask_
1063
   $ do let ref = filesToClean dflags
1064
        fs <- atomicModifyIORef' ref $ \fs -> ([],fs)
1065
        removeTmpFiles dflags fs
1066

1067 1068
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete
ian@well-typed.com's avatar
ian@well-typed.com committed
1069
   = unless (gopt Opt_KeepTmpFiles dflags)
1070
   $ mask_
1071
   $ do let ref = filesToClean dflags
1072
        to_delete <- atomicModifyIORef' ref $ \files ->
1073 1074
            let (to_keep,to_delete) = partition (`elem` dont_delete) files</