From 3ee3822ce588565e912ab6211e9d2cd545fc6ba6 Mon Sep 17 00:00:00 2001 From: Douglas Wilson Date: Thu, 8 Jun 2017 14:59:49 -0400 Subject: 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 --- compiler/ghc.cabal.in | 1 + compiler/ghc.mk | 1 + compiler/ghci/Linker.hs | 8 +- compiler/iface/MkIface.hs | 4 +- compiler/main/CodeOutput.hs | 6 +- compiler/main/DriverMkDepend.hs | 5 +- compiler/main/DriverPipeline.hs | 70 ++++++----- compiler/main/DynFlags.hs | 32 +++++- compiler/main/ErrUtils.hs | 21 ++++ compiler/main/FileCleanup.hs | 249 ++++++++++++++++++++++++++++++++++++++++ compiler/main/GHC.hs | 3 +- compiler/main/GhcMake.hs | 81 ++++++------- compiler/main/HscTypes.hs | 3 - compiler/main/PipelineMonad.hs | 3 +- compiler/main/SysTools.hs | 218 +---------------------------------- 15 files changed, 401 insertions(+), 304 deletions(-) create mode 100644 compiler/main/FileCleanup.hs (limited to 'compiler') 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. -- cgit v1.2.1