X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FSysTools.lhs;h=a77fc7322ad614e3be5f410702a4becbc6f9221e;hb=86454e4bc7854fc5e22dadf521f5419e0fc3715b;hp=e2c43ff58fabada605900b2d71069adf54a75499;hpb=045a18db20c0b7f2942e151dd8fa59dc9476d0bf;p=ghc-hetmet.git diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index e2c43ff..a77fc73 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -37,9 +37,8 @@ module SysTools ( -- Misc showGhcUsage, -- IO () Shows usage message and exits - getSysMan, -- IO String Parallel system only + getSysMan -- IO String Parallel system only - runSomething -- ToDo: make private ) where import DriverUtil @@ -54,22 +53,14 @@ import IO import Directory ( doesFileExist, removeFile ) import IOExts ( IORef, readIORef, writeIORef ) import Monad ( when, unless ) -import System ( system, ExitCode(..), exitWith ) -import CString -import Int - -#if __GLASGOW_HASKELL__ < 500 -import Storable -#else -import MarshalArray -#endif - +import System ( system, ExitCode(..), exitWith, getEnv ) + #include "../includes/config.h" #if !defined(mingw32_TARGET_OS) import qualified Posix #else -import Addr +import Win32DLL import List ( isPrefixOf ) #endif @@ -77,8 +68,6 @@ import List ( isSuffixOf ) #include "HsVersions.h" -{-# DEPRECATED runSomething "runSomething should be private to SysTools" #-} - \end{code} @@ -120,6 +109,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} @@ -173,7 +186,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 @@ -200,6 +214,14 @@ initSysTools minusB_args | am_installed = installed_bin cGHC_MANGLER | otherwise = inplace cGHC_MANGLER_DIR cGHC_MANGLER +#ifndef mingw32_TARGET_OS + -- check whether TMPDIR is set in the environment + ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set + setTmpDir dir + return () + ) +#endif + -- Check that the package config exists ; config_exists <- doesFileExist pkgconfig_path ; when (not config_exists) $ @@ -212,15 +234,22 @@ 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 "gcc-lib/" + ++ " -I" ++ 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 @@ -234,8 +263,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" @@ -245,9 +273,11 @@ initSysTools minusB_args -- our knowledge of $(PERL) on the host system here. ; let split_path = split_script mangle_path = mangle_script - #endif + -- 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 @@ -340,23 +370,8 @@ getTopDir minusbs ; case maybe_exec_dir of -- (only works on Windows; -- returns Nothing on Unix) Nothing -> throwDyn (InstallationError "missing -B option") - Just dir -> return (remove_suffix (unDosifyPath dir)) + Just dir -> return (unDosifyPath 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 ghc_bin_dir) - p2 = dropWhile (not . isSlash) (tail p1) -- head is '/' - back_two = reverse (tail p2) -- head is '/' - back_one = reverse (tail p1) \end{code} @@ -405,13 +420,15 @@ touch purpose arg = do p <- readIORef v_Pgm_T runSomething purpose p [arg] copy :: String -> String -> String -> IO () -copy purpose from to = - do - h <- openFile to WriteMode - ls <- readFile from -- inefficient, but it'll do for now. - -- ToDo: speed up via slurping. - hPutStr h ls - hClose h +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} @@ -493,9 +510,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} @@ -593,10 +612,10 @@ pgmPath :: String -- Directory string in Unix format #if defined(mingw32_TARGET_OS) --------------------- Windows version ------------------ -unDosifyPath xs = xs - dosifyPaths xs = map dosifyPath xs +unDosifyPath xs = subst '\\' '/' xs + pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm dosifyPath stuff @@ -614,7 +633,7 @@ dosifyPath stuff --------------------- Unix version --------------------- dosifyPaths ps = ps -unDosifyPath xs = subst '\\' '/' xs +unDosifyPath xs = xs pgmPath dir pgm = dir ++ '/' : pgm -------------------------------------------------------- #endif @@ -650,37 +669,21 @@ slash s1 s2 = s1 ++ ('/' : s2) \begin{code} ----------------------------------------------------------------------------- --- Define myGetProcessId :: IO Int --- getExecDir :: IO (Maybe String) - -#ifdef mingw32_TARGET_OS -foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows +-- Define getExecDir :: IO (Maybe String) -#if __GLASGOW_HASKELL__ >= 500 -foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectory :: Int32 -> CString -> IO Int32 -foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectoryLen :: Int32 -> Addr -> IO Int32 +#if defined(mingw32_TARGET_OS) getExecDir :: IO (Maybe String) -getExecDir = do len <- getCurrentDirectoryLen 0 nullAddr - buf <- mallocArray (fromIntegral len) - ret <- getCurrentDirectory len buf - if ret == 0 then return Nothing - else do s <- peekCString buf - destructArray (fromIntegral len) buf - return (Just s) +getExecDir = do h <- getModuleHandle Nothing + n <- getModuleFileName h + return (Just (reverse (tail (dropWhile (not . isSlash) (reverse (unDosifyPath n)))))) #else -foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectory :: Int32 -> Addr -> IO Int32 -getExecDir :: IO (Maybe String) -getExecDir = do len <- getCurrentDirectory 0 nullAddr - buf <- malloc (fromIntegral len) - ret <- getCurrentDirectory len buf - if ret == 0 then return Nothing - else do s <- unpackCStringIO buf - free buf - return (Just s) +getExecDir :: IO (Maybe String) = do return Nothing #endif + +#ifdef mingw32_TARGET_OS +foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows #else getProcessID :: IO Int getProcessID = Posix.getProcessID -getExecDir :: IO (Maybe String) = do return Nothing #endif \end{code}