-- Initialisation
initSysTools,
- setPgmP, -- String -> IO ()
+ setPgmL, -- String -> IO ()
+ setPgmP,
setPgmF,
setPgmc,
setPgmm,
import CmdLineOpts ( dynFlag, verbosity )
import EXCEPTION ( throwDyn )
-#if __GLASGOW_HASKELL__ > 408
-import qualified EXCEPTION as Exception ( catch )
-#else
-import EXCEPTION ( catchAllIO )
-#endif
-
import DATA_IOREF ( IORef, readIORef, writeIORef )
import DATA_INT
import Monad ( when, unless )
import System ( ExitCode(..), exitWith, getEnv, system )
-import IO
+import IO ( try, catch,
+ openFile, hPutChar, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
+ stderr )
import Directory ( doesFileExist, removeFile )
+import List ( intersperse )
#include "../includes/config.h"
#endif
#ifndef mingw32_HOST_OS
-import qualified Posix
+#if __GLASGOW_HASKELL__ > 504
+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 )
import Util ( dropList )
-import MarshalArray
import Foreign
-import Foreign.C.String
+import CString ( CString, peekCString )
#endif
#ifdef mingw32_HOST_OS
#else
import SystemExts ( rawSystem )
#endif
-#else
-import System ( system )
-#endif
--- Make catch work on older GHCs
-#if __GLASGOW_HASKELL__ > 408
-myCatch = Exception.catch
-#else
-myCatch = catchAllIO
-#endif
+#else /* Not Win32 */
+import System ( system )
+#endif
\end{code}
\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
is used to override a particular program with a new one
\begin{code}
-setPgmP = writeIORef v_Pgm_P
+setPgmL = writeIORef v_Pgm_L
+-- 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
("Deleting: " ++ unwords fs)
(mapM_ rm fs)
where
- rm f = removeFile f `myCatch`
+ rm f = removeFile f `IO.catch`
(\_ignored ->
when (verb >= 2) $
hPutStrLn stderr ("Warning: deleting non-existent " ++ 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)
; unless n $ do {
-- And run it!
- ; action `myCatch` 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))
+ ; 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 = 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}