X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=9bc26cfddbceab8e17cdf9bcb2fa7bf0e480ae45;hp=a64d73e11c7aa6fb2517f7c1b0bcb704b3187a79;hb=f3a77b2f46ebc27716f45ae426a3b33b853d52f5;hpb=34cc75e1a62638f2833815746ebce0a9114dc26b diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index a64d73e..9bc26cf 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -7,6 +7,7 @@ ----------------------------------------------------------------------------- \begin{code} +{-# OPTIONS -fno-warn-unused-do-bind #-} module SysTools ( -- Initialisation initSysTools, @@ -14,15 +15,17 @@ module SysTools ( -- Interface to system tools runUnlit, runCpp, runCc, -- [Option] -> IO () runPp, -- [Option] -> IO () - runMangle, runSplit, -- [Option] -> IO () + runSplit, -- [Option] -> IO () runAs, runLink, -- [Option] -> IO () runMkDLL, runWindres, + runLlvmOpt, + runLlvmLlc, + readElfSection, touch, -- String -> String -> IO () copy, copyWithHeader, - getExtraViaCOpts, -- Temporary-file management setTmpDir, @@ -43,9 +46,8 @@ import ErrUtils import Panic import Util import DynFlags -import FiniteMap - import Exception + import Data.IORef import Control.Monad import System.Exit @@ -55,17 +57,19 @@ import System.IO import System.IO.Error as IO import System.Directory import Data.Char -import Data.Maybe import Data.List +import qualified Data.Map as Map +import Text.ParserCombinators.ReadP hiding (char) +import qualified Text.ParserCombinators.ReadP as R #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 ) @@ -157,11 +161,25 @@ initSysTools mbMinusB dflags0 -- NB: top_dir is assumed to be in standard Unix -- format, '/' separated + ; let settingsFile = top_dir "settings" + ; settingsStr <- readFile settingsFile + ; mySettings <- case maybeReadFuzzy settingsStr of + Just s -> + return s + Nothing -> + pgmError ("Can't parse " ++ show settingsFile) + ; let getSetting key = case lookup key mySettings of + Just xs -> + return xs + Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) + ; myExtraGccViaCFlags <- getSetting "GCC extra via C opts" + ; 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" @@ -169,21 +187,14 @@ initSysTools mbMinusB dflags0 -- architecture-specific stuff is done when building Config.hs unlit_path = installed cGHC_UNLIT_PGM - -- split and mangle are Perl scripts + -- split is a Perl script split_script = installed cGHC_SPLIT_PGM - mangle_script = installed cGHC_MANGLER_PGM windres_path = installed_mingw_bin "windres" ; 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,14 +202,14 @@ 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 | isWindowsHost = installed cGHC_TOUCHY_PGM | otherwise = "touch" -- On Win32 we don't want to rely on #!/bin/perl, so we prepend - -- a call to Perl to get the invocation of split and mangle. + -- a call to Perl to get the invocation of split. -- On Unix, scripts are invoked using the '#!' method. Binary -- installations of GHC on Unix place the correct line on the -- front of the script at installation time, so we don't want @@ -206,9 +217,6 @@ initSysTools mbMinusB dflags0 (split_prog, split_args) | isWindowsHost = (perl_path, [Option split_script]) | otherwise = (split_script, []) - (mangle_prog, mangle_args) - | isWindowsHost = (perl_path, [Option mangle_script]) - | otherwise = (mangle_script, []) (mkdll_prog, mkdll_args) | not isWindowsHost = panic "Can't build DLLs on a non-Win32 system" @@ -225,23 +233,30 @@ 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, topDir = top_dir, + settings = mySettings, + extraGccViaCFlags = words myExtraGccViaCFlags, systemPackageConfig = pkgconfig_path, pgm_L = unlit_path, pgm_P = cpp_path, pgm_F = "", pgm_c = (gcc_prog,[]), - pgm_m = (mangle_prog,mangle_args), pgm_s = (split_prog,split_args), pgm_a = (as_prog,[]), pgm_l = (ld_prog,[]), 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 } @@ -370,11 +385,6 @@ getGccEnv opts = = (path, '\"' : head b_dirs ++ "\";" ++ paths) mangle_path other = other -runMangle :: DynFlags -> [Option] -> IO () -runMangle dflags args = do - let (p,args0) = pgm_m dflags - runSomething dflags "Mangler" p (args0++args) - runSplit :: DynFlags -> [Option] -> IO () runSplit dflags args = do let (p,args0) = pgm_s dflags @@ -387,6 +397,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 @@ -403,10 +423,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,17 +454,34 @@ 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 - -getExtraViaCOpts :: DynFlags -> IO [String] -getExtraViaCOpts dflags = do - f <- readFile (topDir dflags "extra-gcc-opts") - return (words f) + 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 + +-- | read the contents of the named section in an ELF object as a +-- String. +readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String) +readElfSection _dflags section exe = do + let + prog = "readelf" + args = [Option "-p", Option section, FileOption "" exe] + -- + r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) "" + case r of + (ExitSuccess, out, _err) -> return (doFilter (lines out)) + _ -> return Nothing + where + doFilter [] = Nothing + doFilter (s:r) = case readP_to_S parse s of + [(p,"")] -> Just p + _r -> doFilter r + where parse = do + skipSpaces; R.char '['; skipSpaces; string "0]"; skipSpaces; + munch (const True) \end{code} %************************************************************************ @@ -445,8 +496,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 @@ -462,8 +513,8 @@ cleanTempFilesExcept dflags dont_delete $ do let ref = filesToClean dflags files <- readIORef ref let (to_keep, to_delete) = partition (`elem` dont_delete) files - removeTmpFiles dflags to_delete writeIORef ref to_keep + removeTmpFiles dflags to_delete -- find a temporary name that doesn't already exist. @@ -471,7 +522,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 +539,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 +591,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 +621,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) @@ -607,8 +663,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 +767,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 @@ -728,7 +780,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')