openFile, hPutChar, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
stderr )
import Directory ( doesFileExist, removeFile )
+import List ( intersperse )
#include "../includes/config.h"
#ifndef mingw32_HOST_OS
#if __GLASGOW_HASKELL__ > 504
-import qualified GHC.Posix
+import qualified System.Posix.Internals
+import System.Posix.Process ( executeFile, getProcessStatus, forkProcess, ProcessStatus(..))
+import System.Posix.Signals ( installHandler, sigCHLD, sigCONT, Handler(..) )
#else
import qualified Posix
+import Posix ( executeFile, getProcessStatus, forkProcess, ProcessStatus(..), installHandler,
+ sigCHLD, sigCONT, Handler(..) )
#endif
#else /* Must be Win32 */
import List ( isPrefixOf )
#if __GLASGOW_HASKELL__ > 504
import System.Cmd ( rawSystem )
#else
-
- -- For Win32 and GHC <= 504
- -- rawSystem is defined in this module
- -- We just need an import
-#if __GLASGOW_HASKELL__ < 503
-import PrelIOBase( ioException, IOException(..), IOErrorType(InvalidArgument) )
-#else
-import GHC.IOBase( ioException, IOException(..), IOErrorType(InvalidArgument) )
-#endif
-import CError ( throwErrnoIfMinus1 )
-import CString ( withCString )
+import SystemExts ( rawSystem )
#endif
#else /* Not Win32 */
\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_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
#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_path, (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
\begin{code}
setPgmL = writeIORef v_Pgm_L
-setPgmP = writeIORef v_Pgm_P
+-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
+-- 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
showOptions :: [Option] -> String
showOptions ls = unwords (map (quote.showOpt) ls)
- where
- showOpt (FileOption pre f) = pre ++ dosifyPath f
- showOpt (Option s) = s
+
+showOpt (FileOption pre f) = pre ++ dosifyPath f
+showOpt (Option "") = ""
+showOpt (Option s) = s
\end{code}
runSomething "Literate pre-processor" p args
runCpp :: [Option] -> IO ()
-runCpp args = do p <- readIORef v_Pgm_P
- runSomething "C pre-processor" p args
+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
-> IO ()
runSomething phase_name pgm args
- = traceCmd phase_name cmd_line $
- do {
+ = traceCmd phase_name (concat (intersperse " " (pgm:quoteargs))) $
+ do
#ifndef mingw32_HOST_OS
- exit_code <- system cmd_line
+ mpid <- forkProcess
+ exit_code <- case mpid of
+ Nothing -> do -- Child
+ executeFile pgm True quoteargs Nothing
+ exitWith (ExitFailure 127)
+ -- NOT REACHED
+ return ExitSuccess
+ Just child -> do -- Parent
+#if __GLASGOW_HASKELL__ <= 504
+ -- avoid interaction with broken getProcessStatus-FFI:
+ oldHandler <- installHandler sigCONT Ignore Nothing
+#endif
+ Just (Exited res) <- getProcessStatus True False child
+#if __GLASGOW_HASKELL__ <= 504
+ -- restore handler
+ installHandler sigCONT oldHandler Nothing
+#endif
+
+ return res
#else
exit_code <- rawSystem cmd_line
#endif
- ; if exit_code /= ExitSuccess
- then throwDyn (PhaseFailed phase_name exit_code)
- else return ()
- }
+ when (exit_code /= ExitSuccess)
+ $ throwDyn (PhaseFailed phase_name exit_code)
+ return ()
where
-- The pgm is already in native format (appropriate dir separators)
- cmd_line = pgm ++ ' ':showOptions args
+ cmd_line = pgm ++ ' ':showOptions args
-- unwords (pgm : dosifyPaths (map quote args))
+ quoteargs = filter (not.null) (map showOpt args)
traceCmd :: String -> String -> IO () -> IO ()
-- a) trace the command (at two levels of verbosity)
}}
where
handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
- ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
+ ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}
return (Just (reverse (dropList "/bin/ghc.exe" (reverse (unDosifyPath s)))))
-foreign import stdcall "GetModuleFileNameA" unsafe
+foreign import stdcall "GetModuleFileNameA" unsafe
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
getExecDir :: IO (Maybe String) = do return Nothing
#endif
#ifdef mingw32_HOST_OS
-foreign import "_getpid" unsafe getProcessID :: IO Int -- relies on Int == Int32 on Windows
+foreign import ccall "_getpid" unsafe getProcessID :: IO Int -- relies on Int == Int32 on Windows
#elif __GLASGOW_HASKELL__ > 504
getProcessID :: IO Int
-getProcessID = GHC.Posix.c_getpid >>= return . fromIntegral
+getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
#else
getProcessID :: IO Int
getProcessID = Posix.getProcessID
#endif
quote :: String -> String
-#if defined(mingw32_HOST_OS)
quote "" = ""
quote s = "\"" ++ s ++ "\""
-#else
-quote s = s
-#endif
-
-\end{code}
-
-This next blob is in System.Cmd after 5.04, but until then it needs
-to be here (for Win32 only).
-
-\begin{code}
-#if defined(mingw32_HOST_OS)
-#if __GLASGOW_HASKELL__ <= 504
-
-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
-
-#endif
-#endif
\end{code}