X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=26c85bdc2c8dd67c3a004d5692d9aaedc03a1698;hp=006dd28588751996c0eb2592696bd63db237b786;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=e761a777f2440ca1b8d8b40848cc5aa30d889ff6 diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 006dd28..26c85bd 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -45,7 +45,7 @@ import Util import DynFlags import FiniteMap -import Control.Exception +import Exception import Data.IORef import Control.Monad import System.Exit @@ -71,24 +71,26 @@ 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, +the root of GHC's support files -* 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 . +On Unix: + - ghc always has a shell wrapper that passes a -B option -* 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 Windows: + - ghc never has a shell wrapper. + - we can find the location of the ghc binary, which is + $topdir/bin/.exe + where may be "ghc", "ghc-stage2", or similar + - we strip off the "bin/.exe" to leave $topdir. -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). +from topdir we can find package.conf, ghc-asm, etc. SysTools.initSysProgs figures out exactly where all the auxiliary programs @@ -104,8 +106,8 @@ Config.hs contains two sorts of things etc They do *not* include paths - cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc - cSPLIT_DIR_REL *relative* to the root of the build tree, + cUNLIT_DIR The *path* to the directory containing unlit, split etc + cSPLIT_DIR *relative* to the root of the build tree, for use when running *in-place* in a build tree (only) @@ -150,48 +152,28 @@ initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) 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 + = do { top_dir <- findTopDir mbMinusB + -- 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 + ; let installed :: FilePath -> FilePath + installed file = top_dir file + installed_mingw_bin file = top_dir ".." "mingw" "bin" file - ; let pkgconfig_path - | am_installed = installed "package.conf" - | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace" - - ghc_usage_msg_path - | am_installed = installed "ghc-usage.txt" - | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt" - - ghci_usage_msg_path - | am_installed = installed "ghci-usage.txt" - | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt" + ; let pkgconfig_path = installed "package.conf" + ghc_usage_msg_path = installed "ghc-usage.txt" + ghci_usage_msg_path = installed "ghci-usage.txt" -- For all systems, unlit, split, mangle are GHC utilities -- architecture-specific stuff is done when building Config.hs - unlit_path - | am_installed = installed_bin cGHC_UNLIT_PGM - | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM + unlit_path = installed cGHC_UNLIT_PGM -- split and mangle are Perl scripts - split_script - | am_installed = installed_bin cGHC_SPLIT_PGM - | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM + split_script = installed cGHC_SPLIT_PGM + mangle_script = installed cGHC_MANGLER_PGM - mangle_script - | am_installed = installed_bin cGHC_MANGLER_PGM - | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM - - windres_path - | am_installed = installed_bin "bin/windres" - | otherwise = "windres" + windres_path = installed_mingw_bin "windres" ; tmpdir <- getTemporaryDirectory ; let dflags1 = setTmpDir tmpdir dflags0 @@ -199,45 +181,22 @@ initSysTools mbMinusB 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, - -- so when "installed" we look in TopDir/bin - -- When "in-place", or when not on Windows, we look wherever - -- the build-time configure script found them + -- On Windows, mingw is distributed with GHC, + -- so we look in TopDir/../mingw/bin ; 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_prog,gcc_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]) - | otherwise = (cGCC, []) + gcc_prog + | isWindowsHost = installed_mingw_bin "gcc" + | otherwise = cGCC perl_path - | isWindowsHost && am_installed = installed_bin cGHC_PERL - | otherwise = cGHC_PERL + | isWindowsHost = installed 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" + | isWindowsHost = installed 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 @@ -253,23 +212,18 @@ initSysTools mbMinusB dflags0 (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 ]) - | otherwise = (cMKDLL, []) + | otherwise = + (installed_mingw_bin cMKDLL, []) -- cpp is derived from gcc on all platforms -- HACK, see setPgmP below. We keep 'words' here to remember to fix -- Config.hs one day. - ; let cpp_path = (gcc_prog, gcc_args ++ + ; let cpp_path = (gcc_prog, (Option "-E"):(map Option (words cRAWCPP_FLAGS))) -- 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) + ; let as_prog = gcc_prog + ld_prog = gcc_prog ; return dflags1{ ghcUsagePath = ghc_usage_msg_path, @@ -279,11 +233,11 @@ initSysTools mbMinusB dflags0 pgm_L = unlit_path, pgm_P = cpp_path, pgm_F = "", - pgm_c = (gcc_prog,gcc_args), + pgm_c = (gcc_prog,[]), pgm_m = (mangle_prog,mangle_args), pgm_s = (split_prog,split_args), - pgm_a = (as_prog,as_args), - pgm_l = (ld_prog,ld_args), + pgm_a = (as_prog,[]), + pgm_l = (ld_prog,[]), pgm_dll = (mkdll_prog,mkdll_args), pgm_T = touch_path, pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", @@ -295,46 +249,17 @@ initSysTools mbMinusB dflags0 \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") - - ; return (am_installed, top_dir) - } - where - -- get_proto returns a Unix-format path (relying on getBaseDir to do so too) - get_proto = case mbMinusB of - Just minusb -> return (normalise minusb) - Nothing - -> 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") - Just dir -> return dir +-- returns a Unix-format path (relying on getBaseDir to do so too) +findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). + -> IO String -- TopDir (in Unix format '/' separated) +findTopDir (Just minusb) = return (normalise minusb) +findTopDir Nothing + = do -- Get directory of executable + maybe_exec_dir <- getBaseDir + case maybe_exec_dir of + -- "Just" on Windows, "Nothing" on unix + Nothing -> ghcError (InstallationError "missing -B option") + Just dir -> return dir \end{code} @@ -355,8 +280,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 @@ -475,25 +403,10 @@ runMkDLL dflags args = do runWindres :: DynFlags -> [Option] -> IO () runWindres dflags args = do - let (gcc,gcc_args) = pgm_c dflags + let (_gcc,gcc_args) = pgm_c dflags windres = pgm_windres dflags mb_env <- getGccEnv gcc_args - runSomethingFiltered dflags id "Windres" windres - -- we must tell windres where to find gcc: it might not be on PATH - (Option ("--preprocessor=" ++ - unwords (map quote (gcc : map showOpt gcc_args ++ - ["-E", "-xc", "-DRC_INVOKED"]))) - -- -- use-temp-file is required for windres to interpret the - -- quoting in the preprocessor arg above correctly. Without - -- this, windres calls the preprocessor with popen, which gets - -- the quoting wrong (discovered by experimentation and - -- reading the windres sources). See #1828. - : Option "--use-temp-file" - : args) - -- we must use the PATH workaround here too, since windres invokes gcc - mb_env - where - quote x = '\"' : x ++ "\"" + runSomethingFiltered dflags id "Windres" windres args mb_env touch :: DynFlags -> String -> String -> IO () touch dflags purpose arg = @@ -507,12 +420,13 @@ copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath 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 + hout <- openBinaryFile to WriteMode + hin <- openBinaryFile from ReadMode + ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up + maybe (return ()) (hPutStr hout) maybe_header + hPutStr hout ls + hClose hout + hClose hin getExtraViaCOpts :: DynFlags -> IO [String] getExtraViaCOpts dflags = do @@ -527,32 +441,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. @@ -567,14 +479,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 @@ -585,7 +499,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 -> @@ -595,9 +509,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 @@ -680,9 +594,9 @@ runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do 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)] @@ -694,8 +608,8 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do -- and run a loop piping the output from the compiler to the log_action in DynFlags hSetBuffering hStdOut LineBuffering hSetBuffering hStdErr LineBuffering - forkIO (readerProc chan hStdOut filter_fn) - forkIO (readerProc chan hStdErr filter_fn) + _ <- forkIO (readerProc chan hStdOut filter_fn) + _ <- forkIO (readerProc chan hStdErr filter_fn) -- we don't want to finish until 2 streams have been completed -- (stdout and stderr) -- nor until 1 exit code has been retrieved. @@ -820,7 +734,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} %************************************************************************ @@ -835,8 +749,8 @@ traceCmd dflags phase_name cmd_line action getBaseDir :: IO (Maybe String) #if defined(mingw32_HOST_OS) --- Assuming we are running ghc, accessed by path $()/bin/ghc.exe, --- return the path $(stuff). Note that we drop the "bin/" directory too. +-- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe, +-- return the path $(stuff)/lib. getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32. buf <- mallocArray len ret <- getModuleFileName nullPtr buf len @@ -846,11 +760,18 @@ 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 `elem` ["ghc.exe", + "ghc-stage1.exe", + "ghc-stage2.exe", + "ghc-stage3.exe"] -> case splitFileName $ takeDirectory d of - (d', "bin") -> takeDirectory d' - _ -> panic ("Expected \"bin\" in " ++ show s) - _ -> panic ("Expected \"ghc.exe\" in " ++ show s) + -- ghc is in $topdir/bin/ghc.exe + (d', bin) | lower bin == "bin" -> takeDirectory d' "lib" + _ -> 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