X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FSysTools.lhs;h=97a5ea7bf6b8867f9507a6bdf56af532404af286;hb=8d6bc9bf51829ea04da5f599b84114ef220f0a19;hp=87c55717bd0035e82e005b657ae8e015d7a9c75a;hpb=6c53f40f3dd84cc91a8e6850dbfb271cb24db89a;p=ghc-hetmet.git diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 87c5571..97a5ea7 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 @@ -57,28 +66,16 @@ import Data.Maybe import Data.List #ifndef mingw32_HOST_OS -#if __GLASGOW_HASKELL__ > 504 import qualified System.Posix.Internals -#else -import qualified Posix -#endif #else /* Must be Win32 */ import Foreign import CString ( CString, peekCString ) #endif -#if __GLASGOW_HASKELL__ < 603 --- rawSystem comes from libghccompat.a in stage1 -import Compat.RawSystem ( rawSystem ) -import System.Cmd ( system ) -import GHC.IOBase ( IOErrorType(..) ) -#else import System.Process ( runInteractiveProcess, getProcessExitCode ) import Control.Concurrent( forkIO, newChan, readChan, writeChan ) -import Data.Char ( isSpace ) -import FastString ( mkFastString ) +import FastString import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) -#endif \end{code} @@ -168,10 +165,15 @@ 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 > +#ifndef darwin_TARGET_OS +-- Not sure where cPROJECT_DIR makes sense, on Mac OS, building with +-- xcodebuild, it surely is a *bad* idea! -=chak + cPROJECT_DIR > +#endif + dir > pgm ; let pkgconfig_path | am_installed = installed "package.conf" @@ -200,32 +202,14 @@ 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 - ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set -#else - -- On Win32, consult GetTempPath() for a temp dir. - -- => it first tries TMP, TEMP, then finally the - -- Windows directory(!). The directory is in short-path - -- form. - ; e_tmpdir <- - IO.try (do - let len = (2048::Int) - buf <- mallocArray len - ret <- getTempPath len buf - if ret == 0 then do - -- failed, consult TMPDIR. - free buf - getEnv "TMPDIR" - else do - s <- peekCString buf - free buf - return s) -#endif - ; let dflags1 = case e_tmpdir of - Left _ -> dflags0 - Right d -> setTmpDir d dflags0 + + ; tmpdir <- getTemporaryDirectory + ; let dflags1 = setTmpDir tmpdir dflags0 -- Check that the package config exists ; config_exists <- doesFileExist pkgconfig_path @@ -258,9 +242,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 @@ -276,9 +257,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, []) @@ -330,7 +311,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 } @@ -368,14 +350,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; @@ -401,7 +383,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 @@ -411,7 +395,8 @@ runPp dflags args = do runCc :: DynFlags -> [Option] -> IO () runCc dflags args = do let (p,args0) = pgm_c dflags - (args1,mb_env) <- getGccEnv (args0++args) + args1 = args0 ++ args + mb_env <- getGccEnv args1 runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env where -- discard some harmless warnings from gcc that we can't turn off @@ -467,22 +452,27 @@ runCc dflags args = do isContainedIn :: String -> String -> Bool xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) --- Turn the -B