2 % (c) The GRASP/AQUA Project, Glasgow University, 1995
4 \section[LibPosixProcPrim]{Haskell 1.3 POSIX Process Primitives}
7 module LibPosixProcPrim (
23 floatingPointException,
29 getGroupProcessStatus,
45 queryStoppedChildFlag,
50 segmentationViolation,
97 import LibSystem(ExitCode(..))
98 import LibPosixProcEnv (getProcessID)
100 forkProcess :: IO (Maybe ProcessID)
102 _ccall_ fork `thenPrimIO` \ pid ->
104 -1 -> syserr "forkProcess"
106 _ -> return (Just pid)
108 executeFile :: FilePath -- Command
109 -> Bool -- Search PATH?
110 -> [String] -- Arguments
111 -> Maybe [(String, String)] -- Environment
113 executeFile path search args Nothing =
114 _packBytesForCST path `thenStrictlyST` \ prog ->
115 vectorize (basename path:args) `thenPrimIO` \ argv ->
117 _casm_ ``%r = execvp(%0,(char **)%1);'' prog argv
119 _casm_ ``%r = execv(%0,(char **)%1);'' prog argv
120 ) `thenPrimIO` \ rc ->
123 executeFile path search args (Just env) =
124 _packBytesForCST path `thenStrictlyST` \ prog ->
125 vectorize (basename path:args) `thenPrimIO` \ argv ->
126 vectorize (map (\ (name, val) -> name ++ ('=' : val)) env)
127 `thenPrimIO` \ envp ->
129 _casm_ ``%r = execvpe(%0,(char **)%1,(char **)%2);'' prog argv envp
131 _casm_ ``%r = execve(%0,(char **)%1,(char **)%2);'' prog argv envp
132 ) `thenPrimIO` \ rc ->
135 data ProcessStatus = Exited ExitCode
138 {- mattson -} deriving (Eq, Ord, Text)
140 getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
141 getProcessStatus block stopped pid =
142 allocWords 1 `thenPrimIO` \ wstat ->
143 _casm_ ``%r = waitpid(%0, (int *)%1, %2);'' pid wstat (waitOptions block stopped)
144 `thenPrimIO` \ pid ->
146 -1 -> syserr "getProcessStatus"
148 _ -> decipherWaitStatus wstat `thenPrimIO` \ ps ->
151 getGroupProcessStatus :: Bool
154 -> IO (Maybe (ProcessID, ProcessStatus))
155 getGroupProcessStatus block stopped pgid =
156 allocWords 1 `thenPrimIO` \ wstat ->
157 _casm_ ``%r = waitpid(%0, (int *)%1, %2);'' (-pgid) wstat (waitOptions block stopped)
158 `thenPrimIO` \ pid ->
160 -1 -> syserr "getGroupProcessStatus"
162 _ -> decipherWaitStatus wstat `thenPrimIO` \ ps ->
163 return (Just (pid, ps))
165 getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
166 getAnyProcessStatus block stopped =
167 getGroupProcessStatus block stopped 1 `handle`
168 \ err -> syserr "getAnyProcessStatus"
170 exitImmediately :: ExitCode -> IO ()
171 exitImmediately exitcode =
172 _ccall_ _exit (exitcode2Int exitcode) `thenPrimIO` \ () ->
173 syserr "exitImmediately"
175 exitcode2Int ExitSuccess = 0
176 exitcode2Int (ExitFailure n) = n
178 getEnvironment :: IO [(String, String)]
180 unvectorize ``environ'' 0 `thenPrimIO` \ env ->
181 return (map (split "") env)
183 split :: String -> String -> (String, String)
184 split x ('=' : xs) = (reverse x, xs)
185 split x (c:cs) = split (c:x) cs
187 setEnvironment :: [(String, String)] -> IO ()
188 setEnvironment pairs =
189 vectorize (map (\ (var,val) -> var ++ ('=' : val)) pairs)
190 `thenPrimIO` \ env ->
191 _casm_ ``%r = setenviron((char **)%0);'' env `thenPrimIO` \ rc ->
195 syserr "setEnvironment"
197 getEnvVar :: String -> IO String
199 _packBytesForCST name `thenStrictlyST` \ str ->
200 _ccall_ getenv str `thenPrimIO` \ str ->
201 if str == ``NULL'' then
202 failWith (NoSuchThing "no such environment variable")
204 strcpy str `thenPrimIO` \ env ->
207 setEnvVar :: String -> String -> IO ()
208 setEnvVar name value =
209 _packBytesForCST (name ++ ('=' : value)) `thenStrictlyST` \ str ->
210 _ccall_ setenv str `thenPrimIO` \ rc ->
216 removeEnvVar :: String -> IO ()
218 _packBytesForCST name `thenStrictlyST` \ str ->
219 _ccall_ delenv str `thenPrimIO` \ rc ->
223 syserr "removeEnvVar"
230 backgroundRead, sigTTIN :: Signal
231 backgroundRead = ``SIGTTIN''
232 sigTTIN = ``SIGTTIN''
234 backgroundWrite, sigTTOU :: Signal
235 backgroundWrite = ``SIGTTOU''
236 sigTTOU = ``SIGTTOU''
238 continueProcess, sigCONT :: Signal
239 continueProcess = ``SIGCONT''
240 sigCONT = ``SIGCONT''
242 floatingPointException, sigFPE :: Signal
243 floatingPointException = ``SIGFPE''
246 illegalInstruction, sigILL :: Signal
247 illegalInstruction = ``SIGILL''
250 internalAbort, sigABRT ::Signal
251 internalAbort = ``SIGABRT''
252 sigABRT = ``SIGABRT''
254 keyboardSignal, sigINT :: Signal
255 keyboardSignal = ``SIGINT''
258 keyboardStop, sigTSTP :: Signal
259 keyboardStop = ``SIGTSTP''
260 sigTSTP = ``SIGTSTP''
262 keyboardTermination, sigQUIT :: Signal
263 keyboardTermination = ``SIGQUIT''
264 sigQUIT = ``SIGQUIT''
266 killProcess, sigKILL :: Signal
267 killProcess = ``SIGKILL''
268 sigKILL = ``SIGKILL''
270 lostConnection, sigHUP :: Signal
271 lostConnection = ``SIGHUP''
274 openEndedPipe, sigPIPE :: Signal
275 openEndedPipe = ``SIGPIPE''
276 sigPIPE = ``SIGPIPE''
278 processStatusChanged, sigCHLD :: Signal
279 processStatusChanged = ``SIGCHLD''
280 sigCHLD = ``SIGCHLD''
282 realTimeAlarm, sigALRM :: Signal
283 realTimeAlarm = ``SIGALRM''
284 sigALRM = ``SIGALRM''
286 segmentationViolation, sigSEGV :: Signal
287 segmentationViolation = ``SIGSEGV''
288 sigSEGV = ``SIGSEGV''
290 softwareStop, sigSTOP :: Signal
291 softwareStop = ``SIGSTOP''
292 sigSTOP = ``SIGSTOP''
294 softwareTermination, sigTERM :: Signal
295 softwareTermination = ``SIGTERM''
296 sigTERM = ``SIGTERM''
298 userDefinedSignal1, sigUSR1 :: Signal
299 userDefinedSignal1 = ``SIGUSR1''
300 sigUSR1 = ``SIGUSR1''
302 userDefinedSignal2, sigUSR2 :: Signal
303 userDefinedSignal2 = ``SIGUSR2''
304 sigUSR2 = ``SIGUSR2''
306 signalProcess :: Signal -> ProcessID -> IO ()
307 signalProcess int pid =
308 _ccall_ kill pid int `thenPrimIO` \ rc ->
312 syserr "signalProcess"
314 raiseSignal :: Signal -> IO ()
315 raiseSignal int = getProcessID >>= signalProcess int
317 signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
318 signalProcessGroup int pgid = signalProcess int (-pgid)
320 setStoppedChildFlag :: Bool -> IO Bool
321 setStoppedChildFlag b =
322 _casm_ ``%r = nocldstop; nocldstop = %0;'' x `thenPrimIO` \ rc ->
325 x = case b of {True -> 0; False -> 1}
327 queryStoppedChildFlag :: IO Bool
328 queryStoppedChildFlag =
329 _casm_ ``%r = nocldstop;'' `thenPrimIO` \ rc ->
332 data Handler = Default
336 type SignalSet = _ByteArray ()
339 sigSetSize = ``sizeof(sigset_t)''
341 emptySignalSet :: SignalSet
342 emptySignalSet = unsafePerformPrimIO (
343 allocChars sigSetSize `thenStrictlyST` \ bytes ->
344 _casm_ ``(void) sigemptyset((sigset_t *)%0);'' bytes
346 freeze bytes `thenStrictlyST` \ sigset ->
350 fullSignalSet :: SignalSet
351 fullSignalSet = unsafePerformPrimIO (
352 allocChars sigSetSize `thenStrictlyST` \ bytes ->
353 _casm_ ``(void) sigfillset((sigset_t *)%0);'' bytes
355 freeze bytes `thenStrictlyST` \ sigset ->
359 addSignal :: Signal -> SignalSet -> SignalSet
360 addSignal int oldset = unsafePerformPrimIO (
361 allocChars sigSetSize `thenStrictlyST` \ bytes ->
362 _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1; (void) sigaddset((sigset_t *)%0, %2);''
363 bytes oldset int `thenPrimIO` \ () ->
364 freeze bytes `thenStrictlyST` \ newset ->
368 inSignalSet :: Signal -> SignalSet -> Bool
369 inSignalSet int sigset = unsafePerformPrimIO (
370 _casm_ ``%r = sigismember((sigset_t *)%0, %1);'' sigset int
378 deleteSignal :: Signal -> SignalSet -> SignalSet
379 deleteSignal int oldset = unsafePerformPrimIO (
380 allocChars sigSetSize `thenStrictlyST` \ bytes ->
381 _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1; (void) sigdelset((sigset_t *)%0, %2);''
382 bytes oldset int `thenPrimIO` \ () ->
383 freeze bytes `thenStrictlyST` \ newset ->
387 installHandler :: Signal
389 -> Maybe SignalSet -- other signals to block
390 -> IO Handler -- old handler
392 #ifdef __PARALLEL_HASKELL__
393 installHandler = error "installHandler: not available for Parallel Haskell"
395 installHandler int handler maybe_mask = (
397 Default -> _ccall_ stg_sig_ignore int mask
398 Ignore -> _ccall_ stg_sig_default int mask
400 makeStablePtr (wrap m) `thenPrimIO` \ sptr ->
401 _ccall_ stg_sig_catch int sptr mask
405 _casm_ ``%r = (StgStablePtr) (%0);'' rc `thenPrimIO` \ osptr ->
406 deRefStablePtr osptr `thenPrimIO` \ m ->
408 else if rc == ``STG_SIG_DFL'' then
410 else if rc == ``STG_SIG_IGN'' then
413 syserr "installHandler"
415 mask = case maybe_mask of
416 Nothing -> emptySignalSet
418 wrap :: IO () -> PrimIO ()
421 (result, s2@(S# _)) ->
423 Right () -> ( (), s2 )
424 Left err -> error ("I/O error: "++shows err "\n")
426 #endif {-!__PARALLEL_HASKELL__-}
428 getSignalMask :: IO SignalSet
430 allocChars sigSetSize `thenStrictlyST` \ bytes ->
431 _casm_ ``%r = sigprocmask(0, NULL, (sigset_t *)%0);'' bytes
434 freeze bytes `thenStrictlyST` \ sigset ->
437 syserr "getSignalMask"
439 sigProcMask :: String -> Int -> SignalSet -> IO SignalSet
440 sigProcMask name how sigset =
441 allocChars sigSetSize `thenStrictlyST` \ bytes ->
442 _casm_ ``%r = sigprocmask(%0, (sigset_t *)%1, (sigset_t *)%2);'' how sigset bytes
445 freeze bytes `thenStrictlyST` \ oldset ->
450 setSignalMask :: SignalSet -> IO SignalSet
451 setSignalMask = sigProcMask "setSignalMask" ``SIG_SETMASK''
453 blockSignals :: SignalSet -> IO SignalSet
454 blockSignals = sigProcMask "blockSignals" ``SIG_BLOCK''
456 unBlockSignals :: SignalSet -> IO SignalSet
457 unBlockSignals = sigProcMask "unBlockSignals" ``SIG_UNBLOCK''
459 getPendingSignals :: IO SignalSet
461 allocChars sigSetSize `thenStrictlyST` \ bytes ->
462 _casm_ ``%r = sigpending((sigset_t *)%0);'' bytes
465 freeze bytes `thenStrictlyST` \ sigset ->
468 syserr "getPendingSignals"
470 awaitSignal :: Maybe SignalSet -> IO ()
471 awaitSignal maybe_sigset =
472 pause `thenPrimIO` \ () ->
473 getErrorCode >>= \ err ->
474 if err == interruptedOperation then
482 Nothing -> _casm_ ``(void) pause();''
483 Just sigset -> _casm_ ``(void) sigsuspend((sigset_t *)%0);'' sigset
485 scheduleAlarm :: Int -> IO Int
486 scheduleAlarm (I# secs#) =
487 _ccall_ alarm (W# (int2Word# secs#)) `thenPrimIO` \ (W# w#) ->
488 return (I# (word2Int# w#))
490 sleep :: Int -> IO ()
493 _ccall_ sleep (W# (int2Word# secs#)) `seqPrimIO`
498 Local utility functions
502 -- Get the trailing component of a path
504 basename :: String -> String
507 | c == '/' = basename cs
508 | otherwise = c : basename cs
510 -- Convert wait options to appropriate set of flags
512 waitOptions :: Bool -> Bool -> Int
514 waitOptions False False = ``WNOHANG''
515 waitOptions False True = ``(WNOHANG|WUNTRACED)''
516 waitOptions True False = 0
517 waitOptions True True = ``WUNTRACED''
519 -- Turn a (ptr to a) wait status into a ProcessStatus
521 decipherWaitStatus :: _MutableByteArray s x -> PrimIO ProcessStatus
522 decipherWaitStatus wstat =
523 _casm_ ``%r = WIFEXITED(*(int *)%0);'' wstat `thenPrimIO` \ exited ->
525 _casm_ ``%r = WEXITSTATUS(*(int *)%0);'' wstat
526 `thenPrimIO` \ exitstatus ->
527 if exitstatus == 0 then
528 returnPrimIO (Exited ExitSuccess)
530 returnPrimIO (Exited (ExitFailure exitstatus))
532 _casm_ ``%r = WIFSIGNALED(*(int *)%0);'' wstat
533 `thenPrimIO` \ signalled ->
534 if signalled /= 0 then
535 _casm_ ``%r = WTERMSIG(*(int *)%0);'' wstat
536 `thenPrimIO` \ termsig ->
537 returnPrimIO (Terminated termsig)
539 _casm_ ``%r = WSTOPSIG(*(int *)%0);'' wstat
540 `thenPrimIO` \ stopsig ->
541 returnPrimIO (Stopped stopsig)