X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=d1fd9f7c400b22c146aaf76d10b73b3615d1eab2;hb=5892af0e08fdb890b5a0b9a64346d9f7773a6ed8;hp=a5362aa7a2373d51c6b968601664ad44b4926953;hpb=c272ec8db91d874b53dcf74168e51e2fdc8d1516;p=ghc-hetmet.git diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index a5362aa..d1fd9f7 100644 --- 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 @@ -52,14 +48,14 @@ import Util import DynFlags import FiniteMap -import Control.Exception +import Exception import Data.IORef import Control.Monad 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,29 +69,38 @@ 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} +How GHC finds its files +~~~~~~~~~~~~~~~~~~~~~~~ - The configuration story - ~~~~~~~~~~~~~~~~~~~~~~~ +[Note topdir] GHC needs various support files (library packages, RTS etc), plus -various auxiliary programs (cp, gcc, etc). It finds these in one -of two places: +various auxiliary programs (cp, gcc, etc). It starts by finding topdir: -* When running as an *installed program*, GHC finds most of this support - stuff in the installed library tree. The path to this tree is passed - to GHC via the -B flag, and given to initSysTools . + for "installed" topdir is the root of GHC's support files ($libdir) + for "in-place" topdir is the root of the build tree -* When running *in-place* in a build tree, GHC finds most of this support - stuff in the build tree. The path to the build tree is, again passed - to GHC via -B. +On Unix: + - ghc always has a shell wrapper that passes a -B option + - in an installation, is $libdir + - in a build tree, is $TOP/inplace-datadir + - so we detect the build-tree case and add ".." to get us back to $TOP -GHC tells which of the two is the case by seeing whether package.conf -is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack). +On Windows: + - ghc never has a shell wrapper. + - we can find the location of the ghc binary, which is + $topdir/bin/ghc.exe in an installation, or + $topdir/ghc/stage1-inplace/ghc.exe in a build tree. + - we detect which one of these we have, and calculate $topdir. + + +from topdir we can find package.conf, which contains the locations of +almost everything else, whether we're in a build tree or installed. SysTools.initSysProgs figures out exactly where all the auxiliary programs @@ -156,22 +161,20 @@ 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 - -- for "in-place" it is the root of the build tree + -- see [Note topdir] -- NB: top_dir is assumed to be in standard Unix -- 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 = top_dir dir pgm ; let pkgconfig_path | am_installed = installed "package.conf" - | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace" + | otherwise = inplace "inplace-datadir" "package.conf" ghc_usage_msg_path | am_installed = installed "ghc-usage.txt" @@ -200,81 +203,74 @@ initSysTools mbMinusB dflags | am_installed = installed_bin "bin/windres" | otherwise = "windres" - ; let dflags0 = defaultDynFlags - ; tmpdir <- getTemporaryDirectory ; let dflags1 = setTmpDir tmpdir 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)) -#if defined(mingw32_HOST_OS) - -- WINDOWS-SPECIFIC STUFF -- On Windows, gcc and friends are distributed with GHC, -- so when "installed" we look in TopDir/bin - -- When "in-place" we look wherever the build-time configure - -- script found them - -- When "install" we tell gcc where its specs file + exes are (-B) - -- and also some places to pick up include files. We need - -- to be careful to put all necessary exes in the -B place - -- (as, ld, cc1, etc) since if they don't get found there, gcc - -- then tries to run unadorned "as", "ld", etc, and will - -- pick up whatever happens to be lying around in the path, - -- possibly including those from a cygwin install on the target, - -- which is exactly what we're trying to avoid. - ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/") + -- When "in-place", or when not on Windows, we look wherever + -- the build-time configure script found them + ; let + -- The trailing "/" is absolutely essential; gcc seems + -- to construct file names simply by concatenating to + -- this -B path with no extra slash We use "/" rather + -- than "\\" because otherwise "\\\" is mangled + -- later on; although gcc_args are in NATIVE format, + -- 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) - | am_installed = (installed_bin "gcc", [gcc_b_arg]) - | otherwise = (cGCC, []) - -- The trailing "/" is absolutely essential; gcc seems - -- to construct file names simply by concatenating to - -- this -B path with no extra slash We use "/" rather - -- than "\\" because otherwise "\\\" is mangled - -- later on; although gcc_args are in NATIVE format, - -- gcc can cope - -- (see comments with declarations of global variables) - - perl_path | am_installed = installed_bin cGHC_PERL - | otherwise = cGHC_PERL - - -- 'touch' is a GHC util for Windows, and similarly unlit, mangle - ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM - | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM - - -- 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 - ; let (split_prog, split_args) = (perl_path, [Option split_script]) - (mangle_prog, mangle_args) = (perl_path, [Option mangle_script]) - - ; let (mkdll_prog, mkdll_args) + | isWindowsHost && am_installed + -- We tell gcc where its specs file + exes are (-B) + -- and also some places to pick up include files. We need + -- to be careful to put all necessary exes in the -B place + -- (as, ld, cc1, etc) since if they don't get found there, + -- gcc then tries to run unadorned "as", "ld", etc, and + -- will pick up whatever happens to be lying around in + -- 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, gcc_mingw_include_arg]) + | otherwise = (cGCC, []) + perl_path + | isWindowsHost && am_installed = installed_bin cGHC_PERL + | otherwise = cGHC_PERL + -- 'touch' is a GHC util for Windows + touch_path + | isWindowsHost + = if am_installed + then installed_bin cGHC_TOUCHY_PGM + else inplace cGHC_TOUCHY_DIR_REL 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. + -- 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 + -- to wire-in our knowledge of $(PERL) on the host system here. + (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" | am_installed = (installed "gcc-lib/" cMKDLL, [ 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, []) -#else - -- UNIX-SPECIFIC STUFF - -- On Unix, the "standard" tools are assumed to be - -- in the same place whether we are running "in-place" or "installed" - -- That place is wherever the build-time configure script found them. - ; let gcc_prog = cGCC - gcc_args = [] - touch_path = "touch" - mkdll_prog = panic "Can't build DLLs on a non-Win32 system" - mkdll_args = [] - - -- 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 to wire-in - -- our knowledge of $(PERL) on the host system here. - ; let (split_prog, split_args) = (split_script, []) - (mangle_prog, mangle_args) = (mangle_script, []) -#endif -- cpp is derived from gcc on all platforms -- HACK, see setPgmP below. We keep 'words' here to remember to fix @@ -282,10 +278,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) @@ -311,42 +303,25 @@ initSysTools mbMinusB dflags -- elaborate it in the same way as the others } } - -#if defined(mingw32_HOST_OS) -foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32 -#endif \end{code} \begin{code} --- Find TopDir --- for "installed" this is the root of GHC's support files --- for "in-place" it is the root of the build tree --- --- Plan of action: --- 1. Set proto_top_dir --- if there is no given TopDir path, get the directory --- where GHC is running (only on Windows) --- --- 2. If package.conf exists in proto_top_dir, we are running --- installed; and TopDir = proto_top_dir --- --- 3. Otherwise we are running in-place, so --- proto_top_dir will be /...stuff.../ghc/compiler --- Set TopDir to /...stuff..., which is the root of the build tree --- --- This is very gruesome indeed - findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). -> IO (Bool, -- True <=> am installed, False <=> in-place String) -- TopDir (in Unix format '/' separated) findTopDir mbMinusB = do { top_dir <- get_proto - -- Discover whether we're running in a build tree or in an installation, - -- by looking for the package configuration file. - ; am_installed <- doesFileExist (top_dir "package.conf") + ; exists1 <- doesFileExist (top_dir "package.conf") + ; exists2 <- doesFileExist (top_dir "inplace") + ; let amInplace = not exists1 -- On Windows, package.conf doesn't exist + -- when we are inplace + || exists2 -- On Linux, the presence of inplace signals + -- that we are inplace - ; return (am_installed, top_dir) + ; let real_top = if exists2 then top_dir ".." else top_dir + + ; return (not amInplace, real_top) } where -- get_proto returns a Unix-format path (relying on getBaseDir to do so too) @@ -356,7 +331,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} @@ -451,9 +426,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 @@ -467,7 +439,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 @@ -704,24 +675,16 @@ 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 - (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) -#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 @@ -746,7 +709,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 @@ -767,6 +730,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) @@ -788,6 +752,7 @@ readerProc chan hdl filter_fn = checkError l ls Nothing -> do checkError l ls + _ -> panic "readerProc/loop" checkError l ls = case parseError l of @@ -830,8 +795,8 @@ data BuildMessage = BuildMsg !SDoc | BuildError !SrcLoc !SDoc | EOF -#endif +showOpt :: Option -> String showOpt (FileOption pre f) = pre ++ f showOpt (Option s) = s @@ -851,9 +816,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)) + ; ghcError (PhaseFailed phase_name (ExitFailure 1)) } \end{code} %************************************************************************ @@ -879,11 +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 - (d', "bin") -> takeDirectory d' - _ -> panic ("Expected \"bin\" in " ++ show s) - _ -> panic ("Expected \"ghc.exe\" in " ++ show s) + -- installed ghc.exe is in $topdir/bin/ghc.exe + (d', bin) | lower bin == "bin" -> takeDirectory d' + -- inplace ghc.exe is in $topdir/ghc/stage1-inplace/ghc.exe + (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