X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=97a5ea7bf6b8867f9507a6bdf56af532404af286;hp=b657f91aab25667b2d54f8060e06e4013fc0eacb;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hpb=aee2068e034aca6ddaf6f20f85902137ecf718b7 diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index b657f91..97a5ea7 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -7,6 +7,13 @@ ----------------------------------------------------------------------------- \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module SysTools ( -- Initialisation initSysTools, @@ -17,11 +24,12 @@ module SysTools ( runMangle, runSplit, -- [Option] -> IO () runAs, runLink, -- [Option] -> IO () runMkDLL, + runWindres, touch, -- String -> String -> IO () copy, copyWithHeader, - normalisePath, -- FilePath -> FilePath + getExtraViaCOpts, -- Temporary-file management setTmpDir, @@ -49,37 +57,25 @@ import Data.IORef import Control.Monad import System.Exit import System.Environment +import System.FilePath 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 import qualified System.Posix.Internals -#else -import qualified Posix -#endif #else /* Must be Win32 */ 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 System.Cmd ( system ) -import GHC.IOBase ( IOErrorType(..) ) -#else import System.Process ( runInteractiveProcess, getProcessExitCode ) import Control.Concurrent( forkIO, newChan, readChan, writeChan ) -import Data.Char ( isSpace ) -import FastString ( mkFastString ) +import FastString import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) -#endif \end{code} @@ -169,10 +165,15 @@ initSysTools mbMinusB dflags -- format, '/' separated ; let installed, installed_bin :: FilePath -> FilePath - installed_bin pgm = pgmPath top_dir pgm - installed file = pgmPath top_dir file - inplace dir pgm = pgmPath (top_dir `joinFileName` - cPROJECT_DIR `joinFileName` dir) pgm + installed_bin pgm = top_dir pgm + installed file = top_dir file + inplace dir pgm = top_dir +#ifndef darwin_TARGET_OS +-- Not sure where cPROJECT_DIR makes sense, on Mac OS, building with +-- xcodebuild, it surely is a *bad* idea! -=chak + cPROJECT_DIR +#endif + dir pgm ; let pkgconfig_path | am_installed = installed "package.conf" @@ -201,32 +202,14 @@ initSysTools mbMinusB dflags | am_installed = installed_bin cGHC_MANGLER_PGM | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM + windres_path + | am_installed = installed_bin "bin/windres" + | otherwise = "windres" + ; let dflags0 = defaultDynFlags -#ifndef mingw32_HOST_OS - -- check whether TMPDIR is set in the environment - ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set -#else - -- On Win32, consult GetTempPath() for a temp dir. - -- => it first tries TMP, TEMP, then finally the - -- Windows directory(!). The directory is in short-path - -- form. - ; e_tmpdir <- - IO.try (do - let len = (2048::Int) - buf <- mallocArray len - ret <- getTempPath len buf - if ret == 0 then do - -- failed, consult TMPDIR. - free buf - getEnv "TMPDIR" - else do - s <- peekCString buf - free buf - return s) -#endif - ; let dflags1 = case e_tmpdir of - Left _ -> dflags0 - Right d -> setTmpDir d dflags0 + + ; tmpdir <- getTemporaryDirectory + ; let dflags1 = setTmpDir tmpdir dflags0 -- Check that the package config exists ; config_exists <- doesFileExist pkgconfig_path @@ -259,9 +242,6 @@ initSysTools mbMinusB dflags -- later on; although gcc_args are in NATIVE format, -- gcc can cope -- (see comments with declarations of global variables) - -- - -- The quotes round the -B argument are in case TopDir - -- has spaces in it perl_path | am_installed = installed_bin cGHC_PERL | otherwise = cGHC_PERL @@ -277,9 +257,9 @@ initSysTools mbMinusB dflags ; let (mkdll_prog, mkdll_args) | am_installed = - (pgmPath (installed "gcc-lib/") cMKDLL, + (installed "gcc-lib/" cMKDLL, [ Option "--dlltool-name", - Option (pgmPath (installed "gcc-lib/") "dlltool"), + Option (installed "gcc-lib/" "dlltool"), Option "--driver-name", Option gcc_prog, gcc_b_arg ]) | otherwise = (cMKDLL, []) @@ -331,7 +311,8 @@ initSysTools mbMinusB dflags pgm_l = (ld_prog,ld_args), pgm_dll = (mkdll_prog,mkdll_args), pgm_T = touch_path, - pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan" + pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", + pgm_windres = windres_path -- Hans: this isn't right in general, but you can -- elaborate it in the same way as the others } @@ -369,14 +350,14 @@ findTopDir mbMinusB = do { top_dir <- get_proto -- Discover whether we're running in a build tree or in an installation, -- by looking for the package configuration file. - ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf") + ; am_installed <- doesFileExist (top_dir "package.conf") ; return (am_installed, top_dir) } where -- get_proto returns a Unix-format path (relying on getBaseDir to do so too) get_proto = case mbMinusB of - Just minusb -> return (normalisePath minusb) + Just minusb -> return (normalise minusb) Nothing -> do maybe_exec_dir <- getBaseDir -- Get directory of executable case maybe_exec_dir of -- (only works on Windows; @@ -402,7 +383,9 @@ runUnlit dflags args = do runCpp :: DynFlags -> [Option] -> IO () runCpp dflags args = do let (p,args0) = pgm_P dflags - runSomething dflags "C pre-processor" p (args0 ++ args) + args1 = args0 ++ args + mb_env <- getGccEnv args1 + runSomethingFiltered dflags id "C pre-processor" p args1 mb_env runPp :: DynFlags -> [Option] -> IO () runPp dflags args = do @@ -412,21 +395,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 defined(__GLASGOW_HASKELL__) && __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 @@ -441,17 +488,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 + +runWindres :: DynFlags -> [Option] -> IO () +runWindres dflags args = do + let (gcc,gcc_args) = pgm_c dflags + windres = pgm_windres dflags + mb_env <- getGccEnv gcc_args + runSomethingFiltered dflags id "Windres" windres + -- we must tell windres where to find gcc: it might not be on PATH + (Option ("--preprocessor=" ++ + unwords (map quote (gcc : map showOpt gcc_args ++ + ["-E", "-xc", "-DRC_INVOKED"]))) + -- -- use-temp-file is required for windres to interpret the + -- quoting in the preprocessor arg above correctly. Without + -- this, windres calls the preprocessor with popen, which gets + -- the quoting wrong (discovered by experimentation and + -- reading the windres sources). See #1828. + : Option "--use-temp-file" + : args) + -- we must use the PATH workaround here too, since windres invokes gcc + mb_env + where + quote x = '\"' : x ++ "\"" touch :: DynFlags -> String -> String -> IO () touch dflags purpose arg = @@ -472,6 +547,10 @@ copyWithHeader dflags purpose maybe_header from to = do hPutStr h ls hClose h +getExtraViaCOpts :: DynFlags -> IO [String] +getExtraViaCOpts dflags = do + f <- readFile (topDir dflags "extra-gcc-opts") + return (words f) \end{code} %************************************************************************ @@ -515,13 +594,14 @@ newTempName dflags extn = do d <- getTempDir dflags x <- getProcessID findTempName (d ++ "/ghc" ++ show x ++ "_") 0 - where + where + findTempName :: FilePath -> Integer -> IO FilePath findTempName prefix x - = do let filename = (prefix ++ show x) `joinFileExt` extn - b <- doesFileExist filename - if b then findTempName prefix (x+1) - else do consIORef v_FilesToClean filename -- clean it up later - return filename + = do let filename = (prefix ++ show x) <.> extn + b <- doesFileExist filename + if b then findTempName prefix (x+1) + 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 @@ -532,6 +612,8 @@ getTempDir dflags@(DynFlags{tmpDir=tmp_dir}) Nothing -> do x <- getProcessID let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_" + let + mkTempDir :: Integer -> IO FilePath mkTempDir x = let dirname = prefix ++ show x in do createDirectory dirname @@ -600,17 +682,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 @@ -641,20 +724,24 @@ runSomethingFiltered dflags filter_fn phase_name pgm args = do -#if __GLASGOW_HASKELL__ < 603 -builderMainLoop dflags filter_fn pgm real_args = do +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 +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 hSetBuffering hStdErr LineBuffering forkIO (readerProc chan hStdOut filter_fn) forkIO (readerProc chan hStdErr filter_fn) - rc <- loop chan hProcess 2 1 ExitSuccess + -- we don't want to finish until 2 streams have been completed + -- (stdout and stderr) + -- nor until 1 exit code has been retrieved. + rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess + -- after that, we're done here. hClose hStdIn hClose hStdOut hClose hStdErr @@ -709,23 +796,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 @@ -733,8 +838,7 @@ data BuildMessage | EOF #endif -showOpt (FileOption pre f) = pre ++ platformPath f -showOpt (Option "") = "" +showOpt (FileOption pre f) = pre ++ f showOpt (Option s) = s traceCmd :: DynFlags -> String -> String -> IO () -> IO () @@ -780,7 +884,12 @@ getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32. free buf return (Just (rootDir s)) where - rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s))) + rootDir s = case splitFileName $ normalise s of + (d, "ghc.exe") -> + case splitFileName $ takeDirectory d of + (d', "bin") -> takeDirectory d' + _ -> panic ("Expected \"bin\" in " ++ show s) + _ -> panic ("Expected \"ghc.exe\" in " ++ show s) foreign import stdcall unsafe "GetModuleFileNameA" getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 @@ -790,12 +899,9 @@ getBaseDir = return Nothing #ifdef mingw32_HOST_OS foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows -#elif __GLASGOW_HASKELL__ > 504 -getProcessID :: IO Int -getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral #else getProcessID :: IO Int -getProcessID = Posix.getProcessID +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral #endif -- Divvy up text stream into lines, taking platform dependent