ghc/lib/haskell-1.3/LibPosixProcPrim.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995
   3 %
   4 \section[LibPosixProcPrim]{Haskell 1.3 POSIX Process Primitives}
   5
   6 \begin{code}
   7 module LibPosixProcPrim (
   8     Handler(..),
   9     SignalSet(..),
  10     Signal(..),
  11     ProcessStatus(..),
  12
  13     addSignal,
  14     awaitSignal,
  15     backgroundRead,
  16     backgroundWrite,
  17     blockSignals,
  18     continueProcess,
  19     deleteSignal,
  20     emptySignalSet,
  21     executeFile,
  22     exitImmediately,
  23     floatingPointException,
  24     forkProcess,
  25     fullSignalSet,
  26     getAnyProcessStatus,
  27     getEnvVar,
  28     getEnvironment,
  29     getGroupProcessStatus,
  30     getPendingSignals,
  31     getProcessStatus,
  32     getSignalMask,
  33     illegalInstruction,
  34     inSignalSet,
  35     installHandler,
  36     internalAbort,
  37     keyboardSignal,
  38     keyboardStop,
  39     keyboardTermination,
  40     killProcess,
  41     lostConnection,
  42     nullSignal,
  43     openEndedPipe,
  44     processStatusChanged,
  45     queryStoppedChildFlag,
  46     raiseSignal,
  47     realTimeAlarm,
  48     removeEnvVar,
  49     scheduleAlarm,
  50     segmentationViolation,
  51     setEnvVar,
  52     setEnvironment,
  53     setSignalMask,
  54     setStoppedChildFlag,
  55     sigABRT,
  56     sigALRM,
  57     sigCHLD,
  58     sigCONT,
  59     sigFPE,
  60     sigHUP,
  61     sigILL,
  62     sigINT,
  63     sigKILL,
  64     sigPIPE,
  65     sigProcMask,
  66     sigQUIT,
  67     sigSEGV,
  68     sigSTOP,
  69     sigSetSize,
  70     sigTERM,
  71     sigTSTP,
  72     sigTTIN,
  73     sigTTOU,
  74     sigUSR1,
  75     sigUSR2,
  76     signalProcess,
  77     signalProcessGroup,
  78     sleep,
  79     softwareStop,
  80     softwareTermination,
  81     unBlockSignals,
  82     userDefinedSignal1,
  83     userDefinedSignal2,
  84
  85     ExitCode
  86
  87     ) where
  88
  89 import PreludeGlaMisc
  90 import PreludeGlaST
  91 import PreludeStdIO
  92 import PS
  93
  94 import LibPosixErr
  95 import LibPosixUtil
  96
  97 import LibSystem(ExitCode(..))
  98 import LibPosixProcEnv (getProcessID)
  99
 100 forkProcess :: IO (Maybe ProcessID)
 101 forkProcess =
 102     _ccall_ fork                                    `thenPrimIO` \ pid ->
 103     case pid of
 104       -1 -> syserr "forkProcess"
 105       0  -> return Nothing
 106       _  -> return (Just pid)
 107
 108 executeFile :: FilePath                     -- Command
 109             -> Bool                         -- Search PATH?
 110             -> [String]                     -- Arguments
 111             -> Maybe [(String, String)]     -- Environment
 112             -> IO ()
 113 executeFile path search args Nothing =
 114     _packBytesForCST path                           `thenStrictlyST` \ prog ->
 115     vectorize (basename path:args)                  `thenPrimIO` \ argv ->
 116     (if search then
 117         _casm_ ``%r = execvp(%0,(char **)%1);'' prog argv
 118     else
 119         _casm_ ``%r = execv(%0,(char **)%1);'' prog argv
 120     )                                               `thenPrimIO` \ rc ->
 121     syserr "executeFile"
 122
 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 ->
 128     (if search then
 129         _casm_ ``%r = execvpe(%0,(char **)%1,(char **)%2);'' prog argv envp
 130     else
 131         _casm_ ``%r = execve(%0,(char **)%1,(char **)%2);'' prog argv envp
 132     )                                               `thenPrimIO` \ rc ->
 133     syserr "executeFile"
 134
 135 data ProcessStatus = Exited ExitCode
 136                    | Terminated Signal
 137                    | Stopped Signal
 138 {- mattson -}      deriving (Eq, Ord, Text)
 139
 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 ->
 145     case pid of
 146       -1 -> syserr "getProcessStatus"
 147       0  -> return Nothing
 148       _  -> decipherWaitStatus wstat                `thenPrimIO` \ ps ->
 149             return (Just ps)
 150
 151 getGroupProcessStatus :: Bool
 152                       -> Bool
 153                       -> ProcessGroupID
 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 ->
 159     case pid of
 160       -1 -> syserr "getGroupProcessStatus"
 161       0  -> return Nothing
 162       _  -> decipherWaitStatus wstat                `thenPrimIO` \ ps ->
 163             return (Just (pid, ps))
 164
 165 getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
 166 getAnyProcessStatus block stopped =
 167     getGroupProcessStatus block stopped 1           `handle`
 168     \ err -> syserr "getAnyProcessStatus"
 169
 170 exitImmediately :: ExitCode -> IO ()
 171 exitImmediately exitcode =
 172     _ccall_ _exit (exitcode2Int exitcode)           `thenPrimIO` \ () ->
 173     syserr "exitImmediately"
 174   where
 175     exitcode2Int ExitSuccess = 0
 176     exitcode2Int (ExitFailure n) = n
 177
 178 getEnvironment :: IO [(String, String)]
 179 getEnvironment =
 180     unvectorize ``environ'' 0                       `thenPrimIO` \ env ->
 181     return (map (split "") env)
 182   where
 183     split :: String -> String -> (String, String)
 184     split x ('=' : xs) = (reverse x, xs)
 185     split x (c:cs) = split (c:x) cs
 186
 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 ->
 192     if rc == 0 then
 193         return ()
 194     else
 195         syserr "setEnvironment"
 196
 197 getEnvVar :: String -> IO String
 198 getEnvVar name =
 199     _packBytesForCST name                           `thenStrictlyST` \ str ->
 200     _ccall_ getenv str                              `thenPrimIO` \ str ->
 201     if str == ``NULL'' then
 202         failWith (NoSuchThing "no such environment variable")
 203     else
 204         strcpy str                                  `thenPrimIO` \ env ->
 205         return env
 206
 207 setEnvVar :: String -> String -> IO ()
 208 setEnvVar name value =
 209     _packBytesForCST (name ++ ('=' : value))        `thenStrictlyST` \ str ->
 210     _ccall_ setenv str                              `thenPrimIO` \ rc ->
 211     if rc == 0 then
 212         return ()
 213     else
 214         syserr "setEnvVar"
 215
 216 removeEnvVar :: String -> IO ()
 217 removeEnvVar name =
 218     _packBytesForCST name                           `thenStrictlyST` \ str ->
 219     _ccall_ delenv str                              `thenPrimIO` \ rc ->
 220     if rc == 0 then
 221         return ()
 222     else
 223         syserr "removeEnvVar"
 224
 225 type Signal = Int
 226
 227 nullSignal :: Signal
 228 nullSignal = 0
 229
 230 backgroundRead, sigTTIN :: Signal
 231 backgroundRead = ``SIGTTIN''
 232 sigTTIN = ``SIGTTIN''
 233
 234 backgroundWrite, sigTTOU :: Signal
 235 backgroundWrite = ``SIGTTOU''
 236 sigTTOU = ``SIGTTOU''
 237
 238 continueProcess, sigCONT :: Signal
 239 continueProcess = ``SIGCONT''
 240 sigCONT = ``SIGCONT''
 241
 242 floatingPointException, sigFPE :: Signal
 243 floatingPointException = ``SIGFPE''
 244 sigFPE = ``SIGFPE''
 245
 246 illegalInstruction, sigILL :: Signal
 247 illegalInstruction = ``SIGILL''
 248 sigILL = ``SIGILL''
 249
 250 internalAbort, sigABRT ::Signal
 251 internalAbort = ``SIGABRT''
 252 sigABRT = ``SIGABRT''
 253
 254 keyboardSignal, sigINT :: Signal
 255 keyboardSignal = ``SIGINT''
 256 sigINT = ``SIGINT''
 257
 258 keyboardStop, sigTSTP :: Signal
 259 keyboardStop = ``SIGTSTP''
 260 sigTSTP = ``SIGTSTP''
 261
 262 keyboardTermination, sigQUIT :: Signal
 263 keyboardTermination = ``SIGQUIT''
 264 sigQUIT = ``SIGQUIT''
 265
 266 killProcess, sigKILL :: Signal
 267 killProcess = ``SIGKILL''
 268 sigKILL = ``SIGKILL''
 269
 270 lostConnection, sigHUP :: Signal
 271 lostConnection = ``SIGHUP''
 272 sigHUP = ``SIGHUP''
 273
 274 openEndedPipe, sigPIPE :: Signal
 275 openEndedPipe = ``SIGPIPE''
 276 sigPIPE = ``SIGPIPE''
 277
 278 processStatusChanged, sigCHLD :: Signal
 279 processStatusChanged = ``SIGCHLD''
 280 sigCHLD = ``SIGCHLD''
 281
 282 realTimeAlarm, sigALRM :: Signal
 283 realTimeAlarm = ``SIGALRM''
 284 sigALRM = ``SIGALRM''
 285
 286 segmentationViolation, sigSEGV :: Signal
 287 segmentationViolation = ``SIGSEGV''
 288 sigSEGV = ``SIGSEGV''
 289
 290 softwareStop, sigSTOP :: Signal
 291 softwareStop = ``SIGSTOP''
 292 sigSTOP = ``SIGSTOP''
 293
 294 softwareTermination, sigTERM :: Signal
 295 softwareTermination = ``SIGTERM''
 296 sigTERM = ``SIGTERM''
 297
 298 userDefinedSignal1, sigUSR1 :: Signal
 299 userDefinedSignal1 = ``SIGUSR1''
 300 sigUSR1 = ``SIGUSR1''
 301
 302 userDefinedSignal2, sigUSR2 :: Signal
 303 userDefinedSignal2 = ``SIGUSR2''
 304 sigUSR2 = ``SIGUSR2''
 305
 306 signalProcess :: Signal -> ProcessID -> IO ()
 307 signalProcess int pid =
 308     _ccall_ kill pid int                            `thenPrimIO` \ rc ->
 309     if rc == 0 then
 310         return ()
 311     else
 312         syserr "signalProcess"
 313
 314 raiseSignal :: Signal -> IO ()
 315 raiseSignal int = getProcessID >>= signalProcess int
 316
 317 signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
 318 signalProcessGroup int pgid = signalProcess int (-pgid)
 319
 320 setStoppedChildFlag :: Bool -> IO Bool
 321 setStoppedChildFlag b =
 322     _casm_ ``%r = nocldstop; nocldstop = %0;'' x    `thenPrimIO` \ rc ->
 323     return (rc == 0)
 324   where
 325     x = case b of {True -> 0; False -> 1}
 326
 327 queryStoppedChildFlag :: IO Bool
 328 queryStoppedChildFlag =
 329     _casm_ ``%r = nocldstop;''                      `thenPrimIO` \ rc ->
 330     return (rc == 0)
 331
 332 data Handler = Default
 333              | Ignore
 334              | Catch (IO ())
 335
 336 type SignalSet = _ByteArray ()
 337
 338 sigSetSize :: Int
 339 sigSetSize = ``sizeof(sigset_t)''
 340
 341 emptySignalSet :: SignalSet
 342 emptySignalSet = unsafePerformPrimIO (
 343     allocChars sigSetSize                           `thenStrictlyST` \ bytes ->
 344     _casm_ ``(void) sigemptyset((sigset_t *)%0);'' bytes
 345                                                     `thenPrimIO` \ () ->
 346     freeze bytes                                    `thenStrictlyST` \ sigset ->
 347     returnPrimIO sigset
 348     )
 349
 350 fullSignalSet :: SignalSet
 351 fullSignalSet = unsafePerformPrimIO (
 352     allocChars sigSetSize                           `thenStrictlyST` \ bytes ->
 353     _casm_ ``(void) sigfillset((sigset_t *)%0);'' bytes
 354                                                     `thenPrimIO` \ () ->
 355     freeze bytes                                    `thenStrictlyST` \ sigset ->
 356     returnPrimIO sigset
 357     )
 358
 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 ->
 365     returnPrimIO newset
 366     )
 367
 368 inSignalSet :: Signal -> SignalSet -> Bool
 369 inSignalSet int sigset = unsafePerformPrimIO (
 370     _casm_ ``%r = sigismember((sigset_t *)%0, %1);'' sigset int
 371                                                     `thenPrimIO` \ rc ->
 372     if rc == 1 then
 373         returnPrimIO True
 374     else
 375         returnPrimIO False
 376     )
 377
 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 ->
 384     returnPrimIO newset
 385     )
 386
 387 installHandler :: Signal
 388                -> Handler
 389                -> Maybe SignalSet       -- other signals to block
 390                -> IO Handler            -- old handler
 391
 392 #ifdef __PARALLEL_HASKELL__
 393 installHandler = error "installHandler: not available for Parallel Haskell"
 394 #else
 395 installHandler int handler maybe_mask = (
 396     case handler of
 397       Default -> _ccall_ stg_sig_ignore int mask
 398       Ignore -> _ccall_ stg_sig_default int mask
 399       Catch m ->
 400         makeStablePtr (wrap m)                      `thenPrimIO` \ sptr ->
 401         _ccall_ stg_sig_catch int sptr mask
 402     )
 403                                                     `thenPrimIO` \ rc ->
 404     if rc >= 0 then
 405         _casm_ ``%r = (StgStablePtr) (%0);'' rc     `thenPrimIO` \ osptr ->
 406         deRefStablePtr osptr                        `thenPrimIO` \ m ->
 407         return (Catch m)
 408     else if rc == ``STG_SIG_DFL'' then
 409         return Default
 410     else if rc == ``STG_SIG_IGN'' then
 411         return Ignore
 412     else
 413         syserr "installHandler"
 414   where
 415     mask = case maybe_mask of
 416              Nothing -> emptySignalSet
 417              Just x -> x
 418     wrap :: IO () -> PrimIO ()
 419     wrap m s =
 420         case (m s) of
 421           (result, s2@(S# _)) ->
 422             case result of
 423               Right ()  -> ( (), s2 )
 424               Left  err -> error ("I/O error: "++shows err "\n")
 425
 426 #endif {-!__PARALLEL_HASKELL__-}
 427
 428 getSignalMask :: IO SignalSet
 429 getSignalMask =
 430     allocChars sigSetSize                           `thenStrictlyST` \ bytes ->
 431     _casm_ ``%r = sigprocmask(0, NULL, (sigset_t *)%0);'' bytes
 432                                                     `thenPrimIO` \ rc ->
 433     if rc == 0 then
 434         freeze bytes                                `thenStrictlyST` \ sigset ->
 435         return sigset
 436     else
 437         syserr "getSignalMask"
 438
 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
 443                                                     `thenPrimIO` \ rc ->
 444     if rc == 0 then
 445         freeze bytes                                `thenStrictlyST` \ oldset ->
 446         return oldset
 447     else
 448         syserr name
 449
 450 setSignalMask :: SignalSet -> IO SignalSet
 451 setSignalMask = sigProcMask "setSignalMask" ``SIG_SETMASK''
 452
 453 blockSignals :: SignalSet -> IO SignalSet
 454 blockSignals = sigProcMask "blockSignals" ``SIG_BLOCK''
 455
 456 unBlockSignals :: SignalSet -> IO SignalSet
 457 unBlockSignals = sigProcMask "unBlockSignals" ``SIG_UNBLOCK''
 458
 459 getPendingSignals :: IO SignalSet
 460 getPendingSignals =
 461     allocChars sigSetSize                           `thenStrictlyST` \ bytes ->
 462     _casm_ ``%r = sigpending((sigset_t *)%0);'' bytes
 463                                                     `thenPrimIO` \ rc ->
 464     if rc == 0 then
 465         freeze bytes                                `thenStrictlyST` \ sigset ->
 466         return sigset
 467     else
 468         syserr "getPendingSignals"
 469
 470 awaitSignal :: Maybe SignalSet -> IO ()
 471 awaitSignal maybe_sigset =
 472     pause                                           `thenPrimIO` \ () ->
 473     getErrorCode                                    >>= \ err ->
 474     if err == interruptedOperation then
 475         return ()
 476     else
 477         syserr "awaitSignal"
 478   where
 479     pause :: PrimIO ()
 480     pause =
 481         case maybe_sigset of
 482           Nothing -> _casm_ ``(void) pause();''
 483           Just sigset -> _casm_ ``(void) sigsuspend((sigset_t *)%0);'' sigset
 484
 485 scheduleAlarm :: Int -> IO Int
 486 scheduleAlarm (I# secs#) =
 487     _ccall_ alarm (W# (int2Word# secs#))            `thenPrimIO` \ (W# w#) ->
 488     return (I# (word2Int# w#))
 489
 490 sleep :: Int -> IO ()
 491 sleep 0 = return ()
 492 sleep (I# secs#) =
 493     _ccall_ sleep (W# (int2Word# secs#))            `seqPrimIO`
 494     return ()
 495
 496 \end{code}
 497
 498 Local utility functions
 499
 500 \begin{code}
 501
 502 -- Get the trailing component of a path
 503
 504 basename :: String -> String
 505 basename "" = ""
 506 basename (c:cs)
 507   | c == '/' = basename cs
 508   | otherwise = c : basename cs
 509
 510 -- Convert wait options to appropriate set of flags
 511
 512 waitOptions :: Bool -> Bool -> Int
 513 --             block   stopped
 514 waitOptions False False = ``WNOHANG''
 515 waitOptions False True  = ``(WNOHANG|WUNTRACED)''
 516 waitOptions True  False = 0
 517 waitOptions True  True  = ``WUNTRACED''
 518
 519 -- Turn a (ptr to a) wait status into a ProcessStatus
 520
 521 decipherWaitStatus :: _MutableByteArray s x -> PrimIO ProcessStatus
 522 decipherWaitStatus wstat =
 523     _casm_ ``%r = WIFEXITED(*(int *)%0);'' wstat    `thenPrimIO` \ exited ->
 524     if exited /= 0 then
 525         _casm_ ``%r = WEXITSTATUS(*(int *)%0);'' wstat
 526                                                     `thenPrimIO` \ exitstatus ->
 527         if exitstatus == 0 then
 528             returnPrimIO (Exited ExitSuccess)
 529         else
 530             returnPrimIO (Exited (ExitFailure exitstatus))
 531     else
 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)
 538         else
 539             _casm_ ``%r = WSTOPSIG(*(int *)%0);'' wstat
 540                                                     `thenPrimIO` \ stopsig ->
 541             returnPrimIO (Stopped stopsig)
 542
 543 \end{code}