X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FSysTools.lhs;h=33ac91c562383fa80ac06ad81427f2d24d129ae9;hb=d65574ab3852a0d5b66358f71ae1e34dfcc606c9;hp=2c293346bc1b515348b05bd0e66307d4f8730b64;hpb=3b8aa6ae473ed794ba1dd63af1ffbc78636ef21e;p=ghc-hetmet.git diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index 2c29334..33ac91c 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -50,13 +50,12 @@ import Util ( global ) import CmdLineOpts ( dynFlag, verbosity ) import Exception ( throwDyn, catchAllIO ) -import IO ( hPutStr, hPutChar, hPutStrLn, hFlush, stderr ) +import IO import Directory ( doesFileExist, removeFile ) import IOExts ( IORef, readIORef, writeIORef ) import Monad ( when, unless ) import System ( system, ExitCode(..), exitWith ) import CString -import Addr import Int #if __GLASGOW_HASKELL__ < 500 @@ -70,10 +69,12 @@ import MarshalArray #if !defined(mingw32_TARGET_OS) import qualified Posix #else -import Addr ( nullAddr ) +import Addr import List ( isPrefixOf ) #endif +import List ( isSuffixOf ) + #include "HsVersions.h" {-# DEPRECATED runSomething "runSomething should be private to SysTools" #-} @@ -119,6 +120,30 @@ Config.hs contains two sorts of things +--------------------------------------------- +NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): + +Another hair-brained scheme for simplifying the current tool location +nightmare in GHC: Simon originally suggested using another +configuration file along the lines of GCC's specs file - which is fine +except that it means adding code to read yet another configuration +file. What I didn't notice is that the current package.conf is +general enough to do this: + +Package + {name = "tools", import_dirs = [], source_dirs = [], + library_dirs = [], hs_libraries = [], extra_libraries = [], + include_dirs = [], c_includes = [], package_deps = [], + extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.], + extra_cc_opts = [], extra_ld_opts = []} + +Which would have the advantage that we get to collect together in one +place the path-specific package stuff with the path-specific tool +stuff. + End of NOTES +--------------------------------------------- + + %************************************************************************ %* * \subsection{Global variables to contain system programs} @@ -172,7 +197,8 @@ initSysTools minusB_args -- for "in-place" it is the root of the build tree -- NB: top_dir is assumed to be in standard Unix format '/' separated - ; let installed_bin pgm = pgmPath (top_dir `slash` "bin") pgm + ; let installed, installed_bin :: FilePath -> FilePath + installed_bin pgm = pgmPath (top_dir `slash` "extra-bin") pgm installed file = pgmPath top_dir file inplace dir pgm = pgmPath (top_dir `slash` dir) pgm @@ -203,7 +229,7 @@ initSysTools minusB_args ; config_exists <- doesFileExist pkgconfig_path ; when (not config_exists) $ throwDyn (InstallationError - ("Can't find package.conf in " ++ pkgconfig_path)) + ("Can't find package.conf as " ++ pkgconfig_path)) #if defined(mingw32_TARGET_OS) -- WINDOWS-SPECIFIC STUFF @@ -211,15 +237,23 @@ initSysTools minusB_args -- so when "installed" we look in TopDir/bin -- When "in-place" we look wherever the build-time configure -- script found them - ; let cpp_path | am_installed = installed cRAWCPP - | otherwise = cRAWCPP - gcc_path | am_installed = installed cGCC + -- 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_path | am_installed = installed_bin ("gcc -B" ++ installed "lib/gcc-lib/" + ++ " -I" ++ installed "include/w32api:" + ++ installed "include/mingw") | otherwise = cGCC - perl_path | am_installed = installed cGHC_PERL + 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 cGHC_TOUCHY + ; let touch_path | am_installed = installed_bin cGHC_TOUCHY | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY -- On Win32 we don't want to rely on #!/bin/perl, so we prepend @@ -233,8 +267,7 @@ initSysTools minusB_args -- 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 cpp_path = cRAWCPP - gcc_path = cGCC + ; let gcc_path = cGCC touch_path = cGHC_TOUCHY mkdll_path = panic "Can't build DLLs on a non-Win32 system" @@ -244,10 +277,12 @@ initSysTools minusB_args -- our knowledge of $(PERL) on the host system here. ; let split_path = split_script mangle_path = mangle_script - #endif - -- For all systems, copy and remove are provided by the host + -- cpp is derived from gcc on all platforms + ; let cpp_path = gcc_path ++ " -E " ++ 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 @@ -307,7 +342,7 @@ setPgm pgm = unknownFlagErr ("-pgm" ++ pgm) -- 1. Set proto_top_dir -- a) look for (the last) -B flag, and use it -- b) if there are no -B flags, get the directory --- where GHC is running +-- 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 @@ -323,39 +358,39 @@ getTopDir :: [String] String) -- TopDir (in Unix format '/' separated) getTopDir minusbs - = do { top_dir1 <- get_proto - ; let top_dir2 = unDosifyPath top_dir1 -- Convert to standard internal form - - -- Discover whether we're running in a build tree or in an installation, + = 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_dir2 `slash` "package.conf") + ; am_installed <- doesFileExist (top_dir `slash` "package.conf") - ; if am_installed then - return (True, top_dir2) - else - return (False, remove_suffix top_dir2) + ; return (am_installed, top_dir) } where - get_proto | not (null minusbs) - = return (drop 2 (last minusbs)) -- 2 for "-B" + -- get_proto returns a Unix-format path + get_proto | not (null minusbs) + = return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B" | otherwise = do { maybe_exec_dir <- getExecDir -- 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 + Just dir -> return (remove_suffix (unDosifyPath dir)) } - remove_suffix dir -- "/...stuff.../ghc/compiler" --> "/...stuff..." - = ASSERT2( not (null p1) && - not (null p2) && - dir == top_dir ++ "/ghc/compiler", - text dir ) - top_dir + -- In an installed tree, the ghc binary lives in $libexecdir, which + -- is normally $libdir/bin. So we strip off a /bin suffix here. + -- In a build tree, the ghc binary lives in $fptools/ghc/compiler, + -- so we strip off the /ghc/compiler suffix here too, leaving a + -- standard TOPDIR. + remove_suffix ghc_bin_dir -- ghc_bin_dir is in standard Unix format + | "/ghc/compiler" `isSuffixOf` ghc_bin_dir = back_two + | "/bin" `isSuffixOf` ghc_bin_dir = back_one + | otherwise = ghc_bin_dir where - p1 = dropWhile (not . isSlash) (reverse dir) + p1 = dropWhile (not . isSlash) (reverse ghc_bin_dir) p2 = dropWhile (not . isSlash) (tail p1) -- head is '/' - top_dir = reverse (tail p2) -- head is '/' + back_two = reverse (tail p2) -- head is '/' + back_one = reverse (tail p1) \end{code} @@ -404,8 +439,15 @@ touch purpose arg = do p <- readIORef v_Pgm_T runSomething purpose p [arg] copy :: String -> String -> String -> IO () -copy purpose from to = do p <- readIORef v_Pgm_CP - runSomething purpose p [from,to] +copy purpose from to = do + verb <- dynFlag verbosity + when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose) + + h <- openFile to WriteMode + ls <- readFile from -- inefficient, but it'll do for now. + -- ToDo: speed up via slurping. + hPutStr h ls + hClose h \end{code} \begin{code} @@ -487,9 +529,11 @@ removeTmpFiles verb fs ("Deleting: " ++ unwords fs) (mapM_ rm fs) where - rm f = removeFile f `catchAllIO` - (\exn -> hPutStrLn stderr ("Warning: deleting non-existent " ++ f) >> - return ()) + rm f = removeFile f `catchAllIO` + (\_ignored -> + when (verb >= 2) $ + hPutStrLn stderr ("Warning: deleting non-existent " ++ f) + ) \end{code} @@ -525,7 +569,7 @@ runSomething phase_name pgm args } where cmd_line = unwords (pgm : dosifyPaths args) - -- The pgm is already in native format + -- The pgm is already in native format (appropriate dir separators) traceCmd :: String -> String -> IO () -> IO () -- a) trace the command (at two levels of verbosity)