X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=d33fd6c8c6e9f17cb43565cf2e3bdb2d81f92942;hb=3deca8f44135bd1a146902f498189af00dd4d7b4;hp=7a37b4c6d1c81c76ac896ce7f0e0f9a19beae42e;hpb=caf2112355b82016e3644a31b52249129b48a3ab;p=ghc-hetmet.git diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 7a37b4c..d33fd6c 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -18,6 +18,8 @@ module SysTools ( runAs, runLink, -- [Option] -> IO () runMkDLL, runWindres, + runLlvmOpt, + runLlvmLlc, touch, -- String -> String -> IO () copy, @@ -43,9 +45,8 @@ import ErrUtils import Panic import Util import DynFlags -import FiniteMap - import Exception + import Data.IORef import Control.Monad import System.Exit @@ -56,15 +57,16 @@ import System.IO.Error as IO import System.Directory import Data.Char import Data.List +import qualified Data.Map as Map #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 ) +import System.Process import Control.Concurrent import FastString import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) @@ -159,8 +161,9 @@ initSysTools mbMinusB dflags0 ; let installed :: FilePath -> FilePath installed file = top_dir file installed_mingw_bin file = top_dir ".." "mingw" "bin" file + installed_perl_bin file = top_dir ".." "perl" 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" @@ -177,12 +180,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 @@ -190,7 +187,7 @@ initSysTools mbMinusB dflags0 | isWindowsHost = installed_mingw_bin "gcc" | otherwise = cGCC perl_path - | isWindowsHost = installed cGHC_PERL + | isWindowsHost = installed_perl_bin cGHC_PERL | otherwise = cGHC_PERL -- 'touch' is a GHC util for Windows touch_path @@ -224,6 +221,10 @@ initSysTools mbMinusB dflags0 ; let as_prog = gcc_prog ld_prog = gcc_prog + -- figure out llvm location. (TODO: Acutally implement). + ; let lc_prog = "llc" + lo_prog = "opt" + ; return dflags1{ ghcUsagePath = ghc_usage_msg_path, ghciUsagePath = ghci_usage_msg_path, @@ -240,7 +241,9 @@ initSysTools mbMinusB dflags0 pgm_dll = (mkdll_prog,mkdll_args), pgm_T = touch_path, pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", - pgm_windres = windres_path + pgm_windres = windres_path, + pgm_lo = (lo_prog,[]), + pgm_lc = (lc_prog,[]) -- Hans: this isn't right in general, but you can -- elaborate it in the same way as the others } @@ -386,6 +389,16 @@ runAs dflags args = do mb_env <- getGccEnv args1 runSomethingFiltered dflags id "Assembler" p args1 mb_env +runLlvmOpt :: DynFlags -> [Option] -> IO () +runLlvmOpt dflags args = do + let (p,args0) = pgm_lo dflags + runSomething dflags "LLVM Optimiser" p (args0++args) + +runLlvmLlc :: DynFlags -> [Option] -> IO () +runLlvmLlc dflags args = do + let (p,args0) = pgm_lc dflags + runSomething dflags "LLVM Compiler" p (args0++args) + runLink :: DynFlags -> [Option] -> IO () runLink dflags args = do let (p,args0) = pgm_l dflags @@ -402,10 +415,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 = @@ -445,8 +472,8 @@ cleanTempDirs dflags = unless (dopt Opt_KeepTmpFiles dflags) $ do let ref = dirsToClean dflags ds <- readIORef ref - removeTmpDirs dflags (eltsFM ds) - writeIORef ref emptyFM + removeTmpDirs dflags (Map.elems ds) + writeIORef ref Map.empty cleanTempFiles :: DynFlags -> IO () cleanTempFiles dflags @@ -471,7 +498,7 @@ newTempName :: DynFlags -> Suffix -> IO FilePath newTempName dflags extn = do d <- getTempDir dflags x <- getProcessID - findTempName (d ++ "/ghc" ++ show x ++ "_") 0 + findTempName (d "ghc" ++ show x ++ "_") 0 where findTempName :: FilePath -> Integer -> IO FilePath findTempName prefix x @@ -488,20 +515,20 @@ getTempDir :: DynFlags -> IO FilePath getTempDir dflags@(DynFlags{tmpDir=tmp_dir}) = do let ref = dirsToClean dflags mapping <- readIORef ref - case lookupFM mapping tmp_dir of + case Map.lookup tmp_dir mapping of Nothing -> do x <- getProcessID - let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_" + let prefix = tmp_dir "ghc" ++ show x ++ "_" let mkTempDir :: Integer -> IO FilePath mkTempDir x = let dirname = prefix ++ show x in do createDirectory dirname - let mapping' = addToFM mapping tmp_dir dirname + let mapping' = Map.insert tmp_dir dirname mapping writeIORef ref mapping' debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname) return dirname - `IO.catch` \e -> + `catchIO` \e -> if isAlreadyExistsError e then mkTempDir (x+1) else ioError e @@ -540,7 +567,7 @@ removeTmpFiles dflags fs (non_deletees, deletees) = partition isHaskellUserSrcFilename fs removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () -removeWith dflags remover f = remover f `IO.catch` +removeWith dflags remover f = remover f `catchIO` (\e -> let msg = if isDoesNotExistError e then ptext (sLit "Warning: deleting non-existent") <+> text f @@ -570,9 +597,14 @@ runSomethingFiltered 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 +#if __GLASGOW_HASKELL__ >= 701 + cmdLine = showCommandForUser pgm real_args +#else + cmdLine = unwords (pgm:real_args) +#endif + traceCmd dflags phase_name cmdLine $ do (exit_code, doesn'tExist) <- - IO.catch (do + catchIO (do rc <- builderMainLoop dflags filter_fn pgm real_args mb_env case rc of ExitSuccess{} -> return (rc, False) @@ -724,7 +756,7 @@ traceCmd dflags phase_name cmd_line action ; unless (dopt Opt_DryRun dflags) $ do { -- And run it! - ; action `IO.catch` handle_exn verb + ; action `catchIO` handle_exn verb }} where handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')