X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=f5812f478f364d5c7d62609e834a05b7540e8440;hb=98c68a1c5b63aadf9c7917274519d95bbe9394d4;hp=17ed501deea7bcd5c627e617482df546b2457278;hpb=b1ab4b8a607addc4d097588db5761313c996a41f;p=ghc-hetmet.git diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 17ed501..f5812f4 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 ) @@ -199,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 @@ -257,9 +266,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 @@ -329,7 +335,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 } @@ -400,7 +407,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 @@ -485,7 +494,8 @@ getGccEnv opts = get_b_opt (Option ('-':'B':dir)) = Left dir get_b_opt other = Right other - mangle_path ("PATH",paths) = ("PATH", '\"' : head b_dirs ++ "\";" ++ paths) + mangle_path (path,paths) | map toUpper path == "PATH" + = (path, '\"' : head b_dirs ++ "\";" ++ paths) mangle_path other = other #endif @@ -509,7 +519,9 @@ runAs dflags args = do 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 @@ -518,6 +530,28 @@ runMkDLL dflags args = do 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 = runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] @@ -537,6 +571,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} %************************************************************************ @@ -580,7 +618,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 @@ -597,6 +636,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 @@ -720,7 +761,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 @@ -818,7 +863,6 @@ data BuildMessage #endif showOpt (FileOption pre f) = pre ++ platformPath f -showOpt (Option "") = "" showOpt (Option s) = s traceCmd :: DynFlags -> String -> String -> IO () -> IO () @@ -874,12 +918,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