-----------------------------------------------------------------------------
--- $Id: SysTools.lhs,v 1.52 2001/08/15 15:02:04 rrt Exp $
--
--- (c) The University of Glasgow 2001
+-- (c) The University of Glasgow 2001-2003
--
-- Access to system tools: gcc, cp, rm etc
--
module SysTools (
-- Initialisation
initSysTools,
- setPgm, -- String -> IO ()
- -- Command-line override
- setDryRun,
- getTopDir, -- IO String -- The value of $libdir
+ getTopDir, -- IO String -- The value of $topdir
getPackageConfigPath, -- IO String -- Where package.conf is
+ getUsageMsgPaths, -- IO (String,String)
-- Interface to system tools
runUnlit, runCpp, runCc, -- [Option] -> IO ()
+ runPp, -- [Option] -> IO ()
runMangle, runSplit, -- [Option] -> IO ()
runAs, runLink, -- [Option] -> IO ()
runMkDLL,
-#ifdef ILX
- runIlx2il, runIlasm, -- [String] -> IO ()
-#endif
-
touch, -- String -> String -> IO ()
copy, -- String -> String -> String -> IO ()
- unDosifyPath, -- String -> String
+ normalisePath, -- FilePath -> FilePath
-- Temporary-file management
setTmpDir,
newTempName,
- cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
+ cleanTempFiles, cleanTempFilesExcept,
addFilesToClean,
-- System interface
- getProcessID, -- IO Int
system, -- String -> IO ExitCode
-- Misc
- showGhcUsage, -- IO () Shows usage message and exits
getSysMan, -- IO String Parallel system only
Option(..)
) where
-import DriverUtil
+#include "HsVersions.h"
+
+import DriverPhases ( isHaskellUserSrcFilename )
import Config
import Outputable
-import Panic ( progName, GhcException(..) )
-import Util ( global )
-import CmdLineOpts ( dynFlag, verbosity )
-
-import Exception ( throwDyn, catchAllIO )
-import IO
-import Directory ( doesFileExist, removeFile )
-import IOExts ( IORef, readIORef, writeIORef )
-import Monad ( when, unless )
-import System ( ExitCode(..), exitWith, getEnv, system )
-import CString
-import Int
-import Addr
+import ErrUtils ( putMsg, debugTraceMsg, showPass, Severity(..), Messages )
+import Panic ( GhcException(..) )
+import Util ( Suffix, global, notNull, consIORef, joinFileName,
+ normalisePath, pgmPath, platformPath, joinFileExt )
+import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..),
+ setTmpDir, defaultDynFlags )
+
+import EXCEPTION ( throwDyn, finally )
+import DATA_IOREF ( IORef, readIORef, writeIORef )
+import DATA_INT
-#include "../includes/config.h"
+import Monad ( when, unless )
+import System ( ExitCode(..), getEnv, system )
+import IO ( try, catch, hGetContents,
+ openFile, hPutStr, hClose, hFlush, IOMode(..),
+ stderr, ioError, isDoesNotExistError )
+import Directory ( doesFileExist, removeFile )
+import Maybe ( isJust )
+import List ( partition )
-#ifndef mingw32_TARGET_OS
-import qualified Posix
+-- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
+-- lines on mingw32, so we disallow it now.
+#if __GLASGOW_HASKELL__ < 500
+#error GHC >= 5.00 is required for bootstrapping GHC
+#endif
+
+#ifndef mingw32_HOST_OS
+#if __GLASGOW_HASKELL__ > 504
+import qualified System.Posix.Internals
#else
+import qualified Posix
+#endif
+#else /* Must be Win32 */
import List ( isPrefixOf )
-import MarshalArray
+import Util ( dropList )
+import Foreign
+import CString ( CString, peekCString )
#endif
--- use the line below when we can be sure of compiling with GHC >=
--- 5.02, and remove the implementation of rawSystem at the end of this
--- file
-import PrelIOBase -- this can be removed when SystemExts is used
-import CError ( throwErrnoIfMinus1 ) -- as can this
--- import SystemExts ( rawSystem )
-
-#include "HsVersions.h"
-
+#if __GLASGOW_HASKELL__ < 603
+-- rawSystem comes from libghccompat.a in stage1
+import Compat.RawSystem ( rawSystem )
+import GHC.IOBase ( IOErrorType(..) )
+import System.IO.Error ( ioeGetErrorType )
+#else
+import System.Process ( runInteractiveProcess, getProcessExitCode )
+import System.IO ( hSetBuffering, hGetLine, BufferMode(..) )
+import Control.Concurrent( forkIO, newChan, readChan, writeChan )
+import Text.Regex
+import Data.Char ( isSpace )
+import FastString ( mkFastString )
+import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
+#endif
\end{code}
etc They do *not* include paths
- 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)
+ cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
+ cSPLIT_DIR_REL *relative* to the root of the build tree,
+ for use when running *in-place* in a build tree (only)
{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_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
extra_cc_opts = [], extra_ld_opts = []}
Which would have the advantage that we get to collect together in one
(See remarks under pathnames below)
\begin{code}
-GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
-GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp
-GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc
-GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler
-GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter
-GLOBAL_VAR(v_Pgm_a, error "pgm_a", String) -- as
-#ifdef ILX
-GLOBAL_VAR(v_Pgm_I, error "pgm_I", String) -- ilx2il
-GLOBAL_VAR(v_Pgm_i, error "pgm_i", String) -- ilasm
-#endif
-GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld
-GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll
-
GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
-GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String)
+GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String))
GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
%************************************************************************
\begin{code}
-initSysTools :: [String] -- Command-line arguments starting "-B"
+initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
- -> IO () -- Set all the mutable variables above, holding
+ -> DynFlags
+ -> IO DynFlags -- Set all the mutable variables above, holding
-- (a) the system programs
-- (b) the package-config file
-- (c) the GHC usage message
-initSysTools minusB_args
- = do { (am_installed, top_dir) <- findTopDir minusB_args
+initSysTools mbMinusB dflags
+ = do { (am_installed, top_dir) <- findTopDir mbMinusB
; writeIORef v_TopDir top_dir
-- top_dir
-- for "installed" this is the root of GHC's support files
-- NB: top_dir is assumed to be in standard Unix format '/' separated
; let installed, installed_bin :: FilePath -> FilePath
- installed_bin pgm = pgmPath (top_dir `slash` "extra-bin") pgm
+ installed_bin pgm = pgmPath top_dir pgm
installed file = pgmPath top_dir file
- inplace dir pgm = pgmPath (top_dir `slash` dir) pgm
+ inplace dir pgm = pgmPath (top_dir `joinFileName`
+ cPROJECT_DIR `joinFileName` dir) pgm
; let pkgconfig_path
| am_installed = installed "package.conf"
- | otherwise = inplace cGHC_DRIVER_DIR "package.conf.inplace"
+ | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
ghc_usage_msg_path
| am_installed = installed "ghc-usage.txt"
- | otherwise = inplace cGHC_DRIVER_DIR "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"
-- 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
- | otherwise = inplace cGHC_UNLIT_DIR cGHC_UNLIT
+ | am_installed = installed_bin cGHC_UNLIT_PGM
+ | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
-- split and mangle are Perl scripts
split_script
- | am_installed = installed_bin cGHC_SPLIT
- | otherwise = inplace cGHC_SPLIT_DIR cGHC_SPLIT
+ | am_installed = installed_bin cGHC_SPLIT_PGM
+ | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
mangle_script
- | am_installed = installed_bin cGHC_MANGLER
- | otherwise = inplace cGHC_MANGLER_DIR cGHC_MANGLER
+ | am_installed = installed_bin cGHC_MANGLER_PGM
+ | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
-#ifndef mingw32_TARGET_OS
+ ; let dflags0 = defaultDynFlags
+#ifndef mingw32_HOST_OS
-- check whether TMPDIR is set in the environment
- ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
- setTmpDir dir
- return ()
- )
+ ; 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
-- Check that the package config exists
; config_exists <- doesFileExist pkgconfig_path
throwDyn (InstallationError
("Can't find package.conf as " ++ pkgconfig_path))
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
-- WINDOWS-SPECIFIC STUFF
-- On Windows, gcc and friends are distributed with GHC,
-- so when "installed" we look in TopDir/bin
-- 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/\"")
- | otherwise = cGCC
+ ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
+ (gcc_prog,gcc_args)
+ | am_installed = (installed_bin "gcc", [gcc_b_arg])
+ | otherwise = (cGCC, [])
-- 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_path is in NATIVE format, gcc can cope
+ -- 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)
--
- -- The quotes round the -B argument are in case TopDir has spaces in it
+ -- 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
-- 'touch' is a GHC util for Windows, and similarly unlit, mangle
- ; let touch_path | am_installed = installed_bin cGHC_TOUCHY
- | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
+ ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
+ | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
-- 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
- ; let split_path = perl_path ++ " \"" ++ split_script ++ "\""
- mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
-
- ; let mkdll_path = cMKDLL
+ ; let (split_prog, split_args) = (perl_path, [Option split_script])
+ (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
+
+ ; let (mkdll_prog, mkdll_args)
+ | am_installed =
+ (pgmPath (installed "gcc-lib/") cMKDLL,
+ [ Option "--dlltool-name",
+ Option (pgmPath (installed "gcc-lib/") "dlltool"),
+ Option "--driver-name",
+ Option gcc_prog, gcc_b_arg ])
+ | otherwise = (cMKDLL, [])
#else
-- UNIX-SPECIFIC STUFF
-- 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 gcc_path = cGCC
- touch_path = cGHC_TOUCHY
- mkdll_path = panic "Can't build DLLs on a non-Win32 system"
+ ; let gcc_prog = cGCC
+ gcc_args = []
+ touch_path = "touch"
+ mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
+ mkdll_args = []
-- On Unix, scripts are invoked using the '#!' method. Binary
-- installations of GHC on Unix place the correct line on the front
-- of the script at installation time, so we don't want to wire-in
-- our knowledge of $(PERL) on the host system here.
- ; let split_path = split_script
- mangle_path = mangle_script
+ ; let (split_prog, split_args) = (split_script, [])
+ (mangle_prog, mangle_args) = (mangle_script, [])
#endif
-- cpp is derived from gcc on all platforms
- ; let cpp_path = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
+ -- HACK, see setPgmP below. We keep 'words' here to remember to fix
+ -- Config.hs one day.
+ ; let cpp_path = (gcc_prog, gcc_args ++
+ (Option "-E"):(map Option (words 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
-- Other things being equal, as and ld are simply gcc
- ; let as_path = gcc_path
- ld_path = gcc_path
+ ; let (as_prog,as_args) = (gcc_prog,gcc_args)
+ (ld_prog,ld_args) = (gcc_prog,gcc_args)
-#ifdef ILX
- -- ilx2il and ilasm are specified in Config.hs
- ; let ilx2il_path = cILX2IL
- ilasm_path = cILASM
-#endif
-
-- Initialise the global vars
; writeIORef v_Path_package_config pkgconfig_path
- ; writeIORef v_Path_usage ghc_usage_msg_path
+ ; writeIORef v_Path_usages (ghc_usage_msg_path,
+ ghci_usage_msg_path)
; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
-- Hans: this isn't right in general, but you can
-- elaborate it in the same way as the others
- ; writeIORef v_Pgm_L unlit_path
- ; writeIORef v_Pgm_P cpp_path
- ; writeIORef v_Pgm_c gcc_path
- ; writeIORef v_Pgm_m mangle_path
- ; writeIORef v_Pgm_s split_path
- ; writeIORef v_Pgm_a as_path
-#ifdef ILX
- ; writeIORef v_Pgm_I ilx2il_path
- ; writeIORef v_Pgm_i ilasm_path
-#endif
- ; writeIORef v_Pgm_l ld_path
- ; writeIORef v_Pgm_MkDLL mkdll_path
; writeIORef v_Pgm_T touch_path
; writeIORef v_Pgm_CP cp_path
- ; return ()
+ ; return dflags1{
+ pgm_L = unlit_path,
+ pgm_P = cpp_path,
+ pgm_F = "",
+ pgm_c = (gcc_prog,gcc_args),
+ 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_dll = (mkdll_prog,mkdll_args) }
}
-\end{code}
-
-setPgm is called when a command-line option like
- -pgmLld
-is used to override a particular program with a new one
-\begin{code}
-setPgm :: String -> IO ()
--- The string is the flag, minus the '-pgm' prefix
--- So the first character says which program to override
-
-setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
-setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
-setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
-setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
-setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
-setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
-#ifdef ILX
-setPgm ('I' : pgm) = writeIORef v_Pgm_I pgm
-setPgm ('i' : pgm) = writeIORef v_Pgm_i pgm
+#if defined(mingw32_HOST_OS)
+foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
#endif
-setPgm pgm = unknownFlagErr ("-pgm" ++ pgm)
\end{code}
-
\begin{code}
-- Find TopDir
-- for "installed" this is the root of GHC's support files
--
-- Plan of action:
-- 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 (only on Windows)
+-- 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
--
-- This is very gruesome indeed
-findTopDir :: [String]
- -> IO (Bool, -- True <=> am installed, False <=> in-place
- String) -- TopDir (in Unix format '/' separated)
+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 minusbs
+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 `slash` "package.conf")
+ ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf")
; return (am_installed, top_dir)
}
where
- -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
- 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<dir> option")
- Just dir -> return dir
- }
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Command-line options}
-n%* *
-%************************************************************************
-
-When invoking external tools as part of the compilation pipeline, we
-pass these a sequence of options on the command-line. Rather than
-just using a list of Strings, we use a type that allows us to distinguish
-between filepaths and 'other stuff'. [The reason being, of course, that
-this type gives us a handle on transforming filenames, and filenames only,
-to whatever format they're expected to be on a particular platform.]
-
-
-\begin{code}
-data Option
- = FileOption String
- | Option String
-
-showOptions :: [Option] -> String
-showOptions ls = unwords (map (quote.showOpt) ls)
- where
- showOpt (FileOption f) = dosifyPath f
- showOpt (Option s) = s
-
-#if defined(mingw32_TARGET_OS)
- quote "" = ""
- quote s = "\"" ++ s ++ "\""
-#else
- quote = id
-#endif
-
+ -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
+ get_proto = case mbMinusB of
+ Just minusb -> return (normalisePath 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<dir> option")
+ Just dir -> return dir
\end{code}
%************************************************************************
%* *
\subsection{Running an external program}
-n%* *
+%* *
%************************************************************************
\begin{code}
-runUnlit :: [Option] -> IO ()
-runUnlit args = do p <- readIORef v_Pgm_L
- runSomething "Literate pre-processor" p args
-
-runCpp :: [Option] -> IO ()
-runCpp args = do p <- readIORef v_Pgm_P
- runSomething "C pre-processor" p args
-
-runCc :: [Option] -> IO ()
-runCc args = do p <- readIORef v_Pgm_c
- runSomething "C Compiler" p args
-
-runMangle :: [Option] -> IO ()
-runMangle args = do p <- readIORef v_Pgm_m
- runSomething "Mangler" p args
-
-runSplit :: [Option] -> IO ()
-runSplit args = do p <- readIORef v_Pgm_s
- runSomething "Splitter" p args
-
-runAs :: [Option] -> IO ()
-runAs args = do p <- readIORef v_Pgm_a
- runSomething "Assembler" p args
-
-runLink :: [Option] -> IO ()
-runLink args = do p <- readIORef v_Pgm_l
- runSomething "Linker" p args
-
-#ifdef ILX
-runIlx2il :: [String] -> IO ()
-runIlx2il args = do p <- readIORef v_Pgm_I
- runSomething "Ilx2Il" p args
-
-runIlasm :: [String] -> IO ()
-runIlasm args = do p <- readIORef v_Pgm_i
- runSomething "Ilasm" p args
-#endif
-
-runMkDLL :: [Option] -> IO ()
-runMkDLL args = do p <- readIORef v_Pgm_MkDLL
- runSomething "Make DLL" p args
-
-touch :: String -> String -> IO ()
-touch purpose arg = do p <- readIORef v_Pgm_T
- runSomething purpose p [FileOption arg]
-
-copy :: String -> String -> String -> IO ()
-copy purpose from to = do
- verb <- dynFlag verbosity
- when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
+runUnlit :: DynFlags -> [Option] -> IO ()
+runUnlit dflags args = do
+ let p = pgm_L dflags
+ runSomething dflags "Literate pre-processor" p args
+
+runCpp :: DynFlags -> [Option] -> IO ()
+runCpp dflags args = do
+ let (p,args0) = pgm_P dflags
+ runSomething dflags "C pre-processor" p (args0 ++ args)
+
+runPp :: DynFlags -> [Option] -> IO ()
+runPp dflags args = do
+ let p = pgm_F dflags
+ runSomething dflags "Haskell pre-processor" p args
+
+runCc :: DynFlags -> [Option] -> IO ()
+runCc dflags args = do
+ let (p,args0) = pgm_c dflags
+ runSomethingFiltered dflags cc_filter "C Compiler" p (args0++args)
+ where
+ -- discard some harmless warnings from gcc that we can't turn off
+ cc_filter str = unlines (do_filter (lines str))
+
+ do_filter [] = []
+ do_filter ls@(l:ls')
+ | (w:rest) <- dropWhile (isJust .matchRegex r_from) ls,
+ isJust (matchRegex r_warn w)
+ = do_filter rest
+ | otherwise
+ = l : do_filter ls'
+
+ r_from = mkRegex "from.*:[0-9]+"
+ r_warn = mkRegex "warning: call-clobbered register used"
+
+runMangle :: DynFlags -> [Option] -> IO ()
+runMangle dflags args = do
+ let (p,args0) = pgm_m dflags
+ runSomething dflags "Mangler" p (args0++args)
+
+runSplit :: DynFlags -> [Option] -> IO ()
+runSplit dflags args = do
+ let (p,args0) = pgm_s dflags
+ runSomething dflags "Splitter" p (args0++args)
+
+runAs :: DynFlags -> [Option] -> IO ()
+runAs dflags args = do
+ let (p,args0) = pgm_a dflags
+ runSomething dflags "Assembler" p (args0++args)
+
+runLink :: DynFlags -> [Option] -> IO ()
+runLink dflags args = do
+ let (p,args0) = pgm_l dflags
+ runSomething dflags "Linker" p (args0++args)
+
+runMkDLL :: DynFlags -> [Option] -> IO ()
+runMkDLL dflags args = do
+ let (p,args0) = pgm_dll dflags
+ runSomething dflags "Make DLL" p (args0++args)
+
+touch :: DynFlags -> String -> String -> IO ()
+touch dflags purpose arg = do
+ p <- readIORef v_Pgm_T
+ runSomething dflags purpose p [FileOption "" arg]
+
+copy :: DynFlags -> String -> String -> String -> IO ()
+copy dflags purpose 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.
hPutStr h ls
hClose h
+
\end{code}
\begin{code}
getSysMan = readIORef v_Pgm_sysman
\end{code}
-%************************************************************************
-%* *
-\subsection{GHC Usage message}
-%* *
-%************************************************************************
-
-Show the usage message and exit
-
\begin{code}
-showGhcUsage = do { usage_path <- readIORef v_Path_usage
- ; usage <- readFile usage_path
- ; dump usage
- ; exitWith ExitSuccess }
- where
- dump "" = return ()
- dump ('$':'$':s) = hPutStr stderr progName >> dump s
- dump (c:s) = hPutChar stderr c >> dump s
+getUsageMsgPaths :: IO (FilePath,FilePath)
+ -- the filenames of the usage messages (ghc, ghci)
+getUsageMsgPaths = readIORef v_Path_usages
\end{code}
\begin{code}
GLOBAL_VAR(v_FilesToClean, [], [String] )
-GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
- -- v_TmpDir has no closing '/'
\end{code}
\begin{code}
-setTmpDir dir = writeIORef v_TmpDir dir
-
-cleanTempFiles :: Int -> IO ()
-cleanTempFiles verb = do fs <- readIORef v_FilesToClean
- removeTmpFiles verb fs
+cleanTempFiles :: DynFlags -> IO ()
+cleanTempFiles dflags
+ = do fs <- readIORef v_FilesToClean
+ removeTmpFiles dflags fs
+ writeIORef v_FilesToClean []
-cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
-cleanTempFilesExcept verb dont_delete
- = do fs <- readIORef v_FilesToClean
- let leftovers = filter (`notElem` dont_delete) fs
- removeTmpFiles verb leftovers
- writeIORef v_FilesToClean dont_delete
+cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
+cleanTempFilesExcept dflags dont_delete
+ = do files <- readIORef v_FilesToClean
+ let (to_keep, to_delete) = partition (`elem` dont_delete) files
+ removeTmpFiles dflags to_delete
+ writeIORef v_FilesToClean to_keep
-- find a temporary name that doesn't already exist.
-newTempName :: Suffix -> IO FilePath
-newTempName extn
+newTempName :: DynFlags -> Suffix -> IO FilePath
+newTempName DynFlags{tmpDir=tmp_dir} extn
= do x <- getProcessID
- tmp_dir <- readIORef v_TmpDir
- findTempName tmp_dir x
+ findTempName (tmp_dir ++ "/ghc" ++ show x ++ "_") 0
where
- findTempName tmp_dir x
- = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
+ findTempName prefix x
+ = do let filename = (prefix ++ show x) `joinFileExt` extn
b <- doesFileExist filename
- if b then findTempName tmp_dir (x+1)
- else do add v_FilesToClean filename -- clean it up later
+ if b then findTempName prefix (x+1)
+ else do consIORef v_FilesToClean filename -- clean it up later
return filename
addFilesToClean :: [FilePath] -> IO ()
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
-addFilesToClean files = mapM_ (add v_FilesToClean) files
-
-removeTmpFiles :: Int -> [FilePath] -> IO ()
-removeTmpFiles verb fs
- = traceCmd "Deleting temp files"
- ("Deleting: " ++ unwords fs)
- (mapM_ rm fs)
+addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
+
+removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
+removeTmpFiles dflags fs
+ = warnNon $
+ traceCmd dflags "Deleting temp files"
+ ("Deleting: " ++ unwords deletees)
+ (mapM_ rm deletees)
where
- rm f = removeFile f `catchAllIO`
+ -- Flat out refuse to delete files that are likely to be source input
+ -- files (is there a worse bug than having a compiler delete your source
+ -- files?)
+ --
+ -- Deleting source files is a sign of a bug elsewhere, so prominently flag
+ -- the condition.
+ warnNon act
+ | null non_deletees = act
+ | otherwise = do
+ putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
+ act
+
+ (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
+
+ rm f = removeFile f `IO.catch`
(\_ignored ->
- when (verb >= 2) $
- hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
+ debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Running a program}
-%* *
-%************************************************************************
-
-\begin{code}
-GLOBAL_VAR(v_Dry_run, False, Bool)
-
-setDryRun :: IO ()
-setDryRun = writeIORef v_Dry_run True
-----------------------------------------------------------------------------
-- Running an external program
-runSomething :: String -- For -v message
+runSomething :: DynFlags
+ -> String -- For -v message
-> String -- Command name (possibly a full path)
-- assumed already dos-ified
-> [Option] -- Arguments
-- runSomething will dos-ify them
-> IO ()
-runSomething phase_name pgm args
- = traceCmd phase_name cmd_line $
- do {
-#ifndef mingw32_TARGET_OS
- exit_code <- system cmd_line
-#else
- exit_code <- rawSystem cmd_line
+runSomething dflags phase_name pgm args =
+ runSomethingFiltered dflags id phase_name pgm args
+
+runSomethingFiltered
+ :: DynFlags -> (String->String) -> String -> String -> [Option] -> IO ()
+
+runSomethingFiltered dflags filter_fn phase_name pgm args = do
+ let real_args = filter notNull (map showOpt args)
+ traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
+ (exit_code, doesn'tExist) <-
+ IO.catch (do
+ rc <- builderMainLoop dflags filter_fn pgm real_args
+ case rc of
+ ExitSuccess{} -> return (rc, False)
+ ExitFailure n
+ -- rawSystem returns (ExitFailure 127) if the exec failed for any
+ -- reason (eg. the program doesn't exist). This is the only clue
+ -- we have, but we need to report something to the user because in
+ -- the case of a missing program there will otherwise be no output
+ -- at all.
+ | n == 127 -> return (rc, True)
+ | otherwise -> return (rc, False))
+ -- Should 'rawSystem' generate an IO exception indicating that
+ -- 'pgm' couldn't be run rather than a funky return code, catch
+ -- this here (the win32 version does this, but it doesn't hurt
+ -- to test for this in general.)
+ (\ err ->
+ if IO.isDoesNotExistError err
+#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
+ -- the 'compat' version of rawSystem under mingw32 always
+ -- maps 'errno' to EINVAL to failure.
+ || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
#endif
- ; if exit_code /= ExitSuccess
- then throwDyn (PhaseFailed phase_name exit_code)
- else return ()
- }
- where
- cmd_line = pgm ++ ' ':showOptions args -- unwords (pgm : dosifyPaths (map quote args))
- -- The pgm is already in native format (appropriate dir separators)
-#if defined(mingw32_TARGET_OS)
- quote "" = ""
- quote s = "\"" ++ s ++ "\""
+ then return (ExitFailure 1, True)
+ else IO.ioError err)
+ case (doesn'tExist, exit_code) of
+ (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
+ (_, ExitSuccess) -> return ()
+ _ -> throwDyn (PhaseFailed phase_name exit_code)
+
+
+
+#if __GLASGOW_HASKELL__ < 603
+builderMainLoop dflags filter_fn pgm real_args = do
+ rawSystem pgm real_args
#else
- quote = id
+builderMainLoop dflags filter_fn pgm real_args = do
+ chan <- newChan
+ (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing
+
+ -- 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)
+ rc <- loop chan hProcess 2 1 ExitSuccess
+ hClose hStdIn
+ hClose hStdOut
+ hClose hStdErr
+ return rc
+ where
+ -- status starts at zero, and increments each time either
+ -- a reader process gets EOF, or the build proc exits. We wait
+ -- for all of these to happen (status==3).
+ -- ToDo: we should really have a contingency plan in case any of
+ -- the threads dies, such as a timeout.
+ loop chan hProcess 0 0 exitcode = return exitcode
+ loop chan hProcess t p exitcode = do
+ mb_code <- if p > 0
+ then getProcessExitCode hProcess
+ else return Nothing
+ case mb_code of
+ Just code -> loop chan hProcess t (p-1) code
+ Nothing
+ | t > 0 -> do
+ msg <- readChan chan
+ case msg of
+ BuildMsg msg -> do
+ log_action dflags SevInfo noSrcSpan defaultUserStyle msg
+ loop chan hProcess t p exitcode
+ BuildError loc msg -> do
+ log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
+ loop chan hProcess t p exitcode
+ EOF ->
+ loop chan hProcess (t-1) p exitcode
+ | otherwise -> loop chan hProcess t p exitcode
+
+readerProc chan hdl filter_fn =
+ (do str <- hGetContents hdl
+ loop (lines (filter_fn str)) Nothing)
+ `finally`
+ writeChan chan EOF
+ -- ToDo: check errors more carefully
+ -- ToDo: in the future, the filter should be implemented as
+ -- a stream transformer.
+ where
+ loop [] Nothing = return ()
+ loop [] (Just err) = writeChan chan err
+ loop (l:ls) in_err =
+ case in_err of
+ Just err@(BuildError srcLoc msg)
+ | leading_whitespace l -> do
+ loop ls (Just (BuildError srcLoc (msg $$ text l)))
+ | otherwise -> do
+ writeChan chan err
+ checkError l ls
+ Nothing -> do
+ checkError l ls
+
+ checkError l ls
+ = case matchRegex errRegex l of
+ Nothing -> do
+ writeChan chan (BuildMsg (text l))
+ loop ls Nothing
+ Just (file':lineno':colno':msg:_) -> do
+ let file = mkFastString file'
+ lineno = read lineno'::Int
+ colno = case colno' of
+ "" -> 0
+ _ -> read (init colno') :: Int
+ srcLoc = mkSrcLoc file lineno colno
+ loop ls (Just (BuildError srcLoc (text msg)))
+
+ leading_whitespace [] = False
+ leading_whitespace (x:_) = isSpace x
+
+errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"
+
+data BuildMessage
+ = BuildMsg !SDoc
+ | BuildError !SrcLoc !SDoc
+ | EOF
#endif
-traceCmd :: String -> String -> IO () -> IO ()
+showOpt (FileOption pre f) = pre ++ platformPath f
+showOpt (Option "") = ""
+showOpt (Option s) = s
+
+traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
-- a) trace the command (at two levels of verbosity)
-- b) don't do it at all if dry-run is set
-traceCmd phase_name cmd_line action
- = do { verb <- dynFlag verbosity
- ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
- ; when (verb >= 3) $ hPutStrLn stderr cmd_line
+traceCmd dflags phase_name cmd_line action
+ = do { let verb = verbosity dflags
+ ; showPass dflags phase_name
+ ; debugTraceMsg dflags 3 (text cmd_line)
; hFlush stderr
-- Test for -n flag
- ; n <- readIORef v_Dry_run
- ; unless n $ do {
+ ; unless (dopt Opt_DryRun dflags) $ do {
-- And run it!
- ; action `catchAllIO` handle_exn verb
+ ; action `IO.catch` handle_exn verb
}}
where
- handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
- ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
+ 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)) }
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Path names}
-%* *
-%************************************************************************
-
-We maintain path names in Unix form ('/'-separated) right until
-the last moment. On Windows we dos-ify them just before passing them
-to the Windows command.
-
-The alternative, of using '/' consistently on Unix and '\' on Windows,
-proved quite awkward. There were a lot more calls to dosifyPath,
-and even on Windows we might invoke a unix-like utility (eg 'sh'), which
-interpreted a command line 'foo\baz' as 'foobaz'.
-
-\begin{code}
------------------------------------------------------------------------------
--- Convert filepath into MSDOS form.
-
-dosifyPaths :: [String] -> [String]
--- dosifyPaths does two things
--- a) change '/' to '\'
--- b) remove initial '/cygdrive/'
-
-unDosifyPath :: String -> String
--- Just change '\' to '/'
-
-pgmPath :: String -- Directory string in Unix format
- -> String -- Program name with no directory separators
- -- (e.g. copy /y)
- -> String -- Program invocation string in native format
-
-
-
-#if defined(mingw32_TARGET_OS)
-
---------------------- Windows version ------------------
-dosifyPaths xs = map dosifyPath xs
-
-unDosifyPath xs = subst '\\' '/' xs
-
-pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
-
--- HACK!
-dosifyPath "\"/DLL\"" = "\"/DLL\""
-dosifyPath "\"/QUIET\"" = "\"/QUIET\""
-dosifyPath l@('"':'/':'O':'U':'T':_) = l
--- end of HACK!
-dosifyPath stuff
- = subst '/' '\\' real_stuff
- where
- -- fully convince myself that /cygdrive/ prefixes cannot
- -- really appear here.
- cygdrive_prefix = "/cygdrive/"
-
- real_stuff
- | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
- | otherwise = stuff
-
-#else
-
---------------------- Unix version ---------------------
-dosifyPaths ps = ps
-unDosifyPath xs = xs
-pgmPath dir pgm = dir ++ '/' : pgm
-dosifyPath stuff = stuff
---------------------------------------------------------
-#endif
-
-subst a b ls = map (\ x -> if x == a then b else x) ls
-\end{code}
-
-
------------------------------------------------------------------------------
- Path name construction
-
-\begin{code}
-slash :: String -> String -> String
-absPath, relPath :: [String] -> String
-
-isSlash '/' = True
-isSlash other = False
-
-relPath [] = ""
-relPath xs = foldr1 slash xs
-
-absPath xs = "" `slash` relPath xs
-
-slash s1 s2 = s1 ++ ('/' : s2)
-\end{code}
-
-
%************************************************************************
%* *
\subsection{Support code}
\begin{code}
-----------------------------------------------------------------------------
--- Define getExecDir :: IO (Maybe String)
-
-#if defined(mingw32_TARGET_OS)
-getExecDir :: IO (Maybe String)
-getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
- buf <- mallocArray (fromIntegral len)
- ret <- getModuleFileName nullAddr buf len
- if ret == 0 then return Nothing
+-- Define getBaseDir :: IO (Maybe String)
+
+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.
+getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
+ buf <- mallocArray len
+ ret <- getModuleFileName nullPtr buf len
+ if ret == 0 then free buf >> return Nothing
else do s <- peekCString buf
- destructArray (fromIntegral len) buf
- return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
-
+ free buf
+ return (Just (rootDir s))
+ where
+ rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
-foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
+foreign import stdcall unsafe "GetModuleFileNameA"
+ getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
-getExecDir :: IO (Maybe String) = do return Nothing
+getBaseDir = return Nothing
#endif
-#ifdef mingw32_TARGET_OS
-foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
+#elif __GLASGOW_HASKELL__ > 504
+getProcessID :: IO Int
+getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
#else
getProcessID :: IO Int
getProcessID = Posix.getProcessID
#endif
-rawSystem :: String -> IO ExitCode
-rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
-rawSystem cmd =
- withCString cmd $ \s -> do
- status <- throwErrnoIfMinus1 "rawSystem" (primRawSystem s)
- case status of
- 0 -> return ExitSuccess
- n -> return (ExitFailure n)
-
-foreign import ccall "rawSystemCmd" unsafe primRawSystem :: CString -> IO Int
-
\end{code}
projects / ghc-hetmet.git / blobdiff