X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=71a721e9ccc8c81079746e126d9ef7dae53abe41;hb=0b3b3ada70a54a3ea29ecfbbfabda33472e2c00c;hp=6d377743c87982935bcc1dfb94c5e5b0bd29d53c;hpb=68db78589f7faa747d26b8f10ba3b037f236c7aa;p=ghc-hetmet.git
diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 6d37774..71a721e 100644
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -7,9 +7,6 @@
-----------------------------------------------------------------------------
\begin{code}
-{-# OPTIONS -fno-cse #-}
--- -fno-cse is needed for GLOBAL_VAR's to behave properly
-
module SysTools (
-- Initialisation
initSysTools,
@@ -48,7 +45,7 @@ import Util
import DynFlags
import FiniteMap
-import Control.Exception
+import Exception
import Data.IORef
import Control.Monad
import System.Exit
@@ -209,7 +206,7 @@ initSysTools mbMinusB dflags0
-- Check that the package config exists
; config_exists <- doesFileExist pkgconfig_path
; when (not config_exists) $
- throwDyn (InstallationError
+ ghcError (InstallationError
("Can't find package.conf as " ++ pkgconfig_path))
-- On Windows, gcc and friends are distributed with GHC,
@@ -225,6 +222,7 @@ initSysTools mbMinusB dflags0
-- gcc can cope
-- (see comments with declarations of global variables)
gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
+ gcc_mingw_include_arg = Option ("-I" ++ installed "include/mingw/")
(gcc_prog,gcc_args)
| isWindowsHost && am_installed
-- We tell gcc where its specs file + exes are (-B)
@@ -236,7 +234,7 @@ initSysTools mbMinusB dflags0
-- the path, possibly including those from a cygwin
-- install on the target, which is exactly what we're
-- trying to avoid.
- = (installed_bin "gcc", [gcc_b_arg])
+ = (installed_bin "gcc", [gcc_b_arg, gcc_mingw_include_arg])
| otherwise = (cGCC, [])
perl_path
| isWindowsHost && am_installed = installed_bin cGHC_PERL
@@ -268,7 +266,7 @@ initSysTools mbMinusB dflags0
[ Option "--dlltool-name",
Option (installed "gcc-lib/" > "dlltool"),
Option "--driver-name",
- Option gcc_prog, gcc_b_arg ])
+ Option gcc_prog, gcc_b_arg, gcc_mingw_include_arg ])
| otherwise = (cMKDLL, [])
-- cpp is derived from gcc on all platforms
@@ -330,7 +328,7 @@ findTopDir mbMinusB
-> do maybe_exec_dir <- getBaseDir -- Get directory of executable
case maybe_exec_dir of -- (only works on Windows;
-- returns Nothing on Unix)
- Nothing -> throwDyn (InstallationError "missing -B
option")
+ Nothing -> ghcError (InstallationError "missing -B option")
Just dir -> return dir
\end{code}
@@ -352,8 +350,11 @@ runCpp :: DynFlags -> [Option] -> IO ()
runCpp dflags args = do
let (p,args0) = pgm_P dflags
args1 = args0 ++ args
- mb_env <- getGccEnv args1
- runSomethingFiltered dflags id "C pre-processor" p args1 mb_env
+ args2 = if dopt Opt_WarnIsError dflags
+ then Option "-Werror" : args1
+ else args1
+ mb_env <- getGccEnv args2
+ runSomethingFiltered dflags id "C pre-processor" p args2 mb_env
runPp :: DynFlags -> [Option] -> IO ()
runPp dflags args = do
@@ -524,32 +525,30 @@ getExtraViaCOpts dflags = do
%************************************************************************
\begin{code}
-GLOBAL_VAR(v_FilesToClean, [], [String] )
-GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
-\end{code}
-
-\begin{code}
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
= unless (dopt Opt_KeepTmpFiles dflags)
- $ do ds <- readIORef v_DirsToClean
+ $ do let ref = dirsToClean dflags
+ ds <- readIORef ref
removeTmpDirs dflags (eltsFM ds)
- writeIORef v_DirsToClean emptyFM
+ writeIORef ref emptyFM
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
= unless (dopt Opt_KeepTmpFiles dflags)
- $ do fs <- readIORef v_FilesToClean
+ $ do let ref = filesToClean dflags
+ fs <- readIORef ref
removeTmpFiles dflags fs
- writeIORef v_FilesToClean []
+ writeIORef ref []
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete
= unless (dopt Opt_KeepTmpFiles dflags)
- $ do files <- readIORef v_FilesToClean
+ $ do let ref = filesToClean dflags
+ files <- readIORef ref
let (to_keep, to_delete) = partition (`elem` dont_delete) files
removeTmpFiles dflags to_delete
- writeIORef v_FilesToClean to_keep
+ writeIORef ref to_keep
-- find a temporary name that doesn't already exist.
@@ -564,14 +563,16 @@ newTempName dflags extn
= do let filename = (prefix ++ show x) <.> extn
b <- doesFileExist filename
if b then findTempName prefix (x+1)
- else do consIORef v_FilesToClean filename -- clean it up later
+ else do -- clean it up later
+ consIORef (filesToClean dflags) filename
return filename
-- return our temporary directory within tmp_dir, creating one if we
-- don't have one yet
getTempDir :: DynFlags -> IO FilePath
getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
- = do mapping <- readIORef v_DirsToClean
+ = do let ref = dirsToClean dflags
+ mapping <- readIORef ref
case lookupFM mapping tmp_dir of
Nothing ->
do x <- getProcessID
@@ -582,7 +583,7 @@ getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
= let dirname = prefix ++ show x
in do createDirectory dirname
let mapping' = addToFM mapping tmp_dir dirname
- writeIORef v_DirsToClean mapping'
+ writeIORef ref mapping'
debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
return dirname
`IO.catch` \e ->
@@ -592,9 +593,9 @@ getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
mkTempDir 0
Just d -> return d
-addFilesToClean :: [FilePath] -> IO ()
+addFilesToClean :: DynFlags -> [FilePath] -> IO ()
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
-addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
+addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs dflags ds
@@ -677,9 +678,9 @@ runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
then return (ExitFailure 1, True)
else IO.ioError err)
case (doesn'tExist, exit_code) of
- (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
+ (True, _) -> ghcError (InstallationError ("could not execute: " ++ pgm))
(_, ExitSuccess) -> return ()
- _ -> throwDyn (PhaseFailed phase_name exit_code)
+ _ -> ghcError (PhaseFailed phase_name exit_code)
builderMainLoop :: DynFlags -> (String -> String) -> FilePath
-> [String] -> Maybe [(String, String)]
@@ -817,7 +818,7 @@ traceCmd dflags phase_name cmd_line action
where
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
- ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
+ ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}
%************************************************************************
@@ -843,16 +844,17 @@ getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
return (Just (rootDir s))
where
rootDir s = case splitFileName $ normalise s of
- (d, "ghc.exe") ->
+ (d, ghc_exe) | lower ghc_exe == "ghc.exe" ->
case splitFileName $ takeDirectory d of
-- installed ghc.exe is in $topdir/bin/ghc.exe
- (d', "bin") -> takeDirectory d'
+ (d', bin) | lower bin == "bin" -> takeDirectory d'
-- inplace ghc.exe is in $topdir/ghc/stage1-inplace/ghc.exe
- (d', x) | "-inplace" `isSuffixOf` x ->
+ (d', x) | "-inplace" `isSuffixOf` lower x ->
takeDirectory d' > ".."
_ -> fail
_ -> fail
where fail = panic ("can't decompose ghc.exe path: " ++ show s)
+ lower = map toLower
foreign import stdcall unsafe "GetModuleFileNameA"
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32