-----------------------------------------------------------------------------
--
--- (c) The University of Glasgow 2001
+-- (c) The University of Glasgow 2001-2003
--
-- Access to system tools: gcc, cp, rm etc
--
setPgms,
setPgma,
setPgml,
+ setPgmDLL,
#ifdef ILX
setPgmI,
setPgmi,
getTopDir, -- IO String -- The value of $libdir
getPackageConfigPath, -- IO String -- Where package.conf is
+ getUsageMsgPaths, -- IO (String,String)
-- Interface to system tools
runUnlit, runCpp, runCc, -- [Option] -> IO ()
-- 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(..)
#include "HsVersions.h"
import DriverUtil
+import DriverPhases ( isHaskellUserSrcFilename )
import Config
import Outputable
-import Panic ( progName, GhcException(..) )
-import Util ( global, notNull )
+import Panic ( GhcException(..) )
+import Util ( global, notNull, toArgs )
import CmdLineOpts ( dynFlag, verbosity )
import EXCEPTION ( throwDyn )
import DATA_INT
import Monad ( when, unless )
-import System ( ExitCode(..), exitWith, getEnv, system )
+import System ( ExitCode(..), getEnv, system )
import IO ( try, catch,
- openFile, hPutChar, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
+ openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
stderr )
import Directory ( doesFileExist, removeFile )
-import List ( intersperse )
+import List ( partition )
#include "../includes/config.h"
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>
| am_installed = installed "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
-- 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 and *does* have a trailing backslash.
+ -- form.
; IO.try (do
let len = (2048::Int)
buf <- mallocArray len
ret <- getTempPath len buf
tdir <-
if ret == 0 then do
- -- failed, consult TEMP.
+ -- failed, consult TMPDIR.
free buf
- getEnv "TMP"
+ getEnv "TMPDIR"
else do
s <- peekCString buf
free buf
return s
- let
- -- strip the trailing backslash (awful, but
- -- we only do this once).
- tmpdir =
- case last tdir of
- '/' -> init tdir
- '\\' -> init tdir
- _ -> tdir
- setTmpDir tmpdir
- return ())
+ setTmpDir tdir)
#endif
-- Check that the package config exists
-- 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
setPgms = writeIORef v_Pgm_s
setPgma = writeIORef v_Pgm_a
setPgml = writeIORef v_Pgm_l
+setPgmDLL = writeIORef v_Pgm_MkDLL
#ifdef ILX
setPgmI = writeIORef v_Pgm_I
setPgmi = writeIORef v_Pgm_i
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}
\end{code}
\begin{code}
-setTmpDir dir = writeIORef v_TmpDir dir
+setTmpDir dir = writeIORef v_TmpDir (canonicalise dir)
+ where
+#if !defined(mingw32_HOST_OS)
+ canonicalise p = normalisePath p
+#else
+ -- Canonicalisation of temp path under win32 is a bit more
+ -- involved: (a) strip trailing slash,
+ -- (b) normalise slashes
+ -- (c) just in case, if there is a prefix /cygdrive/x/, change to x:
+ --
+ canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
+
+ -- if we're operating under cygwin, and TMP/TEMP is of
+ -- the form "/cygdrive/drive/path", translate this to
+ -- "drive:/path" (as GHC isn't a cygwin app and doesn't
+ -- understand /cygdrive paths.)
+ xltCygdrive path
+ | "/cygdrive/" `isPrefixOf` path =
+ case drop (length "/cygdrive/") path of
+ drive:xs@('/':_) -> drive:':':xs
+ _ -> path
+ | otherwise = path
+
+ -- strip the trailing backslash (awful, but we only do this once).
+ removeTrailingSlash path =
+ case last path of
+ '/' -> init path
+ '\\' -> init path
+ _ -> path
+#endif
cleanTempFiles :: Int -> IO ()
-cleanTempFiles verb = do fs <- readIORef v_FilesToClean
- removeTmpFiles verb fs
+cleanTempFiles verb
+ = do fs <- readIORef v_FilesToClean
+ removeTmpFiles verb 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
+ = do files <- readIORef v_FilesToClean
+ let (to_keep, to_delete) = partition (`elem` dont_delete) files
+ removeTmpFiles verb to_delete
+ writeIORef v_FilesToClean to_keep
-- find a temporary name that doesn't already exist.
removeTmpFiles :: Int -> [FilePath] -> IO ()
removeTmpFiles verb fs
- = traceCmd "Deleting temp files"
- ("Deleting: " ++ unwords fs)
- (mapM_ rm fs)
+ = warnNon $
+ traceCmd "Deleting temp files"
+ ("Deleting: " ++ unwords deletees)
+ (mapM_ rm deletees)
where
+ -- 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
+ hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
+ act
+
+ (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
+
rm f = removeFile f `IO.catch`
(\_ignored ->
when (verb >= 2) $
runSomething phase_name pgm args = do
let real_args = filter notNull (map showOpt args)
- traceCmd phase_name (concat (intersperse " " (pgm:real_args))) $ do
- exit_code <- rawSystem pgm real_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 ()
-- -----------------------------------------------------------------------------
-- 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 __GLASGOW_HASKELL__ < 601
+-- 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!
--- This code is copied from System.Cmd on GHC 6.1.
+
+#if __GLASGOW_HASKELL__ < 621
rawSystem :: FilePath -> [String] -> IO ExitCode
0 -> return ExitSuccess
n -> return (ExitFailure n)
-foreign import ccall unsafe "rawSystem"
+foreign import ccall "rawSystem" unsafe
c_rawSystem :: CString -> Ptr CString -> IO Int
#else
-- a single string. Command-line parsing is done by the executable
-- itself.
rawSystem cmd args = do
- let cmdline = {-translate-} cmd ++ concat (map ((' ':) . translate) args)
- -- Urk, don't quote/escape the command name on Windows, because the
- -- compiler is exceedingly naughty and sometimes uses 'perl "..."'
- -- as the command name.
+ -- 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
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 '\\' str = '\\' : '\\' : str
escape c str = c : str
-foreign import ccall unsafe "rawSystem"
+foreign import ccall "rawSystem" unsafe
c_rawSystem :: CString -> IO Int
#endif
-----------------------------------------------------------------------------
-- Convert filepath into platform / MSDOS form.
--- platformPath does two things
--- a) change '/' to '\'
--- b) remove initial '/cygdrive/'
-
normalisePath :: String -> String
--- Just change '\' to '/'
+-- Just changes '\' to '/'
pgmPath :: String -- Directory string in Unix format
-> String -- Program name with no directory separators
\begin{code}
slash :: String -> String -> String
-absPath, relPath :: [String] -> String
-
-relPath [] = ""
-relPath xs = foldr1 slash xs
-
-absPath xs = "" `slash` relPath xs
-
slash s1 s2 = s1 ++ ('/' : s2)
\end{code}
projects / ghc-hetmet.git / blobdiff