X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=49dd4275bcef2fed73abdc8ea5c0a1cb9fd05a64;hb=9c9071e8ceecfd955ddfc4ad18f9ceb53dd85977;hp=828530bc12c5dde1845e59ac5894c3821d86b04d;hpb=14bdc03c521a1fa64ea8183553ec9d5ff158ff5b;p=ghc-hetmet.git

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 828530b..49dd427 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,
@@ -225,7 +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_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)
@@ -353,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
@@ -525,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.
@@ -565,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
@@ -583,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 ->
@@ -593,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
@@ -844,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) | map toLower ghc_exe == "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