-----------------------------------------------------------------------------
--- $Id: SysTools.lhs,v 1.48 2001/08/13 15:49:38 simonmar Exp $
--
-- (c) The University of Glasgow 2001
--
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 ()
#else
import List ( isPrefixOf )
import MarshalArray
-import SystemExts ( rawSystem )
+#endif
+
+-- This is a kludge for bootstrapping with 4.08.X. Given that
+-- all distributed compilers >= 5.0 will be compiled with themselves.
+-- I don't think this kludge is a problem. And we have to start
+-- building with >= 5.0 on Win32 anyway.
+#if __GLASGOW_HASKELL__ > 408
+-- 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 )
+#else
+import System ( system )
#endif
#include "HsVersions.h"
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
-- 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
setTmpDir dir
return ()
)
+#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 and *does* have a trailing backslash.
+ ; IO.try (do
+ let len = (2048::Int)
+ buf <- mallocArray len
+ ret <- getTempPath len buf
+ tdir <-
+ if ret == 0 then do
+ -- failed, consult TEMP.
+ destructArray len buf
+ getEnv "TMP"
+ else do
+ s <- peekCString buf
+ destructArray len 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 ())
#endif
-- Check that the package config exists
; let as_path = gcc_path
ld_path = gcc_path
+#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_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
; return ()
}
+
+#if defined(mingw32_TARGET_OS)
+foreign import stdcall "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
+#endif
\end{code}
setPgm is called when a command-line option like
-pgmLld
-is used to override a particular program with a new onw
+is used to override a particular program with a new one
\begin{code}
setPgm :: String -> IO ()
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
+#endif
setPgm pgm = unknownFlagErr ("-pgm" ++ pgm)
\end{code}
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
+ = FileOption -- an entry that _contains_ filename(s) / filepaths.
+ String -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
+ String -- the filepath/filename portion
| Option String
showOptions :: [Option] -> String
showOptions ls = unwords (map (quote.showOpt) ls)
where
- showOpt (FileOption f) = dosifyPath f
+ showOpt (FileOption pre f) = pre ++ dosifyPath f
showOpt (Option s) = s
#if defined(mingw32_TARGET_OS)
runLink args = do p <- readIORef v_Pgm_l
runSomething "Linker" p 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
+#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]
+ runSomething purpose p [FileOption "" arg]
copy :: String -> String -> String -> IO ()
copy purpose from to = do
slash :: String -> String -> String
absPath, relPath :: [String] -> String
-isSlash '/' = True
-isSlash other = False
-
relPath [] = ""
relPath xs = foldr1 slash xs
#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)
+getExecDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
+ buf <- mallocArray len
ret <- getModuleFileName nullAddr buf len
- if ret == 0 then return Nothing
+ if ret == 0 then destructArray len buf >> return Nothing
else do s <- peekCString buf
- destructArray (fromIntegral len) buf
+ destructArray len buf
return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
-foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
+foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int -> IO Int32
#else
getExecDir :: IO (Maybe String) = do return Nothing
#endif
getProcessID :: IO Int
getProcessID = Posix.getProcessID
#endif
+
+rawSystem :: String -> IO ExitCode
+#if __GLASGOW_HASKELL__ > 408
+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
+#else
+rawSystem = System.system
+#endif
+
+
\end{code}
projects / ghc-hetmet.git / blobdiff