X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=f0b34228596d8f762030130f4dd8a801c00dc8dd;hb=6a65049a2b80e42ec44ebd775be98a70101ac495;hp=87c55717bd0035e82e005b657ae8e015d7a9c75a;hpb=6c53f40f3dd84cc91a8e6850dbfb271cb24db89a;p=ghc-hetmet.git
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 87c5571..f0b3422 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,13 @@ 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,
@@ -57,11 +66,7 @@ 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 )
@@ -75,7 +80,6 @@ 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 SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
#endif
@@ -200,6 +204,10 @@ 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
@@ -330,7 +338,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
}
@@ -411,7 +420,8 @@ runPp dflags args = do
runCc :: DynFlags -> [Option] -> IO ()
runCc dflags args = do
let (p,args0) = pgm_c dflags
- (args1,mb_env) <- getGccEnv (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
@@ -467,22 +477,27 @@ runCc dflags args = do
isContainedIn :: String -> String -> Bool
xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
--- Turn the -B
option to gcc into the GCC_EXEC_PREFIX env var, to
--- workaround a bug in MinGW gcc on Windows Vista, see bug #1110.
-getGccEnv :: [Option] -> IO ([Option], Maybe [(String,String)])
+-- 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 (opts,Nothing)
+ return Nothing
#else
if null b_dirs
- then return (opts,Nothing)
+ then return Nothing
else do env <- getEnvironment
- return (rest, Just (("GCC_EXEC_PREFIX", head b_dirs) : env))
+ return (Just (map mangle_path env))
where
- (b_dirs, rest) = partitionWith get_b_opt opts
+ (b_dirs, _) = partitionWith get_b_opt opts
get_b_opt (Option ('-':'B':dir)) = Left dir
get_b_opt other = Right other
+
+ mangle_path (path,paths) | map toUpper path == "PATH"
+ = (path, '\"' : head b_dirs ++ "\";" ++ paths)
+ mangle_path other = other
#endif
runMangle :: DynFlags -> [Option] -> IO ()
@@ -498,19 +513,38 @@ 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
- (args1,mb_env) <- getGccEnv (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=" ++ gcc ++ " " ++
+ unwords (map showOpt gcc_args) ++
+ " -E -xc -DRC_INVOKED")
+ : args)
+ -- we must use the PATH workaround here too, since windres invokes gcc
+ mb_env
+
touch :: DynFlags -> String -> String -> IO ()
touch dflags purpose arg =
runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
@@ -530,6 +564,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 `joinFileName` "extra-gcc-opts")
+ return (words f)
\end{code}
%************************************************************************
@@ -573,7 +611,8 @@ 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
@@ -590,6 +629,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
@@ -713,7 +754,11 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
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
@@ -867,12 +912,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