-- 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)
import Config
import Outputable
import Panic ( GhcException(..) )
-import Util ( global, notNull, toArgs )
-import CmdLineOpts ( dynFlag, verbosity )
+import Util ( global, notNull )
+import CmdLineOpts ( DynFlags(..) )
import EXCEPTION ( throwDyn )
import DATA_IOREF ( IORef, readIORef, writeIORef )
import Directory ( doesFileExist, removeFile )
import List ( partition )
-#include "../includes/config.h"
-
-- 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
#endif
#if __GLASGOW_HASKELL__ < 603
-import Foreign ( withMany, withArray0, nullPtr, Ptr )
-import CForeign ( CString, withCString, throwErrnoIfMinus1 )
+-- rawSystem comes from libghccompat.a in stage1
+import Compat.RawSystem ( rawSystem )
#else
import System.Cmd ( rawSystem )
#endif
{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
GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
GLOBAL_VAR(v_Pgm_P, error "pgm_P", (String,[Option])) -- cpp
GLOBAL_VAR(v_Pgm_F, error "pgm_F", String) -- pp
-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
+GLOBAL_VAR(v_Pgm_c, error "pgm_c", (String,[Option])) -- gcc
+GLOBAL_VAR(v_Pgm_m, error "pgm_m", (String,[Option])) -- asm code mangler
+GLOBAL_VAR(v_Pgm_s, error "pgm_s", (String,[Option])) -- asm code splitter
+GLOBAL_VAR(v_Pgm_a, error "pgm_a", (String,[Option])) -- 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_l, error "pgm_l", (String,[Option])) -- ld
+GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", (String,[Option])) -- mkdll
GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
-- 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
-- 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
- | am_installed = pgmPath (installed "gcc-lib/") cMKDLL ++
- " --dlltool-name " ++ pgmPath (installed "gcc-lib/") "dlltool" ++
- " --driver-name " ++ gcc_path
- | otherwise = 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
+ ; let gcc_prog = cGCC
+ gcc_args = []
touch_path = "touch"
- mkdll_path = panic "Can't build DLLs on a non-Win32 system"
+ 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
-- HACK, see setPgmP below. We keep 'words' here to remember to fix
-- Config.hs one day.
- ; let cpp_path = (gcc_path, (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
+ ; 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
; writeIORef v_Pgm_L unlit_path
; writeIORef v_Pgm_P cpp_path
; writeIORef v_Pgm_F ""
- ; writeIORef v_Pgm_c gcc_path
- ; writeIORef v_Pgm_m mangle_path
- ; writeIORef v_Pgm_s split_path
- ; writeIORef v_Pgm_a as_path
+ ; writeIORef v_Pgm_c (gcc_prog,gcc_args)
+ ; writeIORef v_Pgm_m (mangle_prog,mangle_args)
+ ; writeIORef v_Pgm_s (split_prog,split_args)
+ ; writeIORef v_Pgm_a (as_prog,as_args)
#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_l (ld_prog,ld_args)
+ ; writeIORef v_Pgm_MkDLL (mkdll_prog,mkdll_args)
; writeIORef v_Pgm_T touch_path
; writeIORef v_Pgm_CP cp_path
}
#if defined(mingw32_HOST_OS)
-foreign import stdcall "GetTempPathA" unsafe getTempPath :: Int -> CString -> IO Int32
+foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
#endif
\end{code}
-- Config.hs should really use Option.
setPgmP arg = let (pgm:args) = words arg in writeIORef v_Pgm_P (pgm,map Option args)
setPgmF = writeIORef v_Pgm_F
-setPgmc = writeIORef v_Pgm_c
-setPgmm = writeIORef v_Pgm_m
-setPgms = writeIORef v_Pgm_s
-setPgma = writeIORef v_Pgm_a
-setPgml = writeIORef v_Pgm_l
-setPgmDLL = writeIORef v_Pgm_MkDLL
+setPgmc prog = writeIORef v_Pgm_c (prog,[])
+setPgmm prog = writeIORef v_Pgm_m (prog,[])
+setPgms prog = writeIORef v_Pgm_s (prog,[])
+setPgma prog = writeIORef v_Pgm_a (prog,[])
+setPgml prog = writeIORef v_Pgm_l (prog,[])
+setPgmDLL prog = writeIORef v_Pgm_MkDLL (prog,[])
#ifdef ILX
setPgmI = writeIORef v_Pgm_I
setPgmi = writeIORef v_Pgm_i
\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,baseArgs) <- readIORef v_Pgm_P
- runSomething "C pre-processor" p (baseArgs ++ args)
-
-runPp :: [Option] -> IO ()
-runPp args = do p <- readIORef v_Pgm_F
- runSomething "Haskell 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
+runUnlit :: DynFlags -> [Option] -> IO ()
+runUnlit dflags args = do
+ p <- readIORef v_Pgm_L
+ runSomething dflags "Literate pre-processor" p args
+
+runCpp :: DynFlags -> [Option] -> IO ()
+runCpp dflags args = do
+ (p,baseArgs) <- readIORef v_Pgm_P
+ runSomething dflags "C pre-processor" p (baseArgs ++ args)
+
+runPp :: DynFlags -> [Option] -> IO ()
+runPp dflags args = do
+ p <- readIORef v_Pgm_F
+ runSomething dflags "Haskell pre-processor" p args
+
+runCc :: DynFlags -> [Option] -> IO ()
+runCc dflags args = do
+ (p,args0) <- readIORef v_Pgm_c
+ runSomething dflags "C Compiler" p (args0++args)
+
+runMangle :: DynFlags -> [Option] -> IO ()
+runMangle dflags args = do
+ (p,args0) <- readIORef v_Pgm_m
+ runSomething dflags "Mangler" p (args0++args)
+
+runSplit :: DynFlags -> [Option] -> IO ()
+runSplit dflags args = do
+ (p,args0) <- readIORef v_Pgm_s
+ runSomething dflags "Splitter" p (args0++args)
+
+runAs :: DynFlags -> [Option] -> IO ()
+runAs dflags args = do
+ (p,args0) <- readIORef v_Pgm_a
+ runSomething dflags "Assembler" p (args0++args)
+
+runLink :: DynFlags -> [Option] -> IO ()
+runLink dflags args = do
+ (p,args0) <- readIORef v_Pgm_l
+ runSomething dflags "Linker" p (args0++args)
#ifdef ILX
-runIlx2il :: [Option] -> IO ()
-runIlx2il args = do p <- readIORef v_Pgm_I
- runSomething "Ilx2Il" p args
-
-runIlasm :: [Option] -> IO ()
-runIlasm args = do p <- readIORef v_Pgm_i
- runSomething "Ilasm" p args
+runIlx2il :: DynFlags -> [Option] -> IO ()
+runIlx2il dflags args = do
+ p <- readIORef v_Pgm_I
+ runSomething dflags "Ilx2Il" p args
+
+runIlasm :: DynFlags -> [Option] -> IO ()
+runIlasm dflags args = do
+ p <- readIORef v_Pgm_i
+ runSomething dflags "Ilasm" p args
#endif
-runMkDLL :: [Option] -> IO ()
-runMkDLL args = do p <- readIORef v_Pgm_MkDLL
- runSomething "Make DLL" p args
+runMkDLL :: DynFlags -> [Option] -> IO ()
+runMkDLL dflags args = do
+ (p,args0) <- readIORef v_Pgm_MkDLL
+ runSomething dflags "Make DLL" p (args0++args)
-touch :: String -> String -> IO ()
-touch purpose arg = do p <- readIORef v_Pgm_T
- runSomething purpose p [FileOption "" arg]
+touch :: DynFlags -> String -> String -> IO ()
+touch dflags purpose arg = do
+ p <- readIORef v_Pgm_T
+ runSomething dflags purpose p [FileOption "" arg]
-copy :: String -> String -> String -> IO ()
-copy purpose from to = do
- verb <- dynFlag verbosity
- when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
+copy :: DynFlags -> String -> String -> String -> IO ()
+copy dflags purpose from to = do
+ when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
h <- openFile to WriteMode
ls <- readFile from -- inefficient, but it'll do for now.
_ -> path
#endif
-cleanTempFiles :: Int -> IO ()
-cleanTempFiles verb
+cleanTempFiles :: DynFlags -> IO ()
+cleanTempFiles dflags
= do fs <- readIORef v_FilesToClean
- removeTmpFiles verb fs
+ removeTmpFiles dflags fs
writeIORef v_FilesToClean []
-cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
-cleanTempFilesExcept verb 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 verb to_delete
+ removeTmpFiles dflags to_delete
writeIORef v_FilesToClean to_keep
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
addFilesToClean files = mapM_ (add v_FilesToClean) files
-removeTmpFiles :: Int -> [FilePath] -> IO ()
-removeTmpFiles verb fs
+removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
+removeTmpFiles dflags fs
= warnNon $
- traceCmd "Deleting temp files"
+ traceCmd dflags "Deleting temp files"
("Deleting: " ++ unwords deletees)
(mapM_ rm deletees)
where
+ verb = verbosity dflags
+
-- 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?)
-----------------------------------------------------------------------------
-- 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 = do
+runSomething dflags phase_name pgm args = do
let real_args = filter notNull (map showOpt args)
- -- Don't assume that 'pgm' contains the program path only,
- -- but split it up and shift any arguments over to the arg vector.
- let (real_pgm, argv) =
- case toArgs pgm of
- [] -> (pgm, real_args) -- let rawSystem be the bearer of bad news..
- (x:xs) -> (x, xs ++ real_args)
- traceCmd phase_name (unwords (pgm:real_args)) $ do
- exit_code <- rawSystem real_pgm argv
- if (exit_code /= ExitSuccess)
- then throwDyn (PhaseFailed phase_name exit_code)
- else return ()
-
-traceCmd :: String -> String -> IO () -> IO ()
+ traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
+ exit_code <- rawSystem pgm real_args
+ case exit_code of
+ ExitSuccess ->
+ return ()
+ -- 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.
+ ExitFailure 127 ->
+ throwDyn (InstallationError ("could not execute: " ++ pgm))
+ ExitFailure _other ->
+ throwDyn (PhaseFailed phase_name exit_code)
+
+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
+traceCmd dflags phase_name cmd_line action
+ = do { let verb = verbosity dflags
; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
; when (verb >= 3) $ hPutStrLn stderr cmd_line
; hFlush stderr
handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
-
--- -----------------------------------------------------------------------------
--- rawSystem: run an external command
---
--- In GHC 6.2.1 there's a correct implementation of rawSystem in the
--- library System.Cmd. If we are compiling with an earlier version of
--- GHC than this, we'd better have a copy of the correct implementation
--- right here.
-
--- If you ever alter this code, you must alter
--- libraries/base/System/Cmd.hs
--- at the same time! There are also exensive comments in System.Cmd
--- thare are not repeated here -- go look!
-
-
-#if __GLASGOW_HASKELL__ < 603
-
-rawSystem :: FilePath -> [String] -> IO ExitCode
-
-#ifndef mingw32_TARGET_OS
-
-rawSystem cmd args =
- withCString cmd $ \pcmd ->
- withMany withCString (cmd:args) $ \cstrs ->
- withArray0 nullPtr cstrs $ \arr -> do
- status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmd arr)
- case status of
- 0 -> return ExitSuccess
- n -> return (ExitFailure n)
-
-foreign import ccall "rawSystem" unsafe
- c_rawSystem :: CString -> Ptr CString -> IO Int
-
-#else
-
--- On Windows, the command line is passed to the operating system as
--- a single string. Command-line parsing is done by the executable
--- itself.
-rawSystem cmd args = do
- -- NOTE: 'cmd' is assumed to contain the application to run _only_,
- -- as it'll be quoted surrounded in quotes here.
- let cmdline = translate cmd ++ concat (map ((' ':) . translate) args)
- withCString cmdline $ \pcmdline -> do
- status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmdline)
- case status of
- 0 -> return ExitSuccess
- n -> return (ExitFailure n)
-
-translate :: String -> String
--- Returns a string wrapped in double-quotes
--- If the input string starts with double-quote, don't touch it
--- If not, wrap it in double-quotes and double any backslashes
--- foo\baz --> "foo\\baz"
--- "foo\baz" --> "foo\baz"
-
-translate str@('"':_) = str -- already escaped.
-translate str = '"' : foldr escape "\"" str
- where escape '"' str = '\\' : '"' : str
- escape c str = c : str
-
-foreign import ccall "rawSystem" unsafe
- c_rawSystem :: CString -> IO Int
-
-#endif
-#endif
\end{code}
where
rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
-foreign import stdcall "GetModuleFileNameA" unsafe
+foreign import stdcall unsafe "GetModuleFileNameA"
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
getBaseDir :: IO (Maybe String) = do return Nothing
#endif
#ifdef mingw32_HOST_OS
-foreign import ccall "_getpid" unsafe getProcessID :: IO Int -- relies on Int == Int32 on Windows
+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