2 % (c) The GRASP/AQUA Project, Glasgow University, 1995-1997
4 \section[PosixProcPrim]{Haskell 1.3 POSIX Process Primitives}
10 module PosixProcPrim (
17 #ifndef cygwin32_TARGET_OS
23 #ifndef cygwin32_TARGET_OS
30 floatingPointException,
36 getGroupProcessStatus,
52 queryStoppedChildFlag,
57 segmentationViolation,
65 #ifndef cygwin32_TARGET_OS
101 import PackedString (psToByteArrayST)
102 import Foreign -- stable pointers
105 import Util ( unvectorize )
107 import System(ExitCode(..))
108 import PosixProcEnv (getProcessID)
110 forkProcess :: IO (Maybe ProcessID)
114 -1 -> syserr "forkProcess"
116 _ -> return (Just pid)
118 executeFile :: FilePath -- Command
119 -> Bool -- Search PATH?
120 -> [String] -- Arguments
121 -> Maybe [(String, String)] -- Environment
123 executeFile path search args Nothing = do
124 prog <- psToByteArrayIO path
125 argv <- vectorize (basename path:args)
127 _casm_ ``execvp(%0,(char **)%1);'' prog argv
129 _casm_ ``execv(%0,(char **)%1);'' prog argv
133 executeFile path search args (Just env) = do
134 prog <- psToByteArrayIO path
135 argv <- vectorize (basename path:args)
136 envp <- vectorize (map (\ (name, val) -> name ++ ('=' : val)) env)
138 _casm_ `` execvpe(%0,(char **)%1,(char **)%2);'' prog argv envp
140 _casm_ `` execve(%0,(char **)%1,(char **)%2);'' prog argv envp
144 data ProcessStatus = Exited ExitCode
147 deriving (Eq, Ord, Show)
149 getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
150 getProcessStatus block stopped pid = do
151 wstat <- allocWords 1
152 pid <-_casm_ ``%r = waitpid(%0, (int *)%1, %2);'' pid wstat
153 (waitOptions block stopped)
155 -1 -> syserr "getProcessStatus"
157 _ -> do ps <- decipherWaitStatus wstat
160 getGroupProcessStatus :: Bool
163 -> IO (Maybe (ProcessID, ProcessStatus))
164 getGroupProcessStatus block stopped pgid = do
165 wstat <- allocWords 1
166 pid <-_casm_ ``%r = waitpid(%0, (int *)%1, %2);'' (-pgid) wstat
167 (waitOptions block stopped)
169 -1 -> syserr "getGroupProcessStatus"
171 _ -> do ps <- decipherWaitStatus wstat
172 return (Just (pid, ps))
174 getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
175 getAnyProcessStatus block stopped =
176 getGroupProcessStatus block stopped 1 `catch`
177 \ err -> syserr "getAnyProcessStatus"
179 exitImmediately :: ExitCode -> IO ()
180 exitImmediately exitcode = do
181 _casm_ ``_exit(%0);'' (exitcode2Int exitcode)
182 syserr "exitImmediately"
184 exitcode2Int ExitSuccess = 0
185 exitcode2Int (ExitFailure n) = n
187 getEnvironment :: IO [(String, String)]
189 --WAS: env <- unvectorize ``environ'' 0
190 -- does not work too well, since the lit-lit
191 -- is turned into an Addr that is only evaluated
192 -- once (environ is changed to point the most
193 -- current env. block after the addition of new entries).
194 envp <- _casm_ `` %r=environ; ''
195 env <- unvectorize (envp::Addr) 0
196 return (map (split "") env)
198 split :: String -> String -> (String, String)
199 split x [] = error ("PosixProcPrim.getEnvironment:no `='? in: "++reverse x)
200 split x ('=' : xs) = (reverse x, xs)
201 split x (c:cs) = split (c:x) cs
203 setEnvironment :: [(String, String)] -> IO ()
204 setEnvironment pairs = do
205 env <- vectorize (map (\ (var,val) -> var ++ ('=' : val)) pairs)
206 nonzero_error (_casm_ ``%r = setenviron((char **)%0);'' env)
209 getEnvVar :: String -> IO String
211 str <- psToByteArrayIO name
212 str <- _ccall_ getenv str
214 then fail (IOError Nothing NoSuchThing
215 "getEnvVar" "no such environment variable")
218 setEnvVar :: String -> String -> IO ()
219 setEnvVar name value = do
220 str <- psToByteArrayIO (name ++ ('=' : value))
221 nonzero_error (_casm_ ``%r = _setenv(%0);'' str) "setEnvVar"
223 removeEnvVar :: String -> IO ()
224 removeEnvVar name = do
225 str <- psToByteArrayIO name
226 nonzero_error (_ccall_ delenv str) "removeEnvVar"
233 backgroundRead, sigTTIN :: Signal
234 backgroundRead = ``SIGTTIN''
235 sigTTIN = ``SIGTTIN''
237 backgroundWrite, sigTTOU :: Signal
238 backgroundWrite = ``SIGTTOU''
239 sigTTOU = ``SIGTTOU''
241 #ifndef cygwin32_TARGET_OS
242 continueProcess, sigCONT :: Signal
243 continueProcess = ``SIGCONT''
244 sigCONT = ``SIGCONT''
247 floatingPointException, sigFPE :: Signal
248 floatingPointException = ``SIGFPE''
251 illegalInstruction, sigILL :: Signal
252 illegalInstruction = ``SIGILL''
255 internalAbort, sigABRT ::Signal
256 internalAbort = ``SIGABRT''
257 sigABRT = ``SIGABRT''
259 keyboardSignal, sigINT :: Signal
260 keyboardSignal = ``SIGINT''
263 keyboardStop, sigTSTP :: Signal
264 keyboardStop = ``SIGTSTP''
265 sigTSTP = ``SIGTSTP''
267 keyboardTermination, sigQUIT :: Signal
268 keyboardTermination = ``SIGQUIT''
269 sigQUIT = ``SIGQUIT''
271 killProcess, sigKILL :: Signal
272 killProcess = ``SIGKILL''
273 sigKILL = ``SIGKILL''
275 lostConnection, sigHUP :: Signal
276 lostConnection = ``SIGHUP''
279 openEndedPipe, sigPIPE :: Signal
280 openEndedPipe = ``SIGPIPE''
281 sigPIPE = ``SIGPIPE''
283 processStatusChanged, sigCHLD :: Signal
284 processStatusChanged = ``SIGCHLD''
285 sigCHLD = ``SIGCHLD''
287 realTimeAlarm, sigALRM :: Signal
288 realTimeAlarm = ``SIGALRM''
289 sigALRM = ``SIGALRM''
291 segmentationViolation, sigSEGV :: Signal
292 segmentationViolation = ``SIGSEGV''
293 sigSEGV = ``SIGSEGV''
295 softwareStop, sigSTOP :: Signal
296 softwareStop = ``SIGSTOP''
297 sigSTOP = ``SIGSTOP''
299 softwareTermination, sigTERM :: Signal
300 softwareTermination = ``SIGTERM''
301 sigTERM = ``SIGTERM''
303 userDefinedSignal1, sigUSR1 :: Signal
304 userDefinedSignal1 = ``SIGUSR1''
305 sigUSR1 = ``SIGUSR1''
307 userDefinedSignal2, sigUSR2 :: Signal
308 userDefinedSignal2 = ``SIGUSR2''
309 sigUSR2 = ``SIGUSR2''
311 signalProcess :: Signal -> ProcessID -> IO ()
312 signalProcess int pid =
313 nonzero_error (_ccall_ kill pid int) "signalProcess"
315 raiseSignal :: Signal -> IO ()
316 raiseSignal int = getProcessID >>= signalProcess int
318 signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
319 signalProcessGroup int pgid = signalProcess int (-pgid)
321 setStoppedChildFlag :: Bool -> IO Bool
322 setStoppedChildFlag b = do
323 rc <- _casm_ ``%r = nocldstop; nocldstop = %0;'' x
326 x = case b of {True -> 0; False -> 1}
328 queryStoppedChildFlag :: IO Bool
329 queryStoppedChildFlag = do
330 rc <- _casm_ ``%r = nocldstop;''
333 data Handler = Default
337 type SignalSet = ByteArray ()
340 sigSetSize = ``sizeof(sigset_t)''
342 emptySignalSet :: SignalSet
343 emptySignalSet = unsafePerformPrimIO $ do
344 bytes <- allocChars sigSetSize
345 _casm_ ``(void) sigemptyset((sigset_t *)%0);'' bytes
348 fullSignalSet :: SignalSet
349 fullSignalSet = unsafePerformPrimIO $ do
350 bytes <- allocChars sigSetSize
351 _casm_ ``(void) sigfillset((sigset_t *)%0);'' bytes
354 addSignal :: Signal -> SignalSet -> SignalSet
355 addSignal int oldset = unsafePerformPrimIO $ do
356 bytes <- allocChars sigSetSize
357 _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1;
358 (void) sigaddset((sigset_t *)%0, %2);''
362 inSignalSet :: Signal -> SignalSet -> Bool
363 inSignalSet int sigset = unsafePerformPrimIO $ do
364 rc <- _casm_ ``%r = sigismember((sigset_t *)%0, %1);'' sigset int
367 deleteSignal :: Signal -> SignalSet -> SignalSet
368 deleteSignal int oldset = unsafePerformPrimIO $ do
369 bytes <- allocChars sigSetSize
370 _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1;
371 (void) sigdelset((sigset_t *)%0, %2);''
375 installHandler :: Signal
377 -> Maybe SignalSet -- other signals to block
378 -> IO Handler -- old handler
380 #ifdef __PARALLEL_HASKELL__
381 installHandler = fail (userError "installHandler: not available for Parallel Haskell")
383 installHandler int handler maybe_mask = (
385 Default -> _ccall_ stg_sig_default int mask
386 Ignore -> _ccall_ stg_sig_ignore int mask
388 sptr <- makeStablePtr (ioToPrimIO m)
389 _ccall_ stg_sig_catch int sptr mask
393 osptr <- _casm_ ``%r = (StgStablePtr) (%0);'' rc
394 m <- deRefStablePtr osptr
396 else if rc == ``STG_SIG_DFL'' then
398 else if rc == ``STG_SIG_IGN'' then
401 syserr "installHandler"
403 mask = case maybe_mask of
404 Nothing -> emptySignalSet
407 #endif {-!__PARALLEL_HASKELL__-}
409 getSignalMask :: IO SignalSet
411 bytes <- allocChars sigSetSize
412 rc <- _casm_ ``%r = sigprocmask(0, NULL, (sigset_t *)%0);'' bytes
415 else syserr "getSignalMask"
417 sigProcMask :: String -> Int -> SignalSet -> IO SignalSet
418 sigProcMask name how sigset = do
419 bytes <- allocChars sigSetSize
420 rc <- _casm_ ``%r = sigprocmask(%0, (sigset_t *)%1, (sigset_t *)%2);''
426 setSignalMask :: SignalSet -> IO SignalSet
427 setSignalMask = sigProcMask "setSignalMask" ``SIG_SETMASK''
429 blockSignals :: SignalSet -> IO SignalSet
430 blockSignals = sigProcMask "blockSignals" ``SIG_BLOCK''
432 unBlockSignals :: SignalSet -> IO SignalSet
433 unBlockSignals = sigProcMask "unBlockSignals" ``SIG_UNBLOCK''
435 getPendingSignals :: IO SignalSet
436 getPendingSignals = do
437 bytes <- allocChars sigSetSize
438 rc <- _casm_ ``%r = sigpending((sigset_t *)%0);'' bytes
441 else syserr "getPendingSignals"
443 #ifndef cygwin32_TARGET_OS
444 awaitSignal :: Maybe SignalSet -> IO ()
445 awaitSignal maybe_sigset = do
448 if err == interruptedOperation
450 else syserr "awaitSignal"
452 pause :: Maybe SignalSet -> IO ()
455 Nothing -> _casm_ ``(void) pause();''
456 Just sigset -> _casm_ ``(void) sigsuspend((sigset_t *)%0);'' sigset
459 scheduleAlarm :: Int -> IO Int
460 scheduleAlarm (I# secs#) =
461 _ccall_ alarm (W# (int2Word# secs#)) >>= \ (W# w#) ->
462 return (I# (word2Int# w#))
464 sleep :: Int -> IO ()
466 sleep (I# secs#) = do
467 _ccall_ sleep (W# (int2Word# secs#))
471 Local utility functions
475 -- Get the trailing component of a path
477 basename :: String -> String
480 | c == '/' = basename cs
481 | otherwise = c : basename cs
483 -- Convert wait options to appropriate set of flags
485 waitOptions :: Bool -> Bool -> Int
487 waitOptions False False = ``WNOHANG''
488 waitOptions False True = ``(WNOHANG|WUNTRACED)''
489 waitOptions True False = 0
490 waitOptions True True = ``WUNTRACED''
492 -- Turn a (ptr to a) wait status into a ProcessStatus
494 decipherWaitStatus :: MutableByteArray s x -> IO ProcessStatus
495 decipherWaitStatus wstat = do
496 exited <- _casm_ ``%r = WIFEXITED(*(int *)%0);'' wstat
499 exitstatus <- _casm_ ``%r = WEXITSTATUS(*(int *)%0);'' wstat
501 then return (Exited ExitSuccess)
502 else return (Exited (ExitFailure exitstatus))
504 signalled <- _casm_ ``%r = WIFSIGNALED(*(int *)%0);'' wstat
507 termsig <- _casm_ ``%r = WTERMSIG(*(int *)%0);'' wstat
508 return (Terminated termsig)
510 stopsig <-_casm_ ``%r = WSTOPSIG(*(int *)%0);'' wstat
511 return (Stopped stopsig)