Refactor temp files cleanup

Remove filesToNotIntermediateClean from DynFlags, create a data type
FilesToClean, and change filesToClean in DynFlags to be a FilesToClean.

Modify SysTools.newTempName and the Temporary constructor of
PipelineMonad.PipelineOutput to take a TempFileLifetime, which specifies
whether a temp file should live until the end of GhcMonad.withSession,
or until the next time cleanIntermediateTempFiles is called.

These changes allow the cleaning of intermediate files in GhcMake to be
much more efficient.

HscTypes.hptObjs is removed as it is no longer used.

A new performance test T13701 is added, which passes both with and
without -keep-tmp-files.  The test fails by 25% without the patch, and
passes when -keep-tmp-files is added.

Note that there are still at two hotspots caused by
algorithms quadratic in the number of modules, however neither of them
allocate. They are:

* DriverPipeline.compileOne'.needsLinker
* GhcMake.getModLoop

DriverPipeline.compileOne'.needsLinker is changed slightly to improve
the situation.

I don't like adding these Types to DynFlags, but they need to be seen by
Dynflags, SysTools and PipelineMonad. The alternative seems to be to
create a new module.

Reviewers: austin, hvr, bgamari, dfeuer, niteria, simonmar, erikd

Reviewed By: simonmar

Subscribers: rwbarton, thomie

GHC Trac Issues: #13701

Differential Revision: https://phabricator.haskell.org/D3620

15 files changed, 401 insertions, 304 deletions

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 2ef2db45d3..d11a42bccc 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -165,6 +165,7 @@ Library
         vectorise
 
     Exposed-Modules:
+        FileCleanup
         DriverBkp
         BkpSyn
         NameShape
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index a2a123c03b..bfd75ab26c 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -478,6 +478,7 @@ compiler_stage2_dll0_MODULES = \
 	FastString \
 	FastStringEnv \
 	FieldLabel \
+	FileCleanup \
 	Fingerprint \
 	FiniteMap \
 	ForeignCall \
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 10e789acc3..f32659017a 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -47,6 +47,7 @@ import UniqDSet
 import FastString
 import Platform
 import SysTools
+import FileCleanup
 
 -- Standard libraries
 import Control.Monad
@@ -883,7 +884,8 @@ dynLoadObjs hsc_env pls objs = do
     let platform = targetPlatform dflags
     let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
     let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]
-    (soFile, libPath , libName) <- newTempLibName dflags (soExt platform)
+    (soFile, libPath , libName) <-
+      newTempLibName dflags TFL_CurrentModule (soExt platform)
     let
         dflags2 = dflags {
                       -- We don't want the original ldInputs in
@@ -931,7 +933,9 @@ dynLoadObjs hsc_env pls objs = do
     -- Note: We are loading packages with local scope, so to see the
     -- symbols in this link we must link all loaded packages again.
     linkDynLib dflags2 objs (pkgs_loaded pls)
-    consIORef (filesToNotIntermediateClean dflags) soFile
+
+    -- if we got this far, extend the lifetime of the library file
+    changeTempFilesLifetime dflags TFL_GhcSession [soFile]
     m <- loadDLL hsc_env soFile
     case m of
         Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index dec7215715..78787c9827 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -966,9 +966,9 @@ lookupOccEnvL env k = lookupOccEnv env k `orElse` []
                else return fp
 
 oldMD5 dflags bh = do
-  tmp <- newTempName dflags "bin"
+  tmp <- newTempName dflags CurrentModule "bin"
   writeBinMem bh tmp
-  tmp2 <- newTempName dflags "md5"
+  tmp2 <- newTempName dflags CurrentModule "md5"
   let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
   r <- system cmd
   case r of
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index 7c6dbdab53..34cada3ff9 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -23,9 +23,9 @@ import Cmm              ( RawCmmGroup )
 import HscTypes
 import DynFlags
 import Config
-import SysTools
 import Stream           (Stream)
 import qualified Stream
+import FileCleanup
 
 import ErrUtils
 import Outputable
@@ -202,7 +202,7 @@ outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
 outputForeignStubs dflags mod location stubs
  = do
    let stub_h = mkStubPaths dflags (moduleName mod) location
-   stub_c <- newTempName dflags "c"
+   stub_c <- newTempName dflags TFL_CurrentModule "c"
 
    case stubs of
      NoStubs ->
@@ -276,6 +276,6 @@ outputForeignFile dflags lang file_contents
      LangCxx -> return "cpp"
      LangObjc -> return "m"
      LangObjcxx -> return "mm"
-   fp <- newTempName dflags extension
+   fp <- newTempName dflags TFL_CurrentModule extension
    writeFile fp file_contents
    return fp
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 46fe4e0aad..dc18a31174 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -19,7 +19,7 @@ import GhcMonad
 import DynFlags
 import Util
 import HscTypes
-import SysTools         ( newTempName )
+import FileCleanup      ( newTempName )
 import qualified SysTools
 import Module
 import Digraph          ( SCC(..) )
@@ -29,6 +29,7 @@ import Panic
 import SrcLoc
 import Data.List
 import FastString
+import FileCleanup
 
 import Exception
 import ErrUtils
@@ -121,7 +122,7 @@ beginMkDependHS :: DynFlags -> IO MkDepFiles
 beginMkDependHS dflags = do
         -- open a new temp file in which to stuff the dependency info
         -- as we go along.
-  tmp_file <- newTempName dflags "dep"
+  tmp_file <- newTempName dflags TFL_CurrentModule "dep"
   tmp_hdl <- openFile tmp_file WriteMode
 
         -- open the makefile
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index e400461fb6..eed66b22c1 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -61,6 +61,7 @@ import Platform
 import TcRnTypes
 import Hooks
 import qualified GHC.LanguageExtensions as LangExt
+import FileCleanup
 
 import Exception
 import System.Directory
@@ -86,7 +87,12 @@ preprocess :: HscEnv
 preprocess hsc_env (filename, mb_phase) =
   ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
   runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)
-        Nothing Temporary Nothing{-no ModLocation-} []{-no foreign objects-}
+        Nothing
+        -- We keep the processed file for the whole session to save on
+        -- duplicated work in ghci.
+        (Temporary TFL_GhcSession)
+        Nothing{-no ModLocation-}
+        []{-no foreign objects-}
 
 -- ---------------------------------------------------------------------------
 
@@ -138,9 +144,11 @@ compileOne' m_tc_result mHscMessage
 
    let flags = hsc_dflags hsc_env0
      in do unless (gopt Opt_KeepHiFiles flags) $
-               addFilesToClean flags [ml_hi_file $ ms_location summary]
+               addFilesToClean flags TFL_CurrentModule $
+                   [ml_hi_file $ ms_location summary]
            unless (gopt Opt_KeepOFiles flags) $
-               addFilesToClean flags [ml_obj_file $ ms_location summary]
+               addFilesToClean flags TFL_GhcSession $
+                   [ml_obj_file $ ms_location summary]
 
    case (status, hsc_lang) of
         (HscUpToDate, _) ->
@@ -165,7 +173,8 @@ compileOne' m_tc_result mHscMessage
             in return hmi0 { hm_linkable = Just linkable }
         (HscUpdateSig, _) -> do
             output_fn <- getOutputFilename next_phase
-                            Temporary basename dflags next_phase (Just location)
+                            (Temporary TFL_CurrentModule) basename dflags
+                            next_phase (Just location)
 
             -- #10660: Use the pipeline instead of calling
             -- compileEmptyStub directly, so -dynamic-too gets
@@ -204,7 +213,8 @@ compileOne' m_tc_result mHscMessage
             return hmi0 { hm_linkable = Just linkable }
         (HscRecomp cgguts summary, _) -> do
             output_fn <- getOutputFilename next_phase
-                            Temporary basename dflags next_phase (Just location)
+                            (Temporary TFL_CurrentModule)
+                            basename dflags next_phase (Just location)
             -- We're in --make mode: finish the compilation pipeline.
             _ <- runPipeline StopLn hsc_env
                               (output_fn,
@@ -225,9 +235,10 @@ compileOne' m_tc_result mHscMessage
        input_fn    = expectJust "compile:hs" (ml_hs_file location)
        input_fnpp  = ms_hspp_file summary
        mod_graph   = hsc_mod_graph hsc_env0
-       needsTH     = any (xopt LangExt.TemplateHaskell . ms_hspp_opts) mod_graph
-       needsQQ     = any (xopt LangExt.QuasiQuotes     . ms_hspp_opts) mod_graph
-       needsLinker = needsTH || needsQQ
+       needsLinker = any (\ModSummary {ms_hspp_opts} ->
+                            xopt LangExt.TemplateHaskell ms_hspp_opts
+                            || xopt LangExt.QuasiQuotes ms_hspp_opts
+                         ) mod_graph
        isDynWay    = any (== WayDyn) (ways dflags0)
        isProfWay   = any (== WayProf) (ways dflags0)
        internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)
@@ -240,8 +251,8 @@ compileOne' m_tc_result mHscMessage
        -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
        -- the linker can correctly load the object files.  This isn't necessary
        -- when using -fexternal-interpreter.
-       dflags1 = if needsLinker && dynamicGhc && internalInterpreter &&
-                    not isDynWay && not isProfWay
+       dflags1 = if dynamicGhc && internalInterpreter &&
+                    not isDynWay && not isProfWay && needsLinker
                   then gopt_set dflags0 Opt_BuildDynamicToo
                   else dflags0
 
@@ -299,8 +310,9 @@ compileForeign hsc_env lang stub_c = do
               LangObjcxx -> Cobjcxx
         (_, stub_o) <- runPipeline StopLn hsc_env
                        (stub_c, Just (RealPhase phase))
-                       Nothing Temporary Nothing{-no ModLocation-} []
-
+                       Nothing (Temporary TFL_GhcSession)
+                       Nothing{-no ModLocation-}
+                       []
         return stub_o
 
 compileStub :: HscEnv -> FilePath -> IO FilePath
@@ -315,7 +327,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
   -- so that ranlib on OS X doesn't complain, see
   -- http://ghc.haskell.org/trac/ghc/ticket/12673
   -- and https://github.com/haskell/cabal/issues/2257
-  empty_stub <- newTempName dflags "c"
+  empty_stub <- newTempName dflags TFL_CurrentModule "c"
   let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"
   writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
   _ <- runPipeline StopLn hsc_env
@@ -535,10 +547,10 @@ compileFile hsc_env stop_phase (src, mb_phase) = do
         -- When linking, the -o argument refers to the linker's output.
         -- otherwise, we use it as the name for the pipeline's output.
         output
-         -- If we are dong -fno-code, then act as if the output is
+         -- If we are doing -fno-code, then act as if the output is
          -- 'Temporary'. This stops GHC trying to copy files to their
          -- final location.
-         | HscNothing <- hscTarget dflags = Temporary
+         | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule
          | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
                 -- -o foo applies to linker
          | isJust mb_o_file = SpecificFile
@@ -696,7 +708,7 @@ pipeLoop phase input_fn = do
         -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
         -- further compilation stages can tell what the original filename was.
         case output_spec env of
-        Temporary ->
+        Temporary _ ->
             return (dflags, input_fn)
         output ->
             do pst <- getPipeState
@@ -780,7 +792,9 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
                                            Nothing ->
                                                panic "SpecificFile: No filename"
  | keep_this_output                      = persistent_fn
- | otherwise                             = newTempName dflags suffix
+ | Temporary lifetime <- output          = newTempName dflags lifetime suffix
+ | otherwise                             = newTempName dflags TFL_CurrentModule
+   suffix
     where
           hcsuf      = hcSuf dflags
           odir       = objectDir dflags
@@ -1238,7 +1252,8 @@ runPhase (RealPhase cc_phase) input_fn dflags
 runPhase (RealPhase Splitter) input_fn dflags
   = do  -- tmp_pfx is the prefix used for the split .s files
 
-        split_s_prefix <- liftIO $ SysTools.newTempName dflags "split"
+        split_s_prefix <-
+          liftIO $ newTempName dflags TFL_CurrentModule "split"
         let n_files_fn = split_s_prefix
 
         liftIO $ SysTools.runSplit dflags
@@ -1255,7 +1270,7 @@ runPhase (RealPhase Splitter) input_fn dflags
         setDynFlags dflags'
 
         -- Remember to delete all these files
-        liftIO $ addFilesToClean dflags'
+        liftIO $ addFilesToClean dflags' TFL_CurrentModule $
                                  [ split_s_prefix ++ "__" ++ show n ++ ".s"
                                  | n <- [1..n_files]]
 
@@ -1401,7 +1416,7 @@ runPhase (RealPhase SplitAs) _input_fn dflags
         if null foreign_os
           then return ()
           else liftIO $ do
-             tmp_split_1 <- newTempName dflags osuf
+             tmp_split_1 <- newTempName dflags TFL_CurrentModule osuf
              let split_1 = split_obj 1
              copyFile split_1 tmp_split_1
              removeFile split_1
@@ -1613,8 +1628,8 @@ getLocation src_flavour mod_name = do
 
 mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
 mkExtraObj dflags extn xs
- = do cFile <- newTempName dflags extn
-      oFile <- newTempName dflags "o"
+ = do cFile <- newTempName dflags TFL_CurrentModule extn
+      oFile <- newTempName dflags TFL_GhcSession "o"
       writeFile cFile xs
       ccInfo <- liftIO $ getCompilerInfo dflags
       SysTools.runCc dflags
@@ -2031,8 +2046,9 @@ maybeCreateManifest dflags exe_filename
          -- the binary itself using windres:
          if not (gopt Opt_EmbedManifest dflags) then return [] else do
 
-         rc_filename <- newTempName dflags "rc"
-         rc_obj_filename <- newTempName dflags (objectSuf dflags)
+         rc_filename <- newTempName dflags TFL_CurrentModule "rc"
+         rc_obj_filename <-
+           newTempName dflags TFL_GhcSession (objectSuf dflags)
 
          writeFile rc_filename $
              "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
@@ -2121,7 +2137,7 @@ doCpp dflags raw input_fn output_fn = do
         pkgs = catMaybes (map (lookupPackage dflags) uids)
     mb_macro_include <-
         if not (null pkgs) && gopt Opt_VersionMacros dflags
-            then do macro_stub <- newTempName dflags "h"
+            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
                     writeFile macro_stub (generatePackageVersionMacros pkgs)
                     -- Include version macros for every *exposed* package.
                     -- Without -hide-all-packages and with a package database
@@ -2248,14 +2264,14 @@ joinObjectFiles dflags o_files output_fn = do
   ccInfo <- getCompilerInfo dflags
   if ldIsGnuLd
      then do
-          script <- newTempName dflags "ldscript"
+          script <- newTempName dflags TFL_CurrentModule "ldscript"
           cwd <- getCurrentDirectory
           let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
           writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
           ld_r [SysTools.FileOption "" script] ccInfo
      else if sLdSupportsFilelist mySettings
      then do
-          filelist <- newTempName dflags "filelist"
+          filelist <- newTempName dflags TFL_CurrentModule "filelist"
           writeFile filelist $ unlines o_files
           ld_r [SysTools.Option "-Wl,-filelist",
                 SysTools.FileOption "-Wl," filelist] ccInfo
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index a166993089..8a4f1c3e1d 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -155,6 +155,9 @@ module DynFlags (
         -- * Linker/compiler information
         LinkerInfo(..),
         CompilerInfo(..),
+
+        -- * File cleanup
+        FilesToClean(..), emptyFilesToClean
   ) where
 
 #include "HsVersions.h"
@@ -840,9 +843,8 @@ data DynFlags = DynFlags {
   -- Temporary files
   -- These have to be IORefs, because the defaultCleanupHandler needs to
   -- know what to clean when an exception happens
-  filesToClean          :: IORef [FilePath],
+  filesToClean          :: IORef FilesToClean,
   dirsToClean           :: IORef (Map FilePath FilePath),
-  filesToNotIntermediateClean :: IORef [FilePath],
   -- The next available suffix to uniquely name a temp file, updated atomically
   nextTempSuffix        :: IORef Int,
 
@@ -1504,9 +1506,8 @@ initDynFlags dflags = do
          = platformOS (targetPlatform dflags) /= OSMinGW32
  refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo
  refNextTempSuffix <- newIORef 0
- refFilesToClean <- newIORef []
+ refFilesToClean <- newIORef emptyFilesToClean
  refDirsToClean <- newIORef Map.empty
- refFilesToNotIntermediateClean <- newIORef []
  refGeneratedDumps <- newIORef Set.empty
  refRtldInfo <- newIORef Nothing
  refRtccInfo <- newIORef Nothing
@@ -1530,7 +1531,6 @@ initDynFlags dflags = do
         nextTempSuffix = refNextTempSuffix,
         filesToClean   = refFilesToClean,
         dirsToClean    = refDirsToClean,
-        filesToNotIntermediateClean = refFilesToNotIntermediateClean,
         generatedDumps = refGeneratedDumps,
         nextWrapperNum = wrapperNum,
         useUnicode    = canUseUnicode,
@@ -1647,7 +1647,6 @@ defaultDynFlags mySettings =
         nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix",
         filesToClean   = panic "defaultDynFlags: No filesToClean",
         dirsToClean    = panic "defaultDynFlags: No dirsToClean",
-        filesToNotIntermediateClean = panic "defaultDynFlags: No filesToNotIntermediateClean",
         generatedDumps = panic "defaultDynFlags: No generatedDumps",
         haddockOptions = Nothing,
         dumpFlags = EnumSet.empty,
@@ -5326,3 +5325,24 @@ decodeSize str
 
 foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()
 foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
+
+-- -----------------------------------------------------------------------------
+-- Types for managing temporary files.
+--
+-- these are here because FilesToClean is used in DynFlags
+
+-- | A collection of files that must be deleted before ghc exits.
+-- The current collection
+-- is stored in an IORef in DynFlags, 'filesToClean'.
+data FilesToClean = FilesToClean {
+  ftcGhcSession :: !(Set FilePath),
+  -- ^ Files that will be deleted at the end of runGhc(T)
+  ftcCurrentModule :: !(Set FilePath)
+  -- ^ Files that will be deleted the next time
+  -- 'FileCleanup.cleanCurrentModuleTempFiles' is called, or otherwise at the
+  -- end of the session.
+  }
+
+-- | An empty FilesToClean
+emptyFilesToClean :: FilesToClean
+emptyFilesToClean = FilesToClean Set.empty Set.empty
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 64d23c7e41..c0127b2a27 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -52,6 +52,7 @@ module ErrUtils (
         debugTraceMsg,
         ghcExit,
         prettyPrintGhcErrors,
+        traceCmd
     ) where
 
 #include "HsVersions.h"
@@ -673,3 +674,23 @@ isWarnMsgFatal :: DynFlags -> WarnMsg -> Bool
 isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
   = wopt_fatal wflag dflags
 isWarnMsgFatal dflags _ = gopt Opt_WarnIsError dflags
+
+traceCmd :: DynFlags -> String -> String -> IO a -> IO a
+-- trace the command (at two levels of verbosity)
+traceCmd dflags phase_name cmd_line action
+ = do   { let verb = verbosity dflags
+        ; showPass dflags phase_name
+        ; debugTraceMsg dflags 3 (text cmd_line)
+        ; case flushErr dflags of
+              FlushErr io -> io
+
+           -- And run it!
+        ; action `catchIO` handle_exn verb
+        }
+  where
+    handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
+                              ; debugTraceMsg dflags 2
+                                (text "Failed:"
+                                 <+> text cmd_line
+                                 <+> text (show exn))
+                              ; throwGhcExceptionIO (ProgramError (show exn))}
diff --git a/compiler/main/FileCleanup.hs b/compiler/main/FileCleanup.hs
new file mode 100644
index 0000000000..f4c30d6112
--- /dev/null
+++ b/compiler/main/FileCleanup.hs
@@ -0,0 +1,249 @@
+{-# LANGUAGE CPP #-}
+module FileCleanup
+  ( TempFileLifetime(..)
+  , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles
+  , addFilesToClean, changeTempFilesLifetime
+  , newTempName, newTempLibName
+  ) where
+
+import DynFlags
+import ErrUtils
+import Outputable
+import Util
+import Exception
+import DriverPhases
+
+import Control.Monad
+import Data.List
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.IORef
+import System.Directory
+import System.FilePath
+import System.IO.Error
+
+#if !defined(mingw32_HOST_OS)
+import qualified System.Posix.Internals
+#endif
+
+-- | Used when a temp file is created. This determines which component Set of
+-- FilesToClean will get the temp file
+data TempFileLifetime
+  = TFL_CurrentModule
+  -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the
+  -- end of upweep_mod
+  | TFL_GhcSession
+  -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of
+  -- runGhc(T)
+  deriving (Show)
+
+cleanTempDirs :: DynFlags -> IO ()
+cleanTempDirs dflags
+   = unless (gopt Opt_KeepTmpFiles dflags)
+   $ mask_
+   $ do let ref = dirsToClean dflags
+        ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
+        removeTmpDirs dflags (Map.elems ds)
+
+-- | Delete all files in @filesToClean dflags@.
+cleanTempFiles :: DynFlags -> IO ()
+cleanTempFiles dflags
+   = unless (gopt Opt_KeepTmpFiles dflags)
+   $ mask_
+   $ do let ref = filesToClean dflags
+        to_delete <- atomicModifyIORef' ref $
+            \FilesToClean
+                { ftcCurrentModule = cm_files
+                , ftcGhcSession = gs_files
+                } -> ( emptyFilesToClean
+                     , Set.toList cm_files ++ Set.toList gs_files)
+        removeTmpFiles dflags to_delete
+
+-- | Delete all files in @filesToClean dflags@. That have lifetime
+-- TFL_CurrentModule.
+-- If a file must be cleaned eventually, but must survive a
+-- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.
+cleanCurrentModuleTempFiles :: DynFlags -> IO ()
+cleanCurrentModuleTempFiles dflags
+   = unless (gopt Opt_KeepTmpFiles dflags)
+   $ mask_
+   $ do let ref = filesToClean dflags
+        to_delete <- atomicModifyIORef' ref $
+            \ftc@FilesToClean{ftcCurrentModule = cm_files} ->
+                (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)
+        removeTmpFiles dflags to_delete
+
+-- | Ensure that new_files are cleaned on the next call of
+-- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.
+-- If any of new_files are already tracked, they will have their lifetime
+-- updated.
+addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
+addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $
+  \FilesToClean
+    { ftcCurrentModule = cm_files
+    , ftcGhcSession = gs_files
+    } -> case lifetime of
+      TFL_CurrentModule -> FilesToClean
+        { ftcCurrentModule = cm_files `Set.union` new_files_set
+        , ftcGhcSession = gs_files `Set.difference` new_files_set
+        }
+      TFL_GhcSession -> FilesToClean
+        { ftcCurrentModule = cm_files `Set.difference` new_files_set
+        , ftcGhcSession = gs_files `Set.union` new_files_set
+        }
+  where
+    new_files_set = Set.fromList new_files
+
+-- | Update the lifetime of files already being tracked. If any files are
+-- not being tracked they will be discarded.
+changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
+changeTempFilesLifetime dflags lifetime files = do
+  FilesToClean
+    { ftcCurrentModule = cm_files
+    , ftcGhcSession = gs_files
+    } <- readIORef (filesToClean dflags)
+  let old_set = case lifetime of
+        TFL_CurrentModule -> gs_files
+        TFL_GhcSession -> cm_files
+      existing_files = [f | f <- files, f `Set.member` old_set]
+  addFilesToClean dflags lifetime existing_files
+
+-- Return a unique numeric temp file suffix
+newTempSuffix :: DynFlags -> IO Int
+newTempSuffix dflags =
+  atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
+
+-- Find a temporary name that doesn't already exist.
+newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath
+newTempName dflags lifetime extn
+  = do d <- getTempDir dflags
+       findTempName (d </> "ghc_") -- See Note [Deterministic base name]
+  where
+    findTempName :: FilePath -> IO FilePath
+    findTempName prefix
+      = do n <- newTempSuffix dflags
+           let filename = prefix ++ show n <.> extn
+           b <- doesFileExist filename
+           if b then findTempName prefix
+                else do -- clean it up later
+                        addFilesToClean dflags lifetime [filename]
+                        return filename
+
+newTempLibName :: DynFlags -> TempFileLifetime -> Suffix
+  -> IO (FilePath, FilePath, String)
+newTempLibName dflags lifetime extn
+  = do d <- getTempDir dflags
+       findTempName d ("ghc_")
+  where
+    findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
+    findTempName dir prefix
+      = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
+           let libname = prefix ++ show n
+               filename = dir </> "lib" ++ libname <.> extn
+           b <- doesFileExist filename
+           if b then findTempName dir prefix
+                else do -- clean it up later
+                        addFilesToClean dflags lifetime [filename]
+                        return (filename, dir, libname)
+
+
+-- Return our temporary directory within tmp_dir, creating one if we
+-- don't have one yet.
+getTempDir :: DynFlags -> IO FilePath
+getTempDir dflags = do
+    mapping <- readIORef dir_ref
+    case Map.lookup tmp_dir mapping of
+        Nothing -> do
+            pid <- getProcessID
+            let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
+            mask_ $ mkTempDir prefix
+        Just dir -> return dir
+  where
+    tmp_dir = tmpDir dflags
+    dir_ref = dirsToClean dflags
+
+    mkTempDir :: FilePath -> IO FilePath
+    mkTempDir prefix = do
+        n <- newTempSuffix dflags
+        let our_dir = prefix ++ show n
+
+        -- 1. Speculatively create our new directory.
+        createDirectory our_dir
+
+        -- 2. Update the dirsToClean mapping unless an entry already exists
+        -- (i.e. unless another thread beat us to it).
+        their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
+            case Map.lookup tmp_dir mapping of
+                Just dir -> (mapping, Just dir)
+                Nothing  -> (Map.insert tmp_dir our_dir mapping, Nothing)
+
+        -- 3. If there was an existing entry, return it and delete the
+        -- directory we created.  Otherwise return the directory we created.
+        case their_dir of
+            Nothing  -> do
+                debugTraceMsg dflags 2 $
+                    text "Created temporary directory:" <+> text our_dir
+                return our_dir
+            Just dir -> do
+                removeDirectory our_dir
+                return dir
+      `catchIO` \e -> if isAlreadyExistsError e
+                      then mkTempDir prefix else ioError e
+
+{- Note [Deterministic base name]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The filename of temporary files, especially the basename of C files, can end
+up in the output in some form, e.g. as part of linker debug information. In the
+interest of bit-wise exactly reproducible compilation (#4012), the basename of
+the temporary file no longer contains random information (it used to contain
+the process id).
+
+This is ok, as the temporary directory used contains the pid (see getTempDir).
+-}
+removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
+removeTmpDirs dflags ds
+  = traceCmd dflags "Deleting temp dirs"
+             ("Deleting: " ++ unwords ds)
+             (mapM_ (removeWith dflags removeDirectory) ds)
+
+removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
+removeTmpFiles dflags fs
+  = warnNon $
+    traceCmd dflags "Deleting temp files"
+             ("Deleting: " ++ unwords deletees)
+             (mapM_ (removeWith dflags removeFile) deletees)
+  where
+     -- Flat out refuse to delete files that are likely to be source input
+     -- files (is there a worse bug than having a compiler delete your source
+     -- files?)
+     --
+     -- Deleting source files is a sign of a bug elsewhere, so prominently flag
+     -- the condition.
+    warnNon act
+     | null non_deletees = act
+     | otherwise         = do
+        putMsg dflags (text "WARNING - NOT deleting source files:"
+                       <+> hsep (map text non_deletees))
+        act
+
+    (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
+
+removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
+removeWith dflags remover f = remover f `catchIO`
+  (\e ->
+   let msg = if isDoesNotExistError e
+             then text "Warning: deleting non-existent" <+> text f
+             else text "Warning: exception raised when deleting"
+                                            <+> text f <> colon
+               $$ text (show e)
+   in debugTraceMsg dflags 2 msg
+  )
+
+#if defined(mingw32_HOST_OS)
+-- relies on Int == Int32 on Windows
+foreign import ccall unsafe "_getpid" getProcessID :: IO Int
+#else
+getProcessID :: IO Int
+getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
+#endif
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index af00dab4f2..eda3471ece 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -333,8 +333,9 @@ import qualified Parser
 import Lexer
 import ApiAnnotation
 import qualified GHC.LanguageExtensions as LangExt
-import Data.Set (Set)
+import FileCleanup
 
+import Data.Set (Set)
 import System.Directory ( doesFileExist )
 import Data.Maybe
 import Data.List        ( find )
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index e11503b9d1..134a0607bc 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 -- NB: we specifically ignore deprecations. GHC 7.6 marks the .QSem module as
 -- deprecated, although it became un-deprecated later. As a result, using 7.6
@@ -59,7 +60,6 @@ import Outputable
 import Panic
 import SrcLoc
 import StringBuffer
-import SysTools
 import UniqFM
 import UniqDSet
 import TcBackpack
@@ -68,6 +68,7 @@ import UniqSet
 import Util
 import qualified GHC.LanguageExtensions as LangExt
 import NameEnv
+import FileCleanup
 
 import Data.Either ( rights, partitionEithers )
 import qualified Data.Map as Map
@@ -373,10 +374,7 @@ load' how_much mHscMessage mod_graph = do
         mg = stable_mg ++ unstable_mg
 
     -- clean up between compilations
-    let cleanup hsc_env = intermediateCleanTempFiles (hsc_dflags hsc_env)
-                              (flattenSCCs mg2_with_srcimps)
-                              hsc_env
-
+    let cleanup = cleanCurrentModuleTempFiles . hsc_dflags
     liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
                                2 (ppr mg))
 
@@ -407,7 +405,7 @@ load' how_much mHscMessage mod_graph = do
 
           -- Clean up after ourselves
           hsc_env1 <- getSession
-          liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1
+          liftIO $ cleanCurrentModuleTempFiles dflags
 
           -- Issue a warning for the confusing case where the user
           -- said '-o foo' but we're not going to do any linking.
@@ -448,29 +446,42 @@ load' how_much mHscMessage mod_graph = do
           let mods_to_zap_names
                  = findPartiallyCompletedCycles modsDone_names
                       mg2_with_srcimps
-          let mods_to_keep
-                 = filter ((`Set.notMember` mods_to_zap_names).ms_mod)
-                      modsDone
-
+          let (mods_to_clean, mods_to_keep) =
+                partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone
           hsc_env1 <- getSession
-          let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
-                                          (hsc_HPT hsc_env1)
+          let hpt4 = hsc_HPT hsc_env1
+              -- We must change the lifetime to TFL_CurrentModule for any temp
+              -- file created for an element of mod_to_clean during the upsweep.
+              -- These include preprocessed files and object files for loaded
+              -- modules.
+              unneeded_temps = concat
+                [ms_hspp_file : object_files
+                | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean
+                , let object_files = maybe [] linkableObjs $
+                        lookupHpt hpt4 (moduleName ms_mod)
+                        >>= hm_linkable
+                ]
+          liftIO $
+            changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps
+          liftIO $ cleanCurrentModuleTempFiles dflags
+
+          let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
+                                          hpt4
 
           -- Clean up after ourselves
-          liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1
 
           -- there should be no Nothings where linkables should be, now
           let just_linkables =
                     isNoLink (ghcLink dflags)
                  || allHpt (isJust.hm_linkable)
                         (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
-                                hpt4)
+                                hpt5)
           ASSERT( just_linkables ) do
 
           -- Link everything together
-          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
+          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5
 
-          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
+          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
           loadFinish Failed linkresult
 
 
@@ -518,23 +529,6 @@ discardIC hsc_env
     this_pkg = thisPackage dflags
     old_name = ic_name old_ic
 
-intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO ()
-intermediateCleanTempFiles dflags summaries hsc_env
- = do notIntermediate <- readIORef (filesToNotIntermediateClean dflags)
-      cleanTempFilesExcept dflags (notIntermediate ++ except)
-  where
-    except =
-          -- Save preprocessed files. The preprocessed file *might* be
-          -- the same as the source file, but that doesn't do any
-          -- harm.
-          map ms_hspp_file summaries ++
-          -- Save object files for loaded modules.  The point of this
-          -- is that we might have generated and compiled a stub C
-          -- file, and in the case of GHCi the object file will be a
-          -- temporary file which we must not remove because we need
-          -- to load/link it later.
-          hptObjs (hsc_HPT hsc_env)
-
 -- | If there is no -o option, guess the name of target executable
 -- by using top-level source file name as a base.
 guessOutputFile :: GhcMonad m => m ()
@@ -927,7 +921,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
                 -- compilation for that module is finished) without having to
                 -- worry about accidentally deleting a simultaneous compile's
                 -- important files.
-                lcl_files_to_clean <- newIORef []
+                lcl_files_to_clean <- newIORef emptyFilesToClean
                 let lcl_dflags = dflags { log_action = parLogAction log_queue
                                         , filesToClean = lcl_files_to_clean }
 
@@ -960,9 +954,12 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
 
                 -- Add the remaining files that weren't cleaned up to the
                 -- global filesToClean ref, for cleanup later.
-                files_kept <- readIORef (filesToClean lcl_dflags)
-                addFilesToClean dflags files_kept
-
+                FilesToClean
+                  { ftcCurrentModule = cm_files
+                  , ftcGhcSession = gs_files
+                  } <- readIORef (filesToClean lcl_dflags)
+                addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files
+                addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files
 
         -- Kill all the workers, masking interrupts (since killThread is
         -- interruptible). XXX: This is not ideal.
@@ -1971,14 +1968,10 @@ enableCodeGenForTH target nodemap =
         } <- ms
       , ms_mod `Set.member` needs_codegen_set
       = do
-        let add_intermediate_file f =
-              consIORef (filesToNotIntermediateClean dflags) f
-            new_temp_file suf dynsuf = do
-              tn <- newTempName dflags suf
+        let new_temp_file suf dynsuf = do
+              tn <- newTempName dflags TFL_CurrentModule suf
               let dyn_tn = tn -<.> dynsuf
-              add_intermediate_file tn
-              add_intermediate_file dyn_tn
-              addFilesToClean dflags [dyn_tn]
+              addFilesToClean dflags TFL_GhcSession [dyn_tn]
               return tn
           -- We don't want to create .o or .hi files unless we have been asked
           -- to by the user. But we need them, so we patch their locations in
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 70af19de9b..c9e4f89158 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -40,7 +40,6 @@ module HscTypes (
         addToHpt, addListToHpt, lookupHptDirectly, listToHpt,
         hptCompleteSigs,
         hptInstances, hptRules, hptVectInfo, pprHPT,
-        hptObjs,
 
         -- * State relating to known packages
         ExternalPackageState(..), EpsStats(..), addEpsInStats,
@@ -688,8 +687,6 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
         -- And get its dfuns
     , thing <- things ]
 
-hptObjs :: HomePackageTable -> [FilePath]
-hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsHpt hpt))
 
 {-
 ************************************************************************
diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs
index e0904b8ad3..c8345276fa 100644
--- a/compiler/main/PipelineMonad.hs
+++ b/compiler/main/PipelineMonad.hs
@@ -15,6 +15,7 @@ import DynFlags
 import DriverPhases
 import HscTypes
 import Module
+import FileCleanup (TempFileLifetime)
 
 import Control.Monad
 
@@ -72,7 +73,7 @@ data PipeState = PipeState {
   }
 
 data PipelineOutput
-  = Temporary
+  = Temporary TempFileLifetime
         -- ^ Output should be to a temporary file: we're going to
         -- run more compilation steps on this output later.
   | Persistent
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 612206bc5d..0a19feb2ce 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -37,24 +37,15 @@ module SysTools (
         copy,
         copyWithHeader,
 
-        -- Temporary-file management
-        setTmpDir,
-        newTempName, newTempLibName,
-        cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
-        addFilesToClean,
-
         Option(..),
 
         -- frameworks
         getPkgFrameworkOpts,
         getFrameworkOpts
-
-
  ) where
 
 #include "HsVersions.h"
 
-import DriverPhases
 import Module
 import Packages
 import Config
@@ -65,11 +56,11 @@ import Platform
 import Util
 import DynFlags
 import Exception
+import FileCleanup
 
 import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)
 
 import Data.IORef
-import Control.Monad
 import System.Exit
 import System.Environment
 import System.FilePath
@@ -78,19 +69,15 @@ import System.IO.Error as IO
 import System.Directory
 import Data.Char
 import Data.List
-import qualified Data.Map as Map
-import qualified Data.Set as Set
 
-#if !defined(mingw32_HOST_OS)
-import qualified System.Posix.Internals
-#else /* Must be Win32 */
-import Foreign
-import Foreign.C.String
+#if defined(mingw32_HOST_OS)
 #if MIN_VERSION_Win32(2,5,0)
 import qualified System.Win32.Types as Win32
 #else
 import qualified System.Win32.Info as Win32
 #endif
+import Foreign
+import Foreign.C.String
 import System.Win32.Types (DWORD, LPTSTR, HANDLE)
 import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)
 import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )
@@ -1035,179 +1022,6 @@ copyWithHeader dflags purpose maybe_header from to = do
    hPutStr h str
    hSetBinaryMode h True
 
-
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Managing temporary files
-*                                                                      *
-************************************************************************
--}
-
-cleanTempDirs :: DynFlags -> IO ()
-cleanTempDirs dflags
-   = unless (gopt Opt_KeepTmpFiles dflags)
-   $ mask_
-   $ do let ref = dirsToClean dflags
-        ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
-        removeTmpDirs dflags (Map.elems ds)
-
-cleanTempFiles :: DynFlags -> IO ()
-cleanTempFiles dflags
-   = unless (gopt Opt_KeepTmpFiles dflags)
-   $ mask_
-   $ do let ref = filesToClean dflags
-        fs <- atomicModifyIORef' ref $ \fs -> ([],fs)
-        removeTmpFiles dflags fs
-
-cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
-cleanTempFilesExcept dflags dont_delete
-   = unless (gopt Opt_KeepTmpFiles dflags)
-   $ mask_
-   $ do let ref = filesToClean dflags
-        to_delete <- atomicModifyIORef' ref $ \files ->
-            let res@(_to_keep, _to_delete) =
-                    partition (`Set.member` dont_delete_set) files
-            in  res
-        removeTmpFiles dflags to_delete
-  where dont_delete_set = Set.fromList dont_delete
-
-
--- Return a unique numeric temp file suffix
-newTempSuffix :: DynFlags -> IO Int
-newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
-
--- Find a temporary name that doesn't already exist.
-newTempName :: DynFlags -> Suffix -> IO FilePath
-newTempName dflags extn
-  = do d <- getTempDir dflags
-       findTempName (d </> "ghc_") -- See Note [Deterministic base name]
-  where
-    findTempName :: FilePath -> IO FilePath
-    findTempName prefix
-      = do n <- newTempSuffix dflags
-           let filename = prefix ++ show n <.> extn
-           b <- doesFileExist filename
-           if b then findTempName prefix
-                else do -- clean it up later
-                        consIORef (filesToClean dflags) filename
-                        return filename
-
-newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String)
-newTempLibName dflags extn
-  = do d <- getTempDir dflags
-       findTempName d ("ghc_")
-  where
-    findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
-    findTempName dir prefix
-      = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
-           let libname = prefix ++ show n
-               filename = dir </> "lib" ++ libname <.> extn
-           b <- doesFileExist filename
-           if b then findTempName dir prefix
-                else do -- clean it up later
-                        consIORef (filesToClean dflags) filename
-                        return (filename, dir, libname)
-
-
--- Return our temporary directory within tmp_dir, creating one if we
--- don't have one yet.
-getTempDir :: DynFlags -> IO FilePath
-getTempDir dflags = do
-    mapping <- readIORef dir_ref
-    case Map.lookup tmp_dir mapping of
-        Nothing -> do
-            pid <- getProcessID
-            let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
-            mask_ $ mkTempDir prefix
-        Just dir -> return dir
-  where
-    tmp_dir = tmpDir dflags
-    dir_ref = dirsToClean dflags
-
-    mkTempDir :: FilePath -> IO FilePath
-    mkTempDir prefix = do
-        n <- newTempSuffix dflags
-        let our_dir = prefix ++ show n
-
-        -- 1. Speculatively create our new directory.
-        createDirectory our_dir
-
-        -- 2. Update the dirsToClean mapping unless an entry already exists
-        -- (i.e. unless another thread beat us to it).
-        their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
-            case Map.lookup tmp_dir mapping of
-                Just dir -> (mapping, Just dir)
-                Nothing  -> (Map.insert tmp_dir our_dir mapping, Nothing)
-
-        -- 3. If there was an existing entry, return it and delete the
-        -- directory we created.  Otherwise return the directory we created.
-        case their_dir of
-            Nothing  -> do
-                debugTraceMsg dflags 2 $
-                    text "Created temporary directory:" <+> text our_dir
-                return our_dir
-            Just dir -> do
-                removeDirectory our_dir
-                return dir
-      `catchIO` \e -> if isAlreadyExistsError e
-                      then mkTempDir prefix else ioError e
-
--- Note [Deterministic base name]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- The filename of temporary files, especially the basename of C files, can end
--- up in the output in some form, e.g. as part of linker debug information. In the
--- interest of bit-wise exactly reproducible compilation (#4012), the basename of
--- the temporary file no longer contains random information (it used to contain
--- the process id).
---
--- This is ok, as the temporary directory used contains the pid (see getTempDir).
-
-addFilesToClean :: DynFlags -> [FilePath] -> IO ()
--- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
-addFilesToClean dflags new_files
-    = atomicModifyIORef' (filesToClean dflags) $ \files -> (new_files++files, ())
-
-removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
-removeTmpDirs dflags ds
-  = traceCmd dflags "Deleting temp dirs"
-             ("Deleting: " ++ unwords ds)
-             (mapM_ (removeWith dflags removeDirectory) ds)
-
-removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
-removeTmpFiles dflags fs
-  = warnNon $
-    traceCmd dflags "Deleting temp files"
-             ("Deleting: " ++ unwords deletees)
-             (mapM_ (removeWith dflags removeFile) deletees)
-  where
-     -- Flat out refuse to delete files that are likely to be source input
-     -- files (is there a worse bug than having a compiler delete your source
-     -- files?)
-     --
-     -- Deleting source files is a sign of a bug elsewhere, so prominently flag
-     -- the condition.
-    warnNon act
-     | null non_deletees = act
-     | otherwise         = do
-        putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
-        act
-
-    (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
-
-removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
-removeWith dflags remover f = remover f `catchIO`
-  (\e ->
-   let msg = if isDoesNotExistError e
-             then text "Warning: deleting non-existent" <+> text f
-             else text "Warning: exception raised when deleting"
-                                            <+> text f <> colon
-               $$ text (show e)
-   in debugTraceMsg dflags 2 msg
-  )
-
 -----------------------------------------------------------------------------
 -- Running an external program
 
@@ -1243,7 +1057,7 @@ runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
         return (r,())
   where
     getResponseFile args = do
-      fp <- newTempName dflags "rsp"
+      fp <- newTempName dflags TFL_CurrentModule "rsp"
       withFile fp WriteMode $ \h -> do
 #if defined(mingw32_HOST_OS)
           hSetEncoding h latin1
@@ -1431,22 +1245,6 @@ data BuildMessage
   | BuildError !SrcLoc !SDoc
   | EOF
 
-traceCmd :: DynFlags -> String -> String -> IO a -> IO a
--- trace the command (at two levels of verbosity)
-traceCmd dflags phase_name cmd_line action
- = do   { let verb = verbosity dflags
-        ; showPass dflags phase_name
-        ; debugTraceMsg dflags 3 (text cmd_line)
-        ; case flushErr dflags of
-              FlushErr io -> io
-
-           -- And run it!
-        ; action `catchIO` handle_exn verb
-        }
-  where
-    handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
-                              ; debugTraceMsg dflags 2 (text "Failed:" <+> text cmd_line <+> text (show exn))
-                              ; throwGhcExceptionIO (ProgramError (show exn))}
 
 {-
 ************************************************************************
@@ -1539,12 +1337,6 @@ foreign import WINDOWS_CCONV unsafe "dynamic"
 getBaseDir = return Nothing
 #endif
 
-#if defined(mingw32_HOST_OS)
-foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
-#else
-getProcessID :: IO Int
-getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
-#endif
 
 -- Divvy up text stream into lines, taking platform dependent
 -- line termination into account.