ghc/lib/posix/PosixProcPrim.lhs

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