runAs, runLink, -- [Option] -> IO ()
runMkDLL,
runWindres,
+ runLlvmOpt,
+ runLlvmLlc,
touch, -- String -> String -> IO ()
copy,
import Panic
import Util
import DynFlags
-import FiniteMap
import Exception
import Data.IORef
import System.IO.Error as IO
import System.Directory
import Data.Char
-import Data.Maybe
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 )
; 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"
; 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
| 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
; 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,
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
}
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
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 =
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
= 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
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
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
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
rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
-- 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.
| 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