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     _ccall_ stg_sigaddset bytes oldset int
 362     freeze bytes
 363
 364 inSignalSet :: Signal -> SignalSet -> Bool
 365 inSignalSet int sigset = unsafePerformPrimIO $ do
 366     rc <- _casm_ ``%r = sigismember((sigset_t *)%0, %1);'' sigset int
 367     return (rc == 1)
 368
 369 deleteSignal :: Signal -> SignalSet -> SignalSet
 370 deleteSignal int oldset = unsafePerformPrimIO $ do
 371     bytes <- allocChars sigSetSize
 372     _ccall_ stg_sigdelset bytes oldset int
 373     freeze bytes
 374
 375 installHandler :: Signal
 376                -> Handler
 377                -> Maybe SignalSet       -- other signals to block
 378                -> IO Handler            -- old handler
 379
 380 #ifdef __PARALLEL_HASKELL__
 381 installHandler = fail (userError "installHandler: not available for Parallel Haskell")
 382 #else
 383 installHandler int handler maybe_mask = (
 384     case handler of
 385       Default -> _ccall_ stg_sig_default int mask
 386       Ignore  -> _ccall_ stg_sig_ignore  int mask
 387       Catch m -> do
 388         sptr <- makeStablePtr (ioToPrimIO m)
 389         _ccall_ stg_sig_catch int sptr mask
 390     ) >>= \rc ->
 391
 392     if rc >= 0 then do
 393         osptr <- _casm_ ``%r = (StgStablePtr) (%0);'' rc
 394         m     <- deRefStablePtr osptr
 395         return (Catch m)
 396     else if rc == ``STG_SIG_DFL'' then
 397         return Default
 398     else if rc == ``STG_SIG_IGN'' then
 399         return Ignore
 400     else
 401         syserr "installHandler"
 402   where
 403     mask = case maybe_mask of
 404              Nothing -> emptySignalSet
 405              Just x -> x
 406
 407 #endif {-!__PARALLEL_HASKELL__-}
 408
 409 getSignalMask :: IO SignalSet
 410 getSignalMask = do
 411     bytes <- allocChars sigSetSize
 412     rc    <- _casm_ ``%r = sigprocmask(0, NULL, (sigset_t *)%0);'' bytes
 413     if rc == 0
 414        then freeze bytes
 415        else syserr "getSignalMask"
 416
 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);''
 421                  how sigset bytes
 422     if rc == 0
 423        then freeze bytes
 424        else syserr name
 425
 426 setSignalMask :: SignalSet -> IO SignalSet
 427 setSignalMask = sigProcMask "setSignalMask" ``SIG_SETMASK''
 428
 429 blockSignals :: SignalSet -> IO SignalSet
 430 blockSignals = sigProcMask "blockSignals" ``SIG_BLOCK''
 431
 432 unBlockSignals :: SignalSet -> IO SignalSet
 433 unBlockSignals = sigProcMask "unBlockSignals" ``SIG_UNBLOCK''
 434
 435 getPendingSignals :: IO SignalSet
 436 getPendingSignals = do
 437     bytes <- allocChars sigSetSize
 438     rc <- _casm_ ``%r = sigpending((sigset_t *)%0);'' bytes
 439     if rc == 0
 440        then freeze bytes
 441        else syserr "getPendingSignals"
 442
 443 #ifndef cygwin32_TARGET_OS
 444 awaitSignal :: Maybe SignalSet -> IO ()
 445 awaitSignal maybe_sigset = do
 446     pause maybe_sigset
 447     err <- getErrorCode
 448     if err == interruptedOperation
 449        then return ()
 450        else syserr "awaitSignal"
 451
 452 pause :: Maybe SignalSet -> IO ()
 453 pause maybe_sigset =
 454   case maybe_sigset of
 455    Nothing -> _casm_ ``(void) pause();''
 456    Just sigset -> _casm_ ``(void) sigsuspend((sigset_t *)%0);'' sigset
 457 #endif
 458
 459 scheduleAlarm :: Int -> IO Int
 460 scheduleAlarm (I# secs#) =
 461     _ccall_ alarm (W# (int2Word# secs#))            >>= \ (W# w#) ->
 462     return (I# (word2Int# w#))
 463
 464 sleep :: Int -> IO ()
 465 sleep 0 = return ()
 466 sleep (I# secs#) = do
 467     _ccall_ sleep (W# (int2Word# secs#))
 468     return ()
 469 \end{code}
 470
 471 Local utility functions
 472
 473 \begin{code}
 474
 475 -- Get the trailing component of a path
 476
 477 basename :: String -> String
 478 basename "" = ""
 479 basename (c:cs)
 480   | c == '/' = basename cs
 481   | otherwise = c : basename cs
 482
 483 -- Convert wait options to appropriate set of flags
 484
 485 waitOptions :: Bool -> Bool -> Int
 486 --             block   stopped
 487 waitOptions False False = ``WNOHANG''
 488 waitOptions False True  = ``(WNOHANG|WUNTRACED)''
 489 waitOptions True  False = 0
 490 waitOptions True  True  = ``WUNTRACED''
 491
 492 -- Turn a (ptr to a) wait status into a ProcessStatus
 493
 494 decipherWaitStatus :: MutableByteArray s x -> IO ProcessStatus
 495 decipherWaitStatus wstat = do
 496     exited <- _casm_ ``%r = WIFEXITED(*(int *)%0);'' wstat
 497     if exited /= 0
 498       then do
 499         exitstatus <- _casm_ ``%r = WEXITSTATUS(*(int *)%0);'' wstat
 500         if exitstatus == 0
 501            then return (Exited ExitSuccess)
 502            else return (Exited (ExitFailure exitstatus))
 503       else do
 504         signalled <- _casm_ ``%r = WIFSIGNALED(*(int *)%0);'' wstat
 505         if signalled /= 0
 506            then do
 507                 termsig <- _casm_ ``%r = WTERMSIG(*(int *)%0);'' wstat
 508                 return (Terminated termsig)
 509            else do
 510                 stopsig <-_casm_ ``%r = WSTOPSIG(*(int *)%0);'' wstat
 511                 return (Stopped stopsig)
 512 \end{code}