runAs, runLink, -- [Option] -> IO ()
runMkDLL,
runWindres,
- runLlvmAs,
runLlvmOpt,
runLlvmLlc,
import Panic
import Util
import DynFlags
-import FiniteMap
-
import Exception
+
import Data.IORef
import Control.Monad
import System.Exit
import System.Directory
import Data.Char
import Data.List
+import qualified Data.Map as Map
#ifndef mingw32_HOST_OS
import qualified System.Posix.Internals
import Foreign.C.String
#endif
-import System.Process ( runInteractiveProcess, getProcessExitCode )
+import System.Process
import Control.Concurrent
import FastString
import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
ld_prog = gcc_prog
-- figure out llvm location. (TODO: Acutally implement).
- ; let la_prog = "llvm-as"
- lc_prog = "llc"
+ ; let lc_prog = "llc"
lo_prog = "opt"
; return dflags1{
pgm_T = touch_path,
pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
pgm_windres = windres_path,
- pgm_la = (la_prog,[]),
pgm_lo = (lo_prog,[]),
pgm_lc = (lc_prog,[])
-- Hans: this isn't right in general, but you can
mb_env <- getGccEnv args1
runSomethingFiltered dflags id "Assembler" p args1 mb_env
-runLlvmAs :: DynFlags -> [Option] -> IO ()
-runLlvmAs dflags args = do
- let (p,args0) = pgm_la dflags
- runSomething dflags "LLVM Assembler" p (args0++args)
-
runLlvmOpt :: DynFlags -> [Option] -> IO ()
runLlvmOpt dflags args = do
let (p,args0) = pgm_lo 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
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 ++ "_"
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
(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
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)
; 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')