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 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 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 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 fail (IOError Nothing NoSuchThing
 219                  "getEnvVar" "no such environment variable")
 220        else strcpy str
 221
 222 setEnvVar :: String -> String -> IO ()
 223 setEnvVar name value = do
 224     str <- packStringIO (name ++ ('=' : value))
 225     nonzero_error (_casm_ ``%r = _setenv(%0);'' str) "setEnvVar"
 226
 227 removeEnvVar :: String -> IO ()
 228 removeEnvVar name = do
 229     str <- packStringIO name
 230     nonzero_error (_ccall_ delenv str) "removeEnvVar"
 231
 232 type Signal = Int
 233
 234 nullSignal :: Signal
 235 nullSignal = 0
 236
 237 backgroundRead, sigTTIN :: Signal
 238 backgroundRead = ``SIGTTIN''
 239 sigTTIN = ``SIGTTIN''
 240
 241 backgroundWrite, sigTTOU :: Signal
 242 backgroundWrite = ``SIGTTOU''
 243 sigTTOU = ``SIGTTOU''
 244
 245 #ifndef cygwin32_TARGET_OS
 246 continueProcess, sigCONT :: Signal
 247 continueProcess = ``SIGCONT''
 248 sigCONT = ``SIGCONT''
 249 #endif
 250
 251 floatingPointException, sigFPE :: Signal
 252 floatingPointException = ``SIGFPE''
 253 sigFPE = ``SIGFPE''
 254
 255 illegalInstruction, sigILL :: Signal
 256 illegalInstruction = ``SIGILL''
 257 sigILL = ``SIGILL''
 258
 259 internalAbort, sigABRT ::Signal
 260 internalAbort = ``SIGABRT''
 261 sigABRT = ``SIGABRT''
 262
 263 keyboardSignal, sigINT :: Signal
 264 keyboardSignal = ``SIGINT''
 265 sigINT = ``SIGINT''
 266
 267 keyboardStop, sigTSTP :: Signal
 268 keyboardStop = ``SIGTSTP''
 269 sigTSTP = ``SIGTSTP''
 270
 271 keyboardTermination, sigQUIT :: Signal
 272 keyboardTermination = ``SIGQUIT''
 273 sigQUIT = ``SIGQUIT''
 274
 275 killProcess, sigKILL :: Signal
 276 killProcess = ``SIGKILL''
 277 sigKILL = ``SIGKILL''
 278
 279 lostConnection, sigHUP :: Signal
 280 lostConnection = ``SIGHUP''
 281 sigHUP = ``SIGHUP''
 282
 283 openEndedPipe, sigPIPE :: Signal
 284 openEndedPipe = ``SIGPIPE''
 285 sigPIPE = ``SIGPIPE''
 286
 287 processStatusChanged, sigCHLD :: Signal
 288 processStatusChanged = ``SIGCHLD''
 289 sigCHLD = ``SIGCHLD''
 290
 291 realTimeAlarm, sigALRM :: Signal
 292 realTimeAlarm = ``SIGALRM''
 293 sigALRM = ``SIGALRM''
 294
 295 segmentationViolation, sigSEGV :: Signal
 296 segmentationViolation = ``SIGSEGV''
 297 sigSEGV = ``SIGSEGV''
 298
 299 softwareStop, sigSTOP :: Signal
 300 softwareStop = ``SIGSTOP''
 301 sigSTOP = ``SIGSTOP''
 302
 303 softwareTermination, sigTERM :: Signal
 304 softwareTermination = ``SIGTERM''
 305 sigTERM = ``SIGTERM''
 306
 307 userDefinedSignal1, sigUSR1 :: Signal
 308 userDefinedSignal1 = ``SIGUSR1''
 309 sigUSR1 = ``SIGUSR1''
 310
 311 userDefinedSignal2, sigUSR2 :: Signal
 312 userDefinedSignal2 = ``SIGUSR2''
 313 sigUSR2 = ``SIGUSR2''
 314
 315 signalProcess :: Signal -> ProcessID -> IO ()
 316 signalProcess int pid =
 317     nonzero_error (_ccall_ kill pid int) "signalProcess"
 318
 319 raiseSignal :: Signal -> IO ()
 320 raiseSignal int = getProcessID >>= signalProcess int
 321
 322 signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
 323 signalProcessGroup int pgid = signalProcess int (-pgid)
 324
 325 setStoppedChildFlag :: Bool -> IO Bool
 326 setStoppedChildFlag b = do
 327     rc <- _casm_ ``%r = nocldstop; nocldstop = %0;'' x
 328     return (rc == 0)
 329   where
 330     x = case b of {True -> 0; False -> 1}
 331
 332 queryStoppedChildFlag :: IO Bool
 333 queryStoppedChildFlag = do
 334     rc <- _casm_ ``%r = nocldstop;''
 335     return (rc == 0)
 336
 337 data Handler = Default
 338              | Ignore
 339              | Catch (IO ())
 340
 341 type SignalSet = ByteArray Int
 342
 343 sigSetSize :: Int
 344 sigSetSize = ``sizeof(sigset_t)''
 345
 346 emptySignalSet :: SignalSet
 347 emptySignalSet = unsafePerformPrimIO $ do
 348     bytes <- allocChars sigSetSize
 349     _casm_ ``(void) sigemptyset((sigset_t *)%0);'' bytes
 350     freeze bytes
 351
 352 fullSignalSet :: SignalSet
 353 fullSignalSet = unsafePerformPrimIO $ do
 354     bytes <- allocChars sigSetSize
 355     _casm_ ``(void) sigfillset((sigset_t *)%0);'' bytes
 356     freeze bytes
 357
 358 addSignal :: Signal -> SignalSet -> SignalSet
 359 addSignal int oldset = unsafePerformPrimIO $ do
 360     bytes <- allocChars sigSetSize
 361     _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1;
 362              (void) sigaddset((sigset_t *)%0, %2);''
 363         bytes oldset int
 364     freeze bytes
 365
 366 inSignalSet :: Signal -> SignalSet -> Bool
 367 inSignalSet int sigset = unsafePerformPrimIO $ do
 368     rc <- _casm_ ``%r = sigismember((sigset_t *)%0, %1);'' sigset int
 369     return (rc == 1)
 370
 371 deleteSignal :: Signal -> SignalSet -> SignalSet
 372 deleteSignal int oldset = unsafePerformPrimIO $ do
 373     bytes <- allocChars sigSetSize
 374     _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1;
 375              (void) sigdelset((sigset_t *)%0, %2);''
 376            bytes oldset int
 377     freeze bytes
 378
 379 installHandler :: Signal
 380                -> Handler
 381                -> Maybe SignalSet       -- other signals to block
 382                -> IO Handler            -- old handler
 383
 384 #ifdef __PARALLEL_HASKELL__
 385 installHandler = fail (userError "installHandler: not available for Parallel Haskell")
 386 #else
 387 installHandler int handler maybe_mask = (
 388     case handler of
 389       Default -> _ccall_ stg_sig_default int mask
 390       Ignore  -> _ccall_ stg_sig_ignore  int mask
 391       Catch m -> do
 392         sptr <- makeStablePtr (ioToPrimIO m)
 393         _ccall_ stg_sig_catch int sptr mask
 394     ) >>= \rc ->
 395
 396     if rc >= 0 then do
 397         osptr <- _casm_ ``%r = (StgStablePtr) (%0);'' rc
 398         m     <- deRefStablePtr osptr
 399         return (Catch m)
 400     else if rc == ``STG_SIG_DFL'' then
 401         return Default
 402     else if rc == ``STG_SIG_IGN'' then
 403         return Ignore
 404     else
 405         syserr "installHandler"
 406   where
 407     mask = case maybe_mask of
 408              Nothing -> emptySignalSet
 409              Just x -> x
 410
 411 #endif {-!__PARALLEL_HASKELL__-}
 412
 413 getSignalMask :: IO SignalSet
 414 getSignalMask = do
 415     bytes <- allocChars sigSetSize
 416     rc    <- _casm_ ``%r = sigprocmask(0, NULL, (sigset_t *)%0);'' bytes
 417     if rc == 0
 418        then freeze bytes
 419        else syserr "getSignalMask"
 420
 421 sigProcMask :: String -> Int -> SignalSet -> IO SignalSet
 422 sigProcMask name how sigset = do
 423     bytes <- allocChars sigSetSize
 424     rc <- _casm_ ``%r = sigprocmask(%0, (sigset_t *)%1, (sigset_t *)%2);''
 425                  how sigset bytes
 426     if rc == 0
 427        then freeze bytes
 428        else syserr name
 429
 430 setSignalMask :: SignalSet -> IO SignalSet
 431 setSignalMask = sigProcMask "setSignalMask" ``SIG_SETMASK''
 432
 433 blockSignals :: SignalSet -> IO SignalSet
 434 blockSignals = sigProcMask "blockSignals" ``SIG_BLOCK''
 435
 436 unBlockSignals :: SignalSet -> IO SignalSet
 437 unBlockSignals = sigProcMask "unBlockSignals" ``SIG_UNBLOCK''
 438
 439 getPendingSignals :: IO SignalSet
 440 getPendingSignals = do
 441     bytes <- allocChars sigSetSize
 442     rc <- _casm_ ``%r = sigpending((sigset_t *)%0);'' bytes
 443     if rc == 0
 444        then freeze bytes
 445        else syserr "getPendingSignals"
 446
 447 #ifndef cygwin32_TARGET_OS
 448 awaitSignal :: Maybe SignalSet -> IO ()
 449 awaitSignal maybe_sigset = do
 450     pause maybe_sigset
 451     err <- getErrorCode
 452     if err == interruptedOperation
 453        then return ()
 454        else syserr "awaitSignal"
 455
 456 pause :: Maybe SignalSet -> IO ()
 457 pause maybe_sigset =
 458   case maybe_sigset of
 459    Nothing -> _casm_ ``(void) pause();''
 460    Just sigset -> _casm_ ``(void) sigsuspend((sigset_t *)%0);'' sigset
 461 #endif
 462
 463 scheduleAlarm :: Int -> IO Int
 464 scheduleAlarm (I# secs#) =
 465     _ccall_ alarm (W# (int2Word# secs#))            >>= \ (W# w#) ->
 466     return (I# (word2Int# w#))
 467
 468 sleep :: Int -> IO ()
 469 sleep 0 = return ()
 470 sleep (I# secs#) = do
 471     _ccall_ sleep (W# (int2Word# secs#))
 472     return ()
 473 \end{code}
 474
 475 Local utility functions
 476
 477 \begin{code}
 478
 479 -- Get the trailing component of a path
 480
 481 basename :: String -> String
 482 basename "" = ""
 483 basename (c:cs)
 484   | c == '/' = basename cs
 485   | otherwise = c : basename cs
 486
 487 -- Convert wait options to appropriate set of flags
 488
 489 waitOptions :: Bool -> Bool -> Int
 490 --             block   stopped
 491 waitOptions False False = ``WNOHANG''
 492 waitOptions False True  = ``(WNOHANG|WUNTRACED)''
 493 waitOptions True  False = 0
 494 waitOptions True  True  = ``WUNTRACED''
 495
 496 -- Turn a (ptr to a) wait status into a ProcessStatus
 497
 498 decipherWaitStatus :: MutableByteArray s x -> IO ProcessStatus
 499 decipherWaitStatus wstat = do
 500     exited <- _casm_ ``%r = WIFEXITED(*(int *)%0);'' wstat
 501     if exited /= 0
 502       then do
 503         exitstatus <- _casm_ ``%r = WEXITSTATUS(*(int *)%0);'' wstat
 504         if exitstatus == 0
 505            then return (Exited ExitSuccess)
 506            else return (Exited (ExitFailure exitstatus))
 507       else do
 508         signalled <- _casm_ ``%r = WIFSIGNALED(*(int *)%0);'' wstat
 509         if signalled /= 0
 510            then do
 511                 termsig <- _casm_ ``%r = WTERMSIG(*(int *)%0);'' wstat
 512                 return (Terminated termsig)
 513            else do
 514                 stopsig <-_casm_ ``%r = WSTOPSIG(*(int *)%0);'' wstat
 515                 return (Stopped stopsig)
 516 \end{code}