X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=71a721e9ccc8c81079746e126d9ef7dae53abe41;hb=0b3b3ada70a54a3ea29ecfbbfabda33472e2c00c;hp=96833c86518b5e46b74caa4e94551fa3f7d2b6bc;hpb=bd4d75bae80df2e9a4d519112532bbdd959382a2;p=ghc-hetmet.git diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 96833c8..71a721e 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -45,14 +45,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 @@ -71,24 +71,33 @@ 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 @@ -149,22 +158,20 @@ initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) -- (c) the GHC usage message -initSysTools mbMinusB _ +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" @@ -193,15 +200,13 @@ initSysTools mbMinusB _ | 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)) -- On Windows, gcc and friends are distributed with GHC, @@ -217,6 +222,7 @@ initSysTools mbMinusB _ -- 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) @@ -228,7 +234,7 @@ initSysTools mbMinusB _ -- 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 @@ -260,7 +266,7 @@ initSysTools mbMinusB _ [ 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 @@ -297,35 +303,22 @@ initSysTools mbMinusB _ \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) @@ -335,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} @@ -357,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 @@ -430,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 @@ -446,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 @@ -533,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. @@ -573,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 @@ -591,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 -> @@ -601,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 @@ -683,25 +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) builderMainLoop :: DynFlags -> (String -> String) -> FilePath -> [String] -> Maybe [(String, String)] -> IO ExitCode -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 -builderMainLoop dflags filter_fn pgm real_args mb_env = do - rawSystem pgm real_args -#else builderMainLoop dflags filter_fn pgm real_args mb_env = do chan <- newChan (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env @@ -812,7 +795,6 @@ data BuildMessage = BuildMsg !SDoc | BuildError !SrcLoc !SDoc | EOF -#endif showOpt :: Option -> String showOpt (FileOption pre f) = pre ++ f @@ -836,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} %************************************************************************ @@ -862,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