projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix -split-objs: there was a bad interaction with the recent changes
[ghc-hetmet.git]
/
compiler
/
main
/
SysTools.lhs
diff --git
a/compiler/main/SysTools.lhs
b/compiler/main/SysTools.lhs
index
12b73d3
..
3eb5744
100644
(file)
--- a/
compiler/main/SysTools.lhs
+++ b/
compiler/main/SysTools.lhs
@@
-14,7
+14,7
@@
module SysTools (
-- Interface to system tools
runUnlit, runCpp, runCc, -- [Option] -> IO ()
runPp, -- [Option] -> IO ()
-- 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,
runAs, runLink, -- [Option] -> IO ()
runMkDLL,
runWindres,
@@
-45,9
+45,8
@@
import ErrUtils
import Panic
import Util
import DynFlags
import Panic
import Util
import DynFlags
-import FiniteMap
-
import Exception
import Exception
+
import Data.IORef
import Control.Monad
import System.Exit
import Data.IORef
import Control.Monad
import System.Exit
@@
-58,6
+57,7
@@
import System.IO.Error as IO
import System.Directory
import Data.Char
import Data.List
import System.Directory
import Data.Char
import Data.List
+import qualified Data.Map as Map
#ifndef mingw32_HOST_OS
import qualified System.Posix.Internals
#ifndef mingw32_HOST_OS
import qualified System.Posix.Internals
@@
-66,7
+66,7
@@
import Foreign
import Foreign.C.String
#endif
import Foreign.C.String
#endif
-import System.Process ( runInteractiveProcess, getProcessExitCode )
+import System.Process
import Control.Concurrent
import FastString
import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
import Control.Concurrent
import FastString
import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
@@
-171,9
+171,8
@@
initSysTools mbMinusB dflags0
-- architecture-specific stuff is done when building Config.hs
unlit_path = installed cGHC_UNLIT_PGM
-- 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
split_script = installed cGHC_SPLIT_PGM
- mangle_script = installed cGHC_MANGLER_PGM
windres_path = installed_mingw_bin "windres"
windres_path = installed_mingw_bin "windres"
@@
-194,7
+193,7
@@
initSysTools mbMinusB dflags0
| isWindowsHost = installed cGHC_TOUCHY_PGM
| otherwise = "touch"
-- On Win32 we don't want to rely on #!/bin/perl, so we prepend
| 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
-- 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
@@
-202,9
+201,6
@@
initSysTools mbMinusB dflags0
(split_prog, split_args)
| isWindowsHost = (perl_path, [Option split_script])
| otherwise = (split_script, [])
(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"
(mkdll_prog, mkdll_args)
| not isWindowsHost
= panic "Can't build DLLs on a non-Win32 system"
@@
-234,7
+230,6
@@
initSysTools mbMinusB dflags0
pgm_P = cpp_path,
pgm_F = "",
pgm_c = (gcc_prog,[]),
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_s = (split_prog,split_args),
pgm_a = (as_prog,[]),
pgm_l = (ld_prog,[]),
@@
-372,11
+367,6
@@
getGccEnv opts =
= (path, '\"' : head b_dirs ++ "\";" ++ paths)
mangle_path other = other
= (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
runSplit :: DynFlags -> [Option] -> IO ()
runSplit dflags args = do
let (p,args0) = pgm_s dflags
@@
-472,8
+462,8
@@
cleanTempDirs dflags
= unless (dopt Opt_KeepTmpFiles dflags)
$ do let ref = dirsToClean dflags
ds <- readIORef ref
= 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
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
@@
-515,7
+505,7
@@
getTempDir :: DynFlags -> IO FilePath
getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
= do let ref = dirsToClean dflags
mapping <- readIORef ref
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 ++ "_"
Nothing ->
do x <- getProcessID
let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
@@
-524,11
+514,11
@@
getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
mkTempDir x
= let dirname = prefix ++ show x
in do createDirectory dirname
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
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
if isAlreadyExistsError e
then mkTempDir (x+1)
else ioError e
@@
-567,7
+557,7
@@
removeTmpFiles dflags fs
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
(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
(\e ->
let msg = if isDoesNotExistError e
then ptext (sLit "Warning: deleting non-existent") <+> text f
@@
-597,9
+587,14
@@
runSomethingFiltered
runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
let real_args = filter notNull (map showOpt args)
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) <-
(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)
rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
case rc of
ExitSuccess{} -> return (rc, False)
@@
-751,7
+746,7
@@
traceCmd dflags phase_name cmd_line action
; unless (dopt Opt_DryRun dflags) $ do {
-- And run it!
; 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')
}}
where
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')