X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=2df9a7240702037e8524760a5494dbb2decfe1ec;hp=64e7b7803f1ecef11553a6cdebb3ee1fc414339b;hb=206b4dec78250efef3cd927d64dc6cbc54a16c3d;hpb=01ecefa4b97106fec5c139c5514e5d56e59ecbaf diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 64e7b78..2df9a72 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -7,6 +7,13 @@ ----------------------------------------------------------------------------- \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 + module SysTools ( -- Initialisation initSysTools, @@ -17,11 +24,12 @@ module SysTools ( runMangle, runSplit, -- [Option] -> IO () runAs, runLink, -- [Option] -> IO () runMkDLL, + runWindres, touch, -- String -> String -> IO () copy, copyWithHeader, - normalisePath, -- FilePath -> FilePath + getExtraViaCOpts, -- Temporary-file management setTmpDir, @@ -49,6 +57,7 @@ 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.Directory @@ -63,7 +72,7 @@ import Foreign import CString ( CString, peekCString ) #endif -#if __GLASGOW_HASKELL__ < 603 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 -- rawSystem comes from libghccompat.a in stage1 import Compat.RawSystem ( rawSystem ) import System.Cmd ( system ) @@ -163,10 +172,9 @@ initSysTools mbMinusB dflags -- format, '/' separated ; let installed, installed_bin :: FilePath -> FilePath - installed_bin pgm = pgmPath top_dir pgm - installed file = pgmPath top_dir file - inplace dir pgm = pgmPath (top_dir `joinFileName` - cPROJECT_DIR `joinFileName` dir) pgm + installed_bin pgm = top_dir pgm + installed file = top_dir file + inplace dir pgm = top_dir cPROJECT_DIR dir pgm ; let pkgconfig_path | am_installed = installed "package.conf" @@ -195,6 +203,10 @@ initSysTools mbMinusB dflags | 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" + ; let dflags0 = defaultDynFlags #ifndef mingw32_HOST_OS -- check whether TMPDIR is set in the environment @@ -253,9 +265,6 @@ initSysTools mbMinusB dflags -- later on; although gcc_args are in NATIVE format, -- gcc can cope -- (see comments with declarations of global variables) - -- - -- The quotes round the -B argument are in case TopDir - -- has spaces in it perl_path | am_installed = installed_bin cGHC_PERL | otherwise = cGHC_PERL @@ -271,9 +280,9 @@ initSysTools mbMinusB dflags ; let (mkdll_prog, mkdll_args) | am_installed = - (pgmPath (installed "gcc-lib/") cMKDLL, + (installed "gcc-lib/" cMKDLL, [ Option "--dlltool-name", - Option (pgmPath (installed "gcc-lib/") "dlltool"), + Option (installed "gcc-lib/" "dlltool"), Option "--driver-name", Option gcc_prog, gcc_b_arg ]) | otherwise = (cMKDLL, []) @@ -325,7 +334,8 @@ initSysTools mbMinusB dflags pgm_l = (ld_prog,ld_args), pgm_dll = (mkdll_prog,mkdll_args), pgm_T = touch_path, - pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan" + pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", + pgm_windres = windres_path -- Hans: this isn't right in general, but you can -- elaborate it in the same way as the others } @@ -363,14 +373,14 @@ 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 `joinFileName` "package.conf") + ; 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 (normalisePath minusb) + Just minusb -> return (normalise minusb) Nothing -> do maybe_exec_dir <- getBaseDir -- Get directory of executable case maybe_exec_dir of -- (only works on Windows; @@ -396,7 +406,9 @@ runUnlit dflags args = do runCpp :: DynFlags -> [Option] -> IO () runCpp dflags args = do let (p,args0) = pgm_P dflags - runSomething dflags "C pre-processor" p (args0 ++ args) + args1 = args0 ++ args + mb_env <- getGccEnv args1 + runSomethingFiltered dflags id "C pre-processor" p args1 mb_env runPp :: DynFlags -> [Option] -> IO () runPp dflags args = do @@ -468,7 +480,7 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) -- binaries (see bug #1110). getGccEnv :: [Option] -> IO (Maybe [(String,String)]) getGccEnv opts = -#if __GLASGOW_HASKELL__ < 603 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 return Nothing #else if null b_dirs @@ -517,6 +529,28 @@ runMkDLL dflags args = do mb_env <- getGccEnv (args0++args) runSomethingFiltered dflags id "Make DLL" p args1 mb_env +runWindres :: DynFlags -> [Option] -> IO () +runWindres dflags args = do + 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 ++ "\"" + touch :: DynFlags -> String -> String -> IO () touch dflags purpose arg = runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] @@ -536,6 +570,10 @@ copyWithHeader dflags purpose maybe_header from to = do hPutStr h ls hClose h +getExtraViaCOpts :: DynFlags -> IO [String] +getExtraViaCOpts dflags = do + f <- readFile (topDir dflags "extra-gcc-opts") + return (words f) \end{code} %************************************************************************ @@ -582,11 +620,11 @@ newTempName dflags extn where findTempName :: FilePath -> Integer -> IO FilePath findTempName prefix x - = do let filename = (prefix ++ show x) `joinFileExt` extn - b <- doesFileExist filename - if b then findTempName prefix (x+1) - else do consIORef v_FilesToClean filename -- clean it up later - return filename + = 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 + return filename -- return our temporary directory within tmp_dir, creating one if we -- don't have one yet @@ -709,7 +747,7 @@ runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do -#if __GLASGOW_HASKELL__ < 603 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 builderMainLoop dflags filter_fn pgm real_args mb_env = do rawSystem pgm real_args #else @@ -823,8 +861,7 @@ data BuildMessage | EOF #endif -showOpt (FileOption pre f) = pre ++ platformPath f -showOpt (Option "") = "" +showOpt (FileOption pre f) = pre ++ f showOpt (Option s) = s traceCmd :: DynFlags -> String -> String -> IO () -> IO () @@ -870,7 +907,12 @@ getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32. free buf return (Just (rootDir s)) where - rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s))) + rootDir s = case splitFileName $ normalise s of + (d, "ghc.exe") -> + case splitFileName $ takeDirectory d of + (d', "bin") -> takeDirectory d' + _ -> panic ("Expected \"bin\" in " ++ show s) + _ -> panic ("Expected \"ghc.exe\" in " ++ show s) foreign import stdcall unsafe "GetModuleFileNameA" getModuleFileName :: Ptr () -> CString -> Int -> IO Int32