-- Initialisation
initSysTools,
- getTopDir, -- IO String -- The value of $topdir
- getPackageConfigPath, -- IO String -- Where package.conf is
- getUsageMsgPaths, -- IO (String,String)
-
-- Interface to system tools
runUnlit, runCpp, runCc, -- [Option] -> IO ()
runPp, -- [Option] -> IO ()
-- Temporary-file management
setTmpDir,
newTempName,
- cleanTempFiles, cleanTempFilesExcept,
+ cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
addFilesToClean,
-- System interface
system, -- String -> IO ExitCode
- -- Misc
- getSysMan, -- IO String Parallel system only
-
Option(..)
) where
import System ( ExitCode(..), getEnv, system )
import IO ( try, catch, hGetContents,
openFile, hPutStr, hClose, hFlush, IOMode(..),
- stderr, ioError, isDoesNotExistError )
-import Directory ( doesFileExist, removeFile )
+ stderr, ioError, isDoesNotExistError,
+ isAlreadyExistsError )
+import Directory ( doesFileExist, removeFile,
+ createDirectory, removeDirectory )
import Maybe ( isJust )
import List ( partition )
+import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, eltsFM )
-- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
-- lines on mingw32, so we disallow it now.
End of NOTES
---------------------------------------------
-
-%************************************************************************
-%* *
-\subsection{Global variables to contain system programs}
-%* *
-%************************************************************************
-
-All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
-(See remarks under pathnames below)
-
-\begin{code}
-GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
-GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
-
-GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
-GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String))
-
-GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
-
--- Parallel system only
-GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
-
--- ways to get at some of these variables from outside this module
-getPackageConfigPath = readIORef v_Path_package_config
-getTopDir = readIORef v_TopDir
-\end{code}
-
-
%************************************************************************
%* *
\subsection{Initialisation}
initSysTools mbMinusB dflags
= do { (am_installed, top_dir) <- findTopDir mbMinusB
- ; writeIORef v_TopDir top_dir
-- top_dir
-- for "installed" this is the root of GHC's support files
-- for "in-place" it is the root of the build tree
- -- NB: top_dir is assumed to be in standard Unix format '/' separated
+ -- NB: top_dir is assumed to be in standard Unix
+ -- format, '/' separated
; let installed, installed_bin :: FilePath -> FilePath
installed_bin pgm = pgmPath top_dir pgm
; let (as_prog,as_args) = (gcc_prog,gcc_args)
(ld_prog,ld_args) = (gcc_prog,gcc_args)
- -- Initialise the global vars
- ; writeIORef v_Path_package_config pkgconfig_path
- ; writeIORef v_Path_usages (ghc_usage_msg_path,
- ghci_usage_msg_path)
-
- ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
- -- Hans: this isn't right in general, but you can
- -- elaborate it in the same way as the others
-
- ; writeIORef v_Pgm_T touch_path
- ; writeIORef v_Pgm_CP cp_path
-
; return dflags1{
+ ghcUsagePath = ghc_usage_msg_path,
+ ghciUsagePath = ghci_usage_msg_path,
+ topDir = top_dir,
+ systemPackageConfig = pkgconfig_path,
pgm_L = unlit_path,
pgm_P = cpp_path,
pgm_F = "",
pgm_s = (split_prog,split_args),
pgm_a = (as_prog,as_args),
pgm_l = (ld_prog,ld_args),
- pgm_dll = (mkdll_prog,mkdll_args) }
+ pgm_dll = (mkdll_prog,mkdll_args),
+ pgm_T = touch_path,
+ pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan"
+ -- Hans: this isn't right in general, but you can
+ -- elaborate it in the same way as the others
+ }
}
#if defined(mingw32_HOST_OS)
runSomething dflags "Make DLL" p (args0++args)
touch :: DynFlags -> String -> String -> IO ()
-touch dflags purpose arg = do
- p <- readIORef v_Pgm_T
- runSomething dflags purpose p [FileOption "" arg]
+touch dflags purpose arg =
+ runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
copy :: DynFlags -> String -> String -> String -> IO ()
copy dflags purpose from to = do
-- ToDo: speed up via slurping.
hPutStr h ls
hClose h
-
-\end{code}
-
-\begin{code}
-getSysMan :: IO String -- How to invoke the system manager
- -- (parallel system only)
-getSysMan = readIORef v_Pgm_sysman
\end{code}
-\begin{code}
-getUsageMsgPaths :: IO (FilePath,FilePath)
- -- the filenames of the usage messages (ghc, ghci)
-getUsageMsgPaths = readIORef v_Path_usages
-\end{code}
-
-
%************************************************************************
%* *
\subsection{Managing temporary files
\begin{code}
GLOBAL_VAR(v_FilesToClean, [], [String] )
+GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
\end{code}
\begin{code}
+cleanTempDirs :: DynFlags -> IO ()
+cleanTempDirs dflags
+ = do ds <- readIORef v_DirsToClean
+ removeTmpDirs dflags (eltsFM ds)
+ writeIORef v_DirsToClean emptyFM
+
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
= do fs <- readIORef v_FilesToClean
-- find a temporary name that doesn't already exist.
newTempName :: DynFlags -> Suffix -> IO FilePath
-newTempName DynFlags{tmpDir=tmp_dir} extn
- = do x <- getProcessID
- findTempName (tmp_dir ++ "/ghc" ++ show x ++ "_") 0
+newTempName dflags extn
+ = do d <- getTempDir dflags
+ x <- getProcessID
+ findTempName (d ++ "/ghc" ++ show x ++ "_") 0
where
findTempName prefix x
= do let filename = (prefix ++ show x) `joinFileExt` extn
else do consIORef v_FilesToClean filename -- clean it up later
return filename
+-- return our temporary directory within tmp_dir, creating one if we
+-- don't have one yet
+getTempDir :: DynFlags -> IO FilePath
+getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
+ = do mapping <- readIORef v_DirsToClean
+ case lookupFM mapping tmp_dir of
+ Nothing ->
+ do x <- getProcessID
+ let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
+ mkTempDir x
+ = let dirname = prefix ++ show x
+ in do createDirectory dirname
+ let mapping' = addToFM mapping tmp_dir dirname
+ writeIORef v_DirsToClean mapping'
+ debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
+ return dirname
+ `IO.catch` \e ->
+ if isAlreadyExistsError e
+ then mkTempDir (x+1)
+ else ioError e
+ mkTempDir 0
+ Just d -> return d
+
addFilesToClean :: [FilePath] -> IO ()
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
addFilesToClean files = mapM_ (consIORef v_FilesToClean) 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_ rm 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
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
- rm f = removeFile f `IO.catch`
- (\_ignored ->
- debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
- )
-
+removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
+removeWith dflags remover f = remover f `IO.catch`
+ (\e ->
+ let msg = if isDoesNotExistError e
+ then ptext SLIT("Warning: deleting non-existent") <+> text f
+ else ptext SLIT("Warning: exception raised when deleting")
+ <+> text f <> colon
+ $$ text (show e)
+ in debugTraceMsg dflags 2 msg
+ )
-----------------------------------------------------------------------------
-- Running an external program
readerProc chan hdl filter_fn =
(do str <- hGetContents hdl
- loop (lines (filter_fn str)) Nothing)
+ loop (linesPlatform (filter_fn str)) Nothing)
`finally`
writeChan chan EOF
-- ToDo: check errors more carefully
getProcessID = Posix.getProcessID
#endif
+-- Divvy up text stream into lines, taking platform dependent
+-- line termination into account.
+linesPlatform :: String -> [String]
+#if !defined(mingw32_HOST_OS)
+linesPlatform ls = lines ls
+#else
+linesPlatform "" = []
+linesPlatform xs =
+ case lineBreak xs of
+ (as,xs1) -> as : linesPlatform xs1
+ where
+ lineBreak "" = ("","")
+ lineBreak ('\r':'\n':xs) = ([],xs)
+ lineBreak ('\n':xs) = ([],xs)
+ lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
+
+#endif
+
\end{code}
projects / ghc-hetmet.git / blobdiff