Refactor TcRnDriver, and check exports on hi-boot files

[ghc-hetmet.git] / compiler / main / SysTools.lhs

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index e44ed6d..b550d3c 100644 (file)
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -19,7 +19,8 @@ module SysTools (
        runMkDLL,
 
        touch,                  -- String -> String -> IO ()
-       copy,                   -- String -> String -> String -> IO ()
+       copy,
+        copyWithHeader,
        normalisePath,          -- FilePath -> FilePath
        
        -- Temporary-file management
@@ -28,9 +29,6 @@ module SysTools (
        cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
        addFilesToClean,
 
-       -- System interface
-       system,                 -- String -> IO ExitCode
-
        Option(..)
 
  ) where
@@ -48,7 +46,6 @@ import FiniteMap
 
 import Control.Exception
 import Data.IORef
-import Data.Int
 import Control.Monad
 import System.Exit
 import System.Environment
@@ -58,12 +55,6 @@ import System.Directory
 import Data.Maybe
 import Data.List
 
--- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
--- lines on mingw32, so we disallow it now.
-#if __GLASGOW_HASKELL__ < 500
-#error GHC >= 5.00 is required for bootstrapping GHC
-#endif
-
 #ifndef mingw32_HOST_OS
 #if __GLASGOW_HASKELL__ > 504
 import qualified System.Posix.Internals
@@ -71,8 +62,6 @@ import qualified System.Posix.Internals
 import qualified Posix
 #endif
 #else /* Must be Win32 */
-import List            ( isPrefixOf )
-import Util            ( dropList )
 import Foreign
 import CString         ( CString, peekCString )
 #endif
@@ -85,7 +74,6 @@ import Compat.RawSystem ( rawSystem )
 import System.Cmd       ( system )
 import GHC.IOBase       ( IOErrorType(..) ) 
 #else
-import System.Cmd       ( rawSystem, system )
 import System.Process  ( runInteractiveProcess, getProcessExitCode )
 import Control.Concurrent( forkIO, newChan, readChan, writeChan )
 import Data.Char        ( isSpace )
@@ -424,7 +412,8 @@ runPp dflags args =   do
 runCc :: DynFlags -> [Option] -> IO ()
 runCc dflags args =   do 
   let (p,args0) = pgm_c dflags
-  runSomethingFiltered dflags cc_filter "C Compiler" p (args0++args)
+  (args1,mb_env) <- getGccEnv (args0++args)
+  runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
  where
   -- discard some harmless warnings from gcc that we can't turn off
   cc_filter str = unlines (do_filter (lines str))
@@ -440,6 +429,24 @@ runCc dflags args =   do
   r_from = mkRegex "from.*:[0-9]+"
   r_warn = mkRegex "warning: call-clobbered register used"
 
+-- Turn the -B<dir> option to gcc into the GCC_EXEC_PREFIX env var, to
+-- workaround a bug in MinGW gcc on Windows Vista, see bug #1110.
+getGccEnv :: [Option] -> IO ([Option], Maybe [(String,String)])
+getGccEnv opts = 
+#if __GLASGOW_HASKELL__ < 603
+  return (opts,Nothing)
+#else
+  if null b_dirs
+     then return (opts,Nothing)
+     else do env <- getEnvironment
+             return (rest, Just (("GCC_EXEC_PREFIX", head b_dirs) : env))
+ where
+  (b_dirs, rest) = partitionWith get_b_opt opts
+
+  get_b_opt (Option ('-':'B':dir)) = Left dir
+  get_b_opt other = Right other  
+#endif
+
 runMangle :: DynFlags -> [Option] -> IO ()
 runMangle dflags args = do 
   let (p,args0) = pgm_m dflags
@@ -463,21 +470,28 @@ runLink dflags args = do
 runMkDLL :: DynFlags -> [Option] -> IO ()
 runMkDLL dflags args = do
   let (p,args0) = pgm_dll dflags
-  runSomething dflags "Make DLL" p (args0++args)
+  (args1,mb_env) <- getGccEnv (args0++args)
+  runSomethingFiltered dflags id "Make DLL" p args1 mb_env
 
 touch :: DynFlags -> String -> String -> IO ()
 touch dflags purpose arg =
   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
 
-copy :: DynFlags -> String -> String -> String -> IO ()
-copy dflags purpose from to = do
+copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
+copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
+
+copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
+               -> IO ()
+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
+
 \end{code}
 
 %************************************************************************
@@ -606,17 +620,18 @@ runSomething :: DynFlags
             -> IO ()
 
 runSomething dflags phase_name pgm args = 
-  runSomethingFiltered dflags id phase_name pgm args
+  runSomethingFiltered dflags id phase_name pgm args Nothing
 
 runSomethingFiltered
-  :: DynFlags -> (String->String) -> String -> String -> [Option] -> IO ()
+  :: DynFlags -> (String->String) -> String -> String -> [Option]
+  -> Maybe [(String,String)] -> IO ()
 
-runSomethingFiltered dflags filter_fn phase_name pgm args = do
+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
   (exit_code, doesn'tExist) <- 
      IO.catch (do
-         rc <- builderMainLoop dflags filter_fn pgm real_args
+         rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
         case rc of
           ExitSuccess{} -> return (rc, False)
           ExitFailure n 
@@ -648,12 +663,12 @@ runSomethingFiltered dflags filter_fn phase_name pgm args = do
 
 
 #if __GLASGOW_HASKELL__ < 603
-builderMainLoop dflags filter_fn pgm real_args = do
+builderMainLoop dflags filter_fn pgm real_args mb_env = do
   rawSystem pgm real_args
 #else
-builderMainLoop dflags filter_fn pgm real_args = do
+builderMainLoop dflags filter_fn pgm real_args mb_env = do
   chan <- newChan
-  (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing
+  (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
 
   -- and run a loop piping the output from the compiler to the log_action in DynFlags
   hSetBuffering hStdOut LineBuffering