X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=d33fd6c8c6e9f17cb43565cf2e3bdb2d81f92942;hb=3deca8f44135bd1a146902f498189af00dd4d7b4;hp=c8960dc1ade93edd2ea0fa12a2b84a2893cb920e;hpb=e51cdf9b6e54fb4052e46b6d7afb15e062928467;p=ghc-hetmet.git diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index c8960dc..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,6 +57,7 @@ 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 @@ -64,7 +66,7 @@ import Foreign 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,6 +161,7 @@ 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.d" ghc_usage_msg_path = installed "ghc-usage.txt" @@ -184,7 +187,7 @@ initSysTools mbMinusB dflags0 | isWindowsHost = installed_mingw_bin "gcc" | otherwise = cGCC perl_path - | isWindowsHost = installed_mingw_bin cGHC_PERL + | isWindowsHost = installed_perl_bin cGHC_PERL | otherwise = cGHC_PERL -- 'touch' is a GHC util for Windows touch_path @@ -218,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, @@ -234,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 } @@ -380,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 @@ -453,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 @@ -479,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 @@ -496,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 @@ -548,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 @@ -578,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) @@ -732,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')