Get building GHC itself with Cabal more-or-less working

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

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 9fccdc7..9d53b81 100644 (file)
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -7,12 +7,8 @@
 -----------------------------------------------------------------------------
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
 
 module SysTools (
         -- Initialisation
@@ -59,7 +55,7 @@ import System.Exit
 import System.Environment
 import System.FilePath
 import System.IO
-import SYSTEM_IO_ERROR as IO
+import System.IO.Error as IO
 import System.Directory
 import Data.Char
 import Data.Maybe
@@ -73,7 +69,7 @@ import CString          ( CString, peekCString )
 #endif
 
 import System.Process   ( runInteractiveProcess, getProcessExitCode )
-import Control.Concurrent( forkIO, newChan, readChan, writeChan )
+import Control.Concurrent
 import FastString
 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
 \end{code}
@@ -156,7 +152,7 @@ initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
                                 --      (c) the GHC usage message
 
 
-initSysTools mbMinusB dflags
+initSysTools mbMinusB dflags0
   = do  { (am_installed, top_dir) <- findTopDir mbMinusB
                 -- top_dir
                 --      for "installed" this is the root of GHC's support files
@@ -165,9 +161,14 @@ initSysTools mbMinusB dflags
                 -- format, '/' separated
 
         ; let installed, installed_bin :: FilePath -> FilePath
-              installed_bin pgm   =  top_dir </> pgm
-              installed     file  =  top_dir </> file
-              inplace dir   pgm   =  top_dir </> dir </> pgm
+              installed_bin pgm  = top_dir </> pgm
+              installed     file = top_dir </> file
+              inplace dir   pgm  = let real_top_dir = foldr (</>) ""
+                                                    $ reverse
+                                                    $ drop 4
+                                                    $ reverse
+                                                    $ splitDirectories top_dir
+                                   in real_top_dir </> dir </> pgm
 
         ; let pkgconfig_path
                 | am_installed = installed "package.conf"
@@ -200,8 +201,6 @@ initSysTools mbMinusB dflags
                 | am_installed = installed_bin "bin/windres"
                 | otherwise    = "windres"
 
-        ; let dflags0 = defaultDynFlags
-
         ; tmpdir <- getTemporaryDirectory
         ; let dflags1 = setTmpDir tmpdir dflags0
 
@@ -276,10 +275,6 @@ initSysTools mbMinusB dflags
         ; let cpp_path  = (gcc_prog, gcc_args ++
                            (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
 
-        -- For all systems, copy and remove are provided by the host
-        -- system; architecture-specific stuff is done when building Config.hs
-        ; let   cp_path = cGHC_CP
-
         -- Other things being equal, as and ld are simply gcc
         ; let   (as_prog,as_args)  = (gcc_prog,gcc_args)
                 (ld_prog,ld_args)  = (gcc_prog,gcc_args)
@@ -441,9 +436,6 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
 -- binaries (see bug #1110).
 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
 getGccEnv opts =
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
-  return Nothing
-#else
   if null b_dirs
      then return Nothing
      else do env <- getEnvironment
@@ -457,7 +449,6 @@ getGccEnv opts =
   mangle_path (path,paths) | map toUpper path == "PATH"
         = (path, '\"' : head b_dirs ++ "\";" ++ paths)
   mangle_path other = other
-#endif
 
 runMangle :: DynFlags -> [Option] -> IO ()
 runMangle dflags args = do
@@ -694,11 +685,6 @@ runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
                 -- to test for this in general.)
               (\ err ->
                 if IO.isDoesNotExistError err
-#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
-                -- the 'compat' version of rawSystem under mingw32 always
-                -- maps 'errno' to EINVAL to failure.
-                   || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
-#endif
                  then return (ExitFailure 1, True)
                  else IO.ioError err)
   case (doesn'tExist, exit_code) of
@@ -706,12 +692,9 @@ runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
      (_, ExitSuccess) -> return ()
      _                -> throwDyn (PhaseFailed phase_name exit_code)
 
-
-
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
-builderMainLoop dflags filter_fn pgm real_args mb_env = do
-  rawSystem pgm real_args
-#else
+builderMainLoop :: DynFlags -> (String -> String) -> FilePath
+                -> [String] -> Maybe [(String, String)]
+                -> IO ExitCode
 builderMainLoop dflags filter_fn pgm real_args mb_env = do
   chan <- newChan
   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
@@ -736,7 +719,7 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
     -- for all of these to happen (status==3).
     -- ToDo: we should really have a contingency plan in case any of
     -- the threads dies, such as a timeout.
-    loop chan hProcess 0 0 exitcode = return exitcode
+    loop _    _        0 0 exitcode = return exitcode
     loop chan hProcess t p exitcode = do
       mb_code <- if p > 0
                    then getProcessExitCode hProcess
@@ -757,6 +740,7 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
                   loop chan hProcess (t-1) p exitcode
           | otherwise -> loop chan hProcess t p exitcode
 
+readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
 readerProc chan hdl filter_fn =
     (do str <- hGetContents hdl
         loop (linesPlatform (filter_fn str)) Nothing)
@@ -778,6 +762,7 @@ readerProc chan hdl filter_fn =
                         checkError l ls
                   Nothing -> do
                         checkError l ls
+                  _ -> panic "readerProc/loop"
 
         checkError l ls
            = case parseError l of
@@ -820,8 +805,8 @@ data BuildMessage
   = BuildMsg   !SDoc
   | BuildError !SrcLoc !SDoc
   | EOF
-#endif
 
+showOpt :: Option -> String
 showOpt (FileOption pre f) = pre ++ f
 showOpt (Option s)  = s
 
@@ -841,9 +826,9 @@ traceCmd dflags phase_name cmd_line action
         ; action `IO.catch` handle_exn verb
         }}
   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)) }
+    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)) }
 \end{code}
 
 %************************************************************************