X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=c8960dc1ade93edd2ea0fa12a2b84a2893cb920e;hp=a64d73e11c7aa6fb2517f7c1b0bcb704b3187a79;hb=e51cdf9b6e54fb4052e46b6d7afb15e062928467;hpb=34cc75e1a62638f2833815746ebce0a9114dc26b diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index a64d73e..c8960dc 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -55,14 +55,13 @@ 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 import qualified System.Posix.Internals #else /* Must be Win32 */ import Foreign -import CString ( CString, peekCString ) +import Foreign.C.String #endif import System.Process ( runInteractiveProcess, getProcessExitCode ) @@ -161,7 +160,7 @@ initSysTools mbMinusB dflags0 installed file = top_dir file installed_mingw_bin file = top_dir ".." "mingw" "bin" file - ; let pkgconfig_path = installed "package.conf" + ; let pkgconfig_path = installed "package.conf.d" ghc_usage_msg_path = installed "ghc-usage.txt" ghci_usage_msg_path = installed "ghci-usage.txt" @@ -178,12 +177,6 @@ initSysTools mbMinusB dflags0 ; tmpdir <- getTemporaryDirectory ; let dflags1 = setTmpDir tmpdir dflags0 - -- Check that the package config exists - ; config_exists <- doesFileExist pkgconfig_path - ; when (not config_exists) $ - ghcError (InstallationError - ("Can't find package.conf as " ++ pkgconfig_path)) - -- On Windows, mingw is distributed with GHC, -- so we look in TopDir/../mingw/bin ; let @@ -191,7 +184,7 @@ initSysTools mbMinusB dflags0 | isWindowsHost = installed_mingw_bin "gcc" | otherwise = cGCC perl_path - | isWindowsHost = installed cGHC_PERL + | isWindowsHost = installed_mingw_bin cGHC_PERL | otherwise = cGHC_PERL -- 'touch' is a GHC util for Windows touch_path @@ -403,10 +396,24 @@ runMkDLL dflags args = do runWindres :: DynFlags -> [Option] -> IO () runWindres dflags args = do - let (_gcc,gcc_args) = pgm_c dflags - windres = pgm_windres dflags + let (gcc, gcc_args) = pgm_c dflags + windres = pgm_windres dflags + quote x = "\"" ++ x ++ "\"" + args' = -- If windres.exe and gcc.exe are in a directory containing + -- spaces then windres fails to run gcc. We therefore need + -- to tell it what command to use... + Option ("--preprocessor=" ++ + unwords (map quote (gcc : + map showOpt gcc_args ++ + ["-E", "-xc", "-DRC_INVOKED"]))) + -- ...but if we do that then if windres calls popen then + -- it can't understand the quoting, so we have to use + -- --use-temp-file so that it interprets it correctly. + -- See #1828. + : Option "--use-temp-file" + : args mb_env <- getGccEnv gcc_args - runSomethingFiltered dflags id "Windres" windres args mb_env + runSomethingFiltered dflags id "Windres" windres args' mb_env touch :: DynFlags -> String -> String -> IO () touch dflags purpose arg = @@ -420,12 +427,13 @@ copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath 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 + hout <- openBinaryFile to WriteMode + hin <- openBinaryFile from ReadMode + ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up + maybe (return ()) (hPutStr hout) maybe_header + hPutStr hout ls + hClose hout + hClose hin getExtraViaCOpts :: DynFlags -> IO [String] getExtraViaCOpts dflags = do @@ -607,8 +615,8 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do -- 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) + _ <- forkIO (readerProc chan hStdOut filter_fn) + _ <- forkIO (readerProc chan hStdErr filter_fn) -- we don't want to finish until 2 streams have been completed -- (stdout and stderr) -- nor until 1 exit code has been retrieved. @@ -711,10 +719,6 @@ data BuildMessage | BuildError !SrcLoc !SDoc | EOF -showOpt :: Option -> String -showOpt (FileOption pre f) = pre ++ f -showOpt (Option s) = s - traceCmd :: DynFlags -> String -> String -> IO () -> IO () -- a) trace the command (at two levels of verbosity) -- b) don't do it at all if dry-run is set