X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=a76cb53b5d23b2b30b5ea3c3d7da541cba52668b;hp=eee3e1a38354a3e6b511288663466fb186dfb66b;hb=9bbcd77cf9b66940058dbea1827db594e8ff6d7f;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index eee3e1a..a76cb53 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -11,10 +11,6 @@ module SysTools ( -- 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 () @@ -23,55 +19,42 @@ module SysTools ( runMkDLL, touch, -- String -> String -> IO () - copy, -- String -> String -> String -> IO () + copy, + copyWithHeader, normalisePath, -- FilePath -> FilePath -- 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 #include "HsVersions.h" -import DriverPhases ( isHaskellUserSrcFilename ) +import DriverPhases import Config import Outputable -import ErrUtils ( putMsg, debugTraceMsg, showPass, Severity(..), Messages ) -import Panic ( GhcException(..) ) -import Util ( Suffix, global, notNull, consIORef, joinFileName, - normalisePath, pgmPath, platformPath, joinFileExt ) -import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..), - setTmpDir, defaultDynFlags ) - -import EXCEPTION ( throwDyn, finally ) -import DATA_IOREF ( IORef, readIORef, writeIORef ) -import DATA_INT - -import Monad ( when, unless ) -import System ( ExitCode(..), getEnv, system ) -import IO ( try, catch, hGetContents, - openFile, hPutStr, hClose, hFlush, IOMode(..), - stderr, ioError, isDoesNotExistError ) -import Directory ( doesFileExist, removeFile ) -import Maybe ( isJust ) -import List ( partition ) - --- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command --- lines on mingw32, so we disallow it now. -#if __GLASGOW_HASKELL__ < 500 -#error GHC >= 5.00 is required for bootstrapping GHC -#endif +import ErrUtils +import Panic +import Util +import DynFlags +import FiniteMap + +import Control.Exception +import Data.IORef +import Control.Monad +import System.Exit +import System.Environment +import System.IO +import SYSTEM_IO_ERROR as IO +import System.Directory +import Data.Char +import Data.Maybe +import Data.List #ifndef mingw32_HOST_OS #if __GLASGOW_HASKELL__ > 504 @@ -80,24 +63,18 @@ import qualified System.Posix.Internals import qualified Posix #endif #else /* Must be Win32 */ -import List ( isPrefixOf ) -import Util ( dropList ) import Foreign import CString ( CString, peekCString ) #endif -import Text.Regex - #if __GLASGOW_HASKELL__ < 603 -- rawSystem comes from libghccompat.a in stage1 -import Compat.RawSystem ( rawSystem ) +import Compat.RawSystem ( rawSystem ) +import System.Cmd ( system ) import GHC.IOBase ( IOErrorType(..) ) -import System.IO.Error ( ioeGetErrorType ) #else import System.Process ( runInteractiveProcess, getProcessExitCode ) -import System.IO ( hSetBuffering, hGetLine, BufferMode(..) ) import Control.Concurrent( forkIO, newChan, readChan, writeChan ) -import Data.Char ( isSpace ) import FastString ( mkFastString ) import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) #endif @@ -165,34 +142,6 @@ stuff. 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 - --- 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} @@ -211,11 +160,11 @@ initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) 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 @@ -365,19 +314,11 @@ initSysTools mbMinusB dflags ; 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 = "", @@ -386,7 +327,12 @@ initSysTools mbMinusB dflags 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) @@ -464,21 +410,85 @@ runPp dflags args = do runCc :: DynFlags -> [Option] -> IO () runCc dflags args = do let (p,args0) = pgm_c dflags - runSomethingFiltered dflags cc_filter "C Compiler" p (args0++args) + args1 = args0 ++ args + mb_env <- getGccEnv args1 + runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env where -- discard some harmless warnings from gcc that we can't turn off - cc_filter str = unlines (do_filter (lines str)) + cc_filter = unlines . doFilter . lines + + {- + gcc gives warnings in chunks like so: + In file included from /foo/bar/baz.h:11, + from /foo/bar/baz2.h:22, + from wibble.c:33: + /foo/flibble:14: global register variable ... + /foo/flibble:15: warning: call-clobbered r... + We break it up into its chunks, remove any call-clobbered register + warnings from each chunk, and then delete any chunks that we have + emptied of warnings. + -} + doFilter = unChunkWarnings . filterWarnings . chunkWarnings [] + -- We can't assume that the output will start with an "In file inc..." + -- line, so we start off expecting a list of warnings rather than a + -- location stack. + chunkWarnings :: [String] -- The location stack to use for the next + -- list of warnings + -> [String] -- The remaining lines to look at + -> [([String], [String])] + chunkWarnings loc_stack [] = [(loc_stack, [])] + chunkWarnings loc_stack xs + = case break loc_stack_start xs of + (warnings, lss:xs') -> + case span loc_start_continuation xs' of + (lsc, xs'') -> + (loc_stack, warnings) : chunkWarnings (lss : lsc) xs'' + _ -> [(loc_stack, xs)] + + filterWarnings :: [([String], [String])] -> [([String], [String])] + filterWarnings [] = [] + -- If the warnings are already empty then we are probably doing + -- something wrong, so don't delete anything + filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs + filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of + [] -> filterWarnings zs + ys' -> (xs, ys') : filterWarnings zs + + unChunkWarnings :: [([String], [String])] -> [String] + unChunkWarnings [] = [] + unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs + + loc_stack_start s = "In file included from " `isPrefixOf` s + loc_start_continuation s = " from " `isPrefixOf` s + wantedWarning w + | "warning: call-clobbered register used" `isContainedIn` w = False + | otherwise = True + +isContainedIn :: String -> String -> Bool +xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) + +-- If the -B option is set, add to PATH. This works around +-- a bug in gcc on Windows Vista where it can't find its auxiliary +-- binaries (see bug #1110). +getGccEnv :: [Option] -> IO (Maybe [(String,String)]) +getGccEnv opts = +#if __GLASGOW_HASKELL__ < 603 + return Nothing +#else + if null b_dirs + then return Nothing + else do env <- getEnvironment + return (Just (map mangle_path env)) + where + (b_dirs, _) = partitionWith get_b_opt opts - do_filter [] = [] - do_filter ls@(l:ls') - | (w:rest) <- dropWhile (isJust .matchRegex r_from) ls, - isJust (matchRegex r_warn w) - = do_filter rest - | otherwise - = l : do_filter ls' + get_b_opt (Option ('-':'B':dir)) = Left dir + get_b_opt other = Right other - r_from = mkRegex "from.*:[0-9]+" - r_warn = mkRegex "warning: call-clobbered register used" + mangle_path (path,paths) | map toUpper path == "PATH" + = (path, '\"' : head b_dirs ++ "\";" ++ paths) + mangle_path other = other +#endif runMangle :: DynFlags -> [Option] -> IO () runMangle dflags args = do @@ -493,48 +503,45 @@ runSplit dflags args = do runAs :: DynFlags -> [Option] -> IO () runAs dflags args = do let (p,args0) = pgm_a dflags - runSomething dflags "Assembler" p (args0++args) + args1 = args0 ++ args + mb_env <- getGccEnv args1 + runSomethingFiltered dflags id "Assembler" p args1 mb_env runLink :: DynFlags -> [Option] -> IO () runLink dflags args = do let (p,args0) = pgm_l dflags - runSomething dflags "Linker" p (args0++args) + args1 = args0 ++ args + mb_env <- getGccEnv args1 + runSomethingFiltered dflags id "Linker" p args1 mb_env runMkDLL :: DynFlags -> [Option] -> IO () runMkDLL dflags args = do let (p,args0) = pgm_dll dflags - runSomething dflags "Make DLL" p (args0++args) + args1 = args0 ++ args + mb_env <- getGccEnv (args0++args) + runSomethingFiltered dflags id "Make DLL" p args1 mb_env 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 -> FilePath -> FilePath -> IO () +copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to -copy :: DynFlags -> String -> String -> String -> IO () -copy dflags purpose from to = do +copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath + -> IO () +copyWithHeader dflags purpose maybe_header from to = do showPass dflags purpose h <- openFile to WriteMode ls <- readFile from -- inefficient, but it'll do for now. -- ToDo: speed up via slurping. + maybe (return ()) (hPutStr h) maybe_header 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 @@ -543,28 +550,39 @@ getUsageMsgPaths = readIORef v_Path_usages \begin{code} GLOBAL_VAR(v_FilesToClean, [], [String] ) +GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath ) \end{code} \begin{code} +cleanTempDirs :: DynFlags -> IO () +cleanTempDirs dflags + = unless (dopt Opt_KeepTmpFiles dflags) + $ do ds <- readIORef v_DirsToClean + removeTmpDirs dflags (eltsFM ds) + writeIORef v_DirsToClean emptyFM + cleanTempFiles :: DynFlags -> IO () cleanTempFiles dflags - = do fs <- readIORef v_FilesToClean - removeTmpFiles dflags fs - writeIORef v_FilesToClean [] + = unless (dopt Opt_KeepTmpFiles dflags) + $ do fs <- readIORef v_FilesToClean + removeTmpFiles dflags fs + writeIORef v_FilesToClean [] cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO () cleanTempFilesExcept dflags dont_delete - = do files <- readIORef v_FilesToClean - let (to_keep, to_delete) = partition (`elem` dont_delete) files - removeTmpFiles dflags to_delete - writeIORef v_FilesToClean to_keep + = unless (dopt Opt_KeepTmpFiles dflags) + $ do files <- readIORef v_FilesToClean + let (to_keep, to_delete) = partition (`elem` dont_delete) files + removeTmpFiles dflags to_delete + writeIORef v_FilesToClean to_keep -- 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 @@ -573,16 +591,45 @@ newTempName DynFlags{tmpDir=tmp_dir} 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 @@ -598,11 +645,16 @@ removeTmpFiles dflags fs (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 @@ -616,17 +668,18 @@ runSomething :: DynFlags -> IO () runSomething dflags phase_name pgm args = - runSomethingFiltered dflags id phase_name pgm args + runSomethingFiltered dflags id phase_name pgm args Nothing runSomethingFiltered - :: DynFlags -> (String->String) -> String -> String -> [Option] -> IO () + :: DynFlags -> (String->String) -> String -> String -> [Option] + -> Maybe [(String,String)] -> IO () -runSomethingFiltered dflags filter_fn phase_name pgm args = do +runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do let real_args = filter notNull (map showOpt args) traceCmd dflags phase_name (unwords (pgm:real_args)) $ do (exit_code, doesn'tExist) <- IO.catch (do - rc <- builderMainLoop dflags filter_fn pgm real_args + rc <- builderMainLoop dflags filter_fn pgm real_args mb_env case rc of ExitSuccess{} -> return (rc, False) ExitFailure n @@ -658,12 +711,12 @@ runSomethingFiltered dflags filter_fn phase_name pgm args = do #if __GLASGOW_HASKELL__ < 603 -builderMainLoop dflags filter_fn pgm real_args = do +builderMainLoop dflags filter_fn pgm real_args mb_env = do rawSystem pgm real_args #else -builderMainLoop dflags filter_fn pgm real_args = do +builderMainLoop dflags filter_fn pgm real_args mb_env = do chan <- newChan - (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing + (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env -- and run a loop piping the output from the compiler to the log_action in DynFlags hSetBuffering hStdOut LineBuffering @@ -704,7 +757,7 @@ builderMainLoop dflags filter_fn pgm real_args = do 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 @@ -725,23 +778,41 @@ readerProc chan hdl filter_fn = checkError l ls checkError l ls - = case matchRegex errRegex l of + = case parseError l of Nothing -> do writeChan chan (BuildMsg (text l)) loop ls Nothing - Just (file':lineno':colno':msg:_) -> do - let file = mkFastString file' - lineno = read lineno'::Int - colno = case colno' of - "" -> 0 - _ -> read (init colno') :: Int - srcLoc = mkSrcLoc file lineno colno + Just (file, lineNum, colNum, msg) -> do + let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum loop ls (Just (BuildError srcLoc (text msg))) leading_whitespace [] = False leading_whitespace (x:_) = isSpace x -errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)" +parseError :: String -> Maybe (String, Int, Int, String) +parseError s0 = case breakColon s0 of + Just (filename, s1) -> + case breakIntColon s1 of + Just (lineNum, s2) -> + case breakIntColon s2 of + Just (columnNum, s3) -> + Just (filename, lineNum, columnNum, s3) + Nothing -> + Just (filename, lineNum, 0, s2) + Nothing -> Nothing + Nothing -> Nothing + +breakColon :: String -> Maybe (String, String) +breakColon xs = case break (':' ==) xs of + (ys, _:zs) -> Just (ys, zs) + _ -> Nothing + +breakIntColon :: String -> Maybe (Int, String) +breakIntColon xs = case break (':' ==) xs of + (ys, _:zs) + | not (null ys) && all isAscii ys && all isDigit ys -> + Just (read ys, zs) + _ -> Nothing data BuildMessage = BuildMsg !SDoc @@ -814,4 +885,22 @@ getProcessID :: IO Int 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}