SysTools.hs 68.8 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
        cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
        addFilesToClean,

47 48 49 50 51 52
        Option(..),

        -- frameworks
        getPkgFrameworkOpts,
        getFrameworkOpts

53 54 55

 ) where

56 57
#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
58
import DriverPhases
59 60
import Module
import Packages
61
import Config
62
import Outputable
Simon Marlow's avatar
Simon Marlow committed
63 64
import ErrUtils
import Panic
65
import Platform
Simon Marlow's avatar
Simon Marlow committed
66 67
import Util
import DynFlags
68
import Exception
69

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

84
#ifndef mingw32_HOST_OS
85
import qualified System.Posix.Internals
86
#else /* Must be Win32 */
sof's avatar
sof committed
87
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
88
import Foreign.C.String
rrt's avatar
rrt committed
89 90
#endif

91
import System.Process
Ian Lynagh's avatar
Ian Lynagh committed
92
import Control.Concurrent
93
import FastString
94
import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
95 96 97 98 99 100 101 102 103 104

#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
105

Austin Seipp's avatar
Austin Seipp committed
106
{-
107 108
How GHC finds its files
~~~~~~~~~~~~~~~~~~~~~~~
109

110
[Note topdir]
111 112

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

116 117
On Unix:
  - ghc always has a shell wrapper that passes a -B<dir> option
118

119 120 121
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
122 123 124
        $topdir/bin/<something>.exe
    where <something> may be "ghc", "ghc-stage2", or similar
  - we strip off the "bin/<something>.exe" to leave $topdir.
125

Ian Lynagh's avatar
Ian Lynagh committed
126
from topdir we can find package.conf, ghc-asm, etc.
127 128 129 130 131 132 133 134 135


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
136 137 138 139 140
  cGCC,         The *names* of the programs
  cCPP            e.g.  cGCC = gcc
  cUNLIT                cCPP = gcc -E
  etc           They do *not* include paths

141

Ian Lynagh's avatar
Ian Lynagh committed
142 143
  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
144 145
                   for use when running *in-place* in a build tree (only)

146 147


148 149 150 151 152 153 154 155 156 157 158 159 160 161
---------------------------------------------
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 = [],
162
     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
163 164 165 166 167
     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
168
                End of NOTES
169 170
---------------------------------------------

Austin Seipp's avatar
Austin Seipp committed
171 172
************************************************************************
*                                                                      *
173
\subsection{Initialisation}
Austin Seipp's avatar
Austin Seipp committed
174 175 176
*                                                                      *
************************************************************************
-}
177

Ian Lynagh's avatar
Ian Lynagh committed
178
initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
179
             -> IO Settings     -- Set all the mutable variables above, holding
Ian Lynagh's avatar
Ian Lynagh committed
180 181 182
                                --      (a) the system programs
                                --      (b) the package-config file
                                --      (c) the GHC usage message
183
initSysTools mbMinusB
184 185 186 187 188 189
  = 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"
190
           platformConstantsFile = top_dir </> "platformConstants"
191 192 193 194
           installed :: FilePath -> FilePath
           installed file = top_dir </> file

       settingsStr <- readFile settingsFile
195
       platformConstantsStr <- readFile platformConstantsFile
196 197 198 199 200
       mySettings <- case maybeReadFuzzy settingsStr of
                     Just s ->
                         return s
                     Nothing ->
                         pgmError ("Can't parse " ++ show settingsFile)
201 202 203 204 205 206
       platformConstants <- case maybeReadFuzzy platformConstantsStr of
                            Just s ->
                                return s
                            Nothing ->
                                pgmError ("Can't parse " ++
                                          show platformConstantsFile)
207 208 209 210 211 212 213 214 215 216 217
       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)
218 219 220 221 222
           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)
223 224 225 226 227 228
           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)
229
       crossCompiling <- getBooleanSetting "cross compiling"
230 231 232
       targetArch <- readSetting "target arch"
       targetOS <- readSetting "target os"
       targetWordSize <- readSetting "target word size"
233
       targetUnregisterised <- getBooleanSetting "Unregisterised"
234 235 236 237 238 239 240 241 242 243 244
       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"
245 246
       cpp_prog <- getSetting "Haskell CPP command"
       cpp_args_str <- getSetting "Haskell CPP flags"
247 248 249
       let unreg_gcc_args = if targetUnregisterised
                            then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
                            else []
250 251
           -- TABLES_NEXT_TO_CODE affects the info table layout.
           tntc_gcc_args
252 253 254
            | mkTablesNextToCode targetUnregisterised
               = ["-DTABLES_NEXT_TO_CODE"]
            | otherwise = []
255
           cpp_args= map Option (words cpp_args_str)
256 257 258
           gcc_args = map Option (words gcc_args_str
                               ++ unreg_gcc_args
                               ++ tntc_gcc_args)
259 260
       ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
       ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
261
       ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"
262
       ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
263 264 265 266 267 268 269 270 271 272 273 274 275 276
       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"
277
       libtool_path <- getSetting "libtool command"
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297

       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.
298

299 300

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

       -- 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,
315
                          platformUnregisterised = targetUnregisterised,
316 317
                          platformHasGnuNonexecStack = targetHasGnuNonexecStack,
                          platformHasIdentDirective = targetHasIdentDirective,
318 319
                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,
                          platformIsCrossCompiling = crossCompiling
320 321 322 323 324 325 326 327 328 329 330
                      }

       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,
331 332
                    sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
                    sLdSupportsBuildId       = ldSupportsBuildId,
333
                    sLdSupportsFilelist      = ldSupportsFilelist,
334
                    sLdIsGnuLd               = ldIsGnuLd,
335 336
                    sProgramName             = "ghc",
                    sProjectVersion          = cProjectVersion,
337 338 339 340 341 342 343 344 345 346
                    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_windres = windres_path,
347
                    sPgm_libtool = libtool_path,
348 349 350 351 352 353 354 355 356 357
                    sPgm_lo  = (lo_prog,[]),
                    sPgm_lc  = (lc_prog,[]),
                    sOpt_L       = [],
                    sOpt_P       = [],
                    sOpt_F       = [],
                    sOpt_c       = [],
                    sOpt_a       = [],
                    sOpt_l       = [],
                    sOpt_windres = [],
                    sOpt_lo      = [],
358 359
                    sOpt_lc      = [],
                    sPlatformConstants = platformConstants
360
             }
361

Ian Lynagh's avatar
Ian Lynagh committed
362 363 364 365 366 367 368 369 370
-- 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
371
             Nothing  -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
Ian Lynagh's avatar
Ian Lynagh committed
372
             Just dir -> return dir
373

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

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

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

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

runCc :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
407
runCc dflags args =   do
408
  let (p,args0) = pgm_c dflags
409 410 411
      args1 = map Option (getOpts dflags opt_c)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
412
  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env
413 414
 where
  -- discard some harmless warnings from gcc that we can't turn off
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 464 465
  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)
466

467 468 469
askCc :: DynFlags -> [Option] -> IO String
askCc dflags args = do
  let (p,args0) = pgm_c dflags
470 471 472 473
      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
474
    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
475

thomie's avatar
thomie committed
476 477 478
-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
-- inherited from the parent process, and output to stderr is not captured.
readCreateProcessWithExitCode'
479 480
    :: CreateProcess
    -> IO (ExitCode, String)    -- ^ stdout
thomie's avatar
thomie committed
481
readCreateProcessWithExitCode' proc = do
482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498
    (_, 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)

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 542 543
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")]
544

545 546 547 548
-- 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
549
getGccEnv opts =
550
  if null b_dirs
551
     then return Nothing
552
     else do env <- getEnvironment
553
             return (Just (map mangle_path env))
554
 where
555
  (b_dirs, _) = partitionWith get_b_opt opts
556 557

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

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

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

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

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

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

591 592 593 594 595 596 597
-- | 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"
598 599 600
      -- be careful what options we call clang with
      -- see #5903 and #7617 for bugs caused by this.
      (_,args0) = pgm_a dflags
601 602 603
      args1 = map Option (getOpts dflags opt_a)
      args2 = args0 ++ args1 ++ args
  mb_env <- getGccEnv args2
604
  Exception.catch (do
605
        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env
606 607
    )
    (\(err :: SomeException) -> do
608 609
        errorMsg dflags $
            text ("Error running clang! you need clang installed to use the" ++
610
                  " LLVM backend") $+$
611
            text "(or GHC tried to execute clang incorrectly)"
612
        throwIO err
613 614
    )

615
-- | Figure out which version of LLVM we are running this session
616
figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))
617 618 619 620 621 622 623 624 625 626 627
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
628
             {- > llc -version
629 630
                  LLVM (http://llvm.org/):
                    LLVM version 3.5.2
631 632 633 634
                    ...
             -}
             hSetBinaryMode pout False
             _     <- hGetLine pout
635 636 637 638 639 640
             vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
             v     <- case span (/= '.') vline of
                        ("",_)  -> fail "no digits!"
                        (x,y) -> return (read x
                                        , read $ takeWhile isDigit $ drop 1 y)

641 642 643 644 645 646
             hClose pin
             hClose pout
             hClose perr
             return $ Just v
            )
            (\err -> do
647 648 649
                debugTraceMsg dflags 2
                    (text "Error (figuring out LLVM version):" <+>
                     text (show err))
650
                errorMsg dflags $ vcat
651 652 653
                    [ text "Warning:", nest 9 $
                          text "Couldn't figure out LLVM version!" $$
                          text "Make sure you have installed LLVM"]
654 655
                return Nothing)
  return ver
656

Austin Seipp's avatar
Austin Seipp committed
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 690 691 692
{- 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).

-}
693 694 695

{- Note [Run-time linker info]

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

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.

723 724 725 726
-}

{- Note [ELF needed shared libs]

727 728 729 730 731 732 733
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.

734 735
The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
(Mach-O) the flag is not needed.
736

737
-}
738

739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762
{- Note [Windows static libGCC]

The GCC versions being upgraded to in #10726 are configured with
dynamic linking of libgcc supported. This results in libgcc being
linked dynamically when a shared library is created.

This introduces thus an extra dependency on GCC dll that was not
needed before by shared libraries created with GHC. This is a particular
issue on Windows because you get a non-obvious error due to this missing
dependency. This dependent dll is also not commonly on your path.

For this reason using the static libgcc is preferred as it preserves
the same behaviour that existed before. There are however some very good
reasons to have the shared version as well as described on page 181 of
https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :

"There are several situations in which an application should use the
 shared ‘libgcc’ instead of the static version. The most common of these
 is when the application wishes to throw and catch exceptions across different
 shared libraries. In that case, each of the libraries as well as the application
 itself should use the shared ‘libgcc’. "

-}

763 764 765 766
neededLinkArgs :: LinkerInfo -> [Option]
neededLinkArgs (GnuLD o)     = o
neededLinkArgs (GnuGold o)   = o
neededLinkArgs (DarwinLD o)  = o
767
neededLinkArgs (SolarisLD o) = o
768 769 770 771 772
neededLinkArgs UnknownLD     = []

-- Grab linker info and cache it in DynFlags.
getLinkerInfo :: DynFlags -> IO LinkerInfo
getLinkerInfo dflags = do
Austin Seipp's avatar
Austin Seipp committed
773
  info <- readIORef (rtldInfo dflags)
774 775 776 777
  case info of
    Just v  -> return v
    Nothing -> do
      v <- getLinkerInfo' dflags
Austin Seipp's avatar
Austin Seipp committed
778
      writeIORef (rtldInfo dflags) (Just v)
779 780 781 782 783 784 785
      return v

-- See Note [Run-time linker info].
getLinkerInfo' :: DynFlags -> IO LinkerInfo
getLinkerInfo' dflags = do
  let platform = targetPlatform dflags
      os = platformOS platform
786 787 788 789
      (pgm,args0) = pgm_l dflags
      args1     = map Option (getOpts dflags opt_l)
      args2     = args0 ++ args1
      args3     = filter notNull (map showOpt args2)
790 791 792 793 794 795

      -- 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.
796
          -- Set DT_NEEDED for all shared libraries. Trac #10110.
797
          return (GnuLD $ map Option ["-Wl,--hash-size=31",
798
                                      "-Wl,--reduce-memory-overheads",
799 800
                                      -- ELF specific flag
                                      -- see Note [ELF needed shared libs]
801
                                      "-Wl,--no-as-needed"])
802 803

        | any ("GNU gold" `isPrefixOf`) stdo =
804
          -- GNU gold only needs --no-as-needed. Trac #10110.
805
          -- ELF specific flag, see Note [ELF needed shared libs]
806
          return (GnuGold [Option "-Wl,--no-as-needed"])
807 808 809 810 811 812 813

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

  -- Process the executable call
  info <- catchIO (do
             case os of
814 815
               OSSolaris2 ->
                 -- Solaris uses its own Solaris linker. Even all
Gabor Greif's avatar
Gabor Greif committed
816
                 -- GNU C are recommended to configure with Solaris
817 818 819 820 821
                 -- 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 []
822 823 824 825 826
               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
827
               OSiOS ->
828 829
                 -- Ditto for iOS
                 return $ DarwinLD []
830 831 832 833
               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
834 835 836 837 838 839
                 return $ GnuLD $ map Option
                   [ -- Reduce ld memory usage
                     "-Wl,--hash-size=31"
                   , "-Wl,--reduce-memory-overheads"
                     -- Increase default stack, see
                     -- Note [Windows stack usage]
840 841 842
                     -- Force static linking of libGCC
                     -- Note [Windows static libGCC]
                   , "-Xlinker", "--stack=0x800000,0x800000", "-static-libgcc" ]
843 844 845
               _ -> do
                 -- In practice, we use the compiler as the linker here. Pass
                 -- -Wl,--version to get linker version info.
846
                 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
847
                                        (["-Wl,--version"] ++ args3)
848
                                        en_locale_env
849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864
                 -- 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
865

Austin Seipp's avatar
Austin Seipp committed
866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888
-- 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
889 890 891
        -- XCode 5.1 clang
        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
          return AppleClang51
Austin Seipp's avatar
Austin Seipp committed
892 893
        -- XCode 5 clang
        | any ("Apple LLVM version" `isPrefixOf`) stde =
Austin Seipp's avatar
Austin Seipp committed
894
          return AppleClang
Austin Seipp's avatar
Austin Seipp committed
895 896
        -- XCode 4.1 clang
        | any ("Apple clang version" `isPrefixOf`) stde =
Austin Seipp's avatar
Austin Seipp committed
897
          return AppleClang
Austin Seipp's avatar
Austin Seipp committed
898 899 900 901 902
         -- Unknown linker.
        | otherwise = fail "invalid -v output, or compiler is unsupported"

  -- Process the executable call
  info <- catchIO (do
903 904
                (exitc, stdo, stde) <-
                    readProcessEnvWithExitCode pgm ["-v"] en_locale_env
Austin Seipp's avatar
Austin Seipp committed
905 906 907 908 909 910
                -- Split the output by lines to make certain kinds
                -- of processing easier.
                parseCompilerInfo (lines stdo) (lines stde) exitc
            )
            (\err -> do
                debugTraceMsg dflags 2
911
                    (text "Error (figuring out C compiler information):" <+>
Austin Seipp's avatar
Austin Seipp committed
912 913
                     text (show err))
                errorMsg dflags $ hang (text "Warning:") 9 $
914
                  text "Couldn't figure out C compiler information!" $$
Austin Seipp's avatar
Austin Seipp committed
915 916 917 918
                  text "Make sure you're using GNU gcc, or clang"
                return UnknownCC)
  return info

919
runLink :: DynFlags -> [Option] -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
920
runLink dflags args = do
921 922
  -- See Note [Run-time linker info]
  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
923
  let (p,args0) = pgm_l dflags
924
      args1     = map Option (getOpts dflags opt_l)
925
      args2     = args0 ++ linkargs ++ args1 ++ args
926
  mb_env <- getGccEnv args2
927
  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
928 929 930 931 932 933
  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
934
  symbols in case of compiling into shared library when we do not
935 936
  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
937
  choose the library later based on binary application linking
938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960
  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
961
  little bit more complex due to the simple reason that we need to preserve
962 963
  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
964
  text between (including) the marks. Otherwise we copy the whole output.
965 966 967 968 969 970 971 972 973 974 975 976 977
-}
    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

978

979 980 981 982 983
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
984
      libtool    = pgm_libtool dflags
985 986 987
  mb_env <- getGccEnv args2
  runSomethingFiltered dflags id "Linker" libtool args2 mb_env

988 989
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = do
990
  let (p,args0) = pgm_dll dflags
991 992
      args1 = args0 ++ args
  mb_env <- getGccEnv (args0++args)
993
  runSomethingFiltered dflags id "Make DLL" p args1 mb_env
994

995 996
runWindres :: DynFlags -> [Option] -> IO ()
runWindres dflags args = do
997 998
  let (gcc, gcc_args) = pgm_c dflags
      windres = pgm_windres dflags
999
      opts = map Option (getOpts dflags opt_windres)
1000 1001 1002 1003 1004 1005 1006
      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 ++
1007
                                          map showOpt opts ++
1008 1009 1010 1011 1012 1013 1014
                                          ["-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
1015
  mb_env <- getGccEnv gcc_args
1016
  runSomethingFiltered dflags id "Windres" windres args' mb_env
1017

1018
touch :: DynFlags -> String -> String -> IO ()
1019 1020
touch dflags purpose arg =
  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
1021

1022 1023 1024 1025 1026 1027
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
1028
  showPass dflags purpose
1029

1030 1031 1032
  hout <- openBinaryFile to   WriteMode
  hin  <- openBinaryFile from ReadMode
  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
1033
  maybe (return ()) (header hout) maybe_header
1034 1035 1036
  hPutStr hout ls
  hClose hout
  hClose hin
1037 1038 1039 1040 1041 1042 1043 1044
 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
1045

1046 1047 1048 1049 1050 1051 1052 1053
-- | 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]
  --
1054 1055
  r <- readProcessEnvWithExitCode prog (filter notNull (map showOpt args))
                                  en_locale_env
1056 1057 1058 1059 1060 1061 1062 1063 1064
  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
1065 1066 1067 1068 1069
           skipSpaces
           _ <- R.char '['
           skipSpaces
           _ <- string "0]"
           skipSpaces
1070
           munch (const True)
1071

Austin Seipp's avatar
Austin Seipp committed
1072 1073 1074
{-
************************************************************************
*                                                                      *
1075
\subsection{Managing temporary files
Austin Seipp's avatar
Austin Seipp committed
1076 1077 1078
*                                                                      *
************************************************************************
-}
1079

1080 1081
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
1082
   = unless (gopt Opt_KeepTmpFiles dflags)
1083
   $ mask_
1084
   $ do let ref = dirsToClean dflags
1085
        ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
1086
        removeTmpDirs dflags (Map.elems ds)
1087

1088 1089
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
1090
   = unless (gopt Opt_KeepTmpFiles dflags)
1091
   $ mask_
1092
   $ do let ref = filesToClean dflags
1093
        fs <- atomicModifyIORef' ref $ \fs -> ([],fs)
1094
        removeTmpFiles dflags fs
1095

1096 1097
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete
ian@well-typed.com's avatar
ian@well-typed.com committed
1098
   = unless (gopt Opt_KeepTmpFiles dflags)
1099
   $ mask_
1100
   $ do let ref = filesToClean dflags
1101
        to_delete <- atomicModifyIORef' ref $ \files ->
1102 1103
            let (to_keep,to_delete) = partition (`elem` dont_delete) files
            in  (to_keep,to_delete)
Simon Marlow's avatar
Simon Marlow committed