X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=12b73d3bf259a0c47c5cadba0ec230ea8364c717;hb=f1a72b2938cc289c9a3879301ab445ec9efd63dd;hp=357616bfb90e682719395038aa284b642bbe698a;hpb=fb97019335ae012a11bbfb229b08d18316dcd1df;p=ghc-hetmet.git diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 357616b..12b73d3 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, @@ -55,14 +57,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 ) @@ -160,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" @@ -178,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 @@ -191,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 @@ -225,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, @@ -241,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 } @@ -387,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 @@ -403,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 = @@ -472,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 @@ -492,7 +518,7 @@ getTempDir dflags@(DynFlags{tmpDir=tmp_dir}) case lookupFM mapping tmp_dir 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 @@ -608,8 +634,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. @@ -712,10 +738,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