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 PackedString (psToByteArrayST)
 102 import Foreign  -- stable pointers
 103 import PosixErr
 104 import PosixUtil
 105 import Util ( unvectorize )
 106
 107 import System(ExitCode(..))
 108 import PosixProcEnv (getProcessID)
 109
 110 forkProcess :: IO (Maybe ProcessID)
 111 forkProcess = do
 112     pid <-_ccall_ fork
 113     case pid of
 114       -1 -> syserr "forkProcess"
 115       0  -> return Nothing
 116       _  -> return (Just pid)
 117
 118 executeFile :: FilePath                     -- Command
 119             -> Bool                         -- Search PATH?
 120             -> [String]                     -- Arguments
 121             -> Maybe [(String, String)]     -- Environment
 122             -> IO ()
 123 executeFile path search args Nothing = do
 124     prog <- psToByteArrayIO path
 125     argv <- vectorize (basename path:args)
 126     (if search then
 127         _casm_ ``execvp(%0,(char **)%1);'' prog argv
 128      else
 129         _casm_ ``execv(%0,(char **)%1);'' prog argv
 130      )
 131     syserr "executeFile"
 132
 133 executeFile path search args (Just env) = do
 134     prog <- psToByteArrayIO path
 135     argv <- vectorize (basename path:args)
 136     envp <- vectorize (map (\ (name, val) -> name ++ ('=' : val)) env)
 137     (if search then
 138         _casm_ `` execvpe(%0,(char **)%1,(char **)%2);'' prog argv envp
 139      else
 140         _casm_ `` execve(%0,(char **)%1,(char **)%2);'' prog argv envp
 141      )
 142     syserr "executeFile"
 143
 144 data ProcessStatus = Exited ExitCode
 145                    | Terminated Signal
 146                    | Stopped Signal
 147                    deriving (Eq, Ord, Show)
 148
 149 getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
 150 getProcessStatus block stopped pid = do
 151     wstat <- allocWords 1
 152     pid   <-_casm_ ``%r = waitpid(%0, (int *)%1, %2);'' pid wstat
 153                 (waitOptions block stopped)
 154     case pid of
 155       -1 -> syserr "getProcessStatus"
 156       0  -> return Nothing
 157       _  -> do ps <- decipherWaitStatus wstat
 158                return (Just ps)
 159
 160 getGroupProcessStatus :: Bool
 161                       -> Bool
 162                       -> ProcessGroupID
 163                       -> IO (Maybe (ProcessID, ProcessStatus))
 164 getGroupProcessStatus block stopped pgid = do
 165     wstat <- allocWords 1
 166     pid   <-_casm_ ``%r = waitpid(%0, (int *)%1, %2);'' (-pgid) wstat
 167                    (waitOptions block stopped)
 168     case pid of
 169       -1 -> syserr "getGroupProcessStatus"
 170       0  -> return Nothing
 171       _  -> do ps <- decipherWaitStatus wstat
 172                return (Just (pid, ps))
 173
 174 getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
 175 getAnyProcessStatus block stopped =
 176     getGroupProcessStatus block stopped 1           `catch`
 177     \ err -> syserr "getAnyProcessStatus"
 178
 179 exitImmediately :: ExitCode -> IO ()
 180 exitImmediately exitcode = do
 181     _casm_ ``_exit(%0);'' (exitcode2Int exitcode)
 182     syserr "exitImmediately"
 183   where
 184     exitcode2Int ExitSuccess = 0
 185     exitcode2Int (ExitFailure n) = n
 186
 187 getEnvironment :: IO [(String, String)]
 188 getEnvironment = do
 189     --WAS: env  <- unvectorize ``environ'' 0
 190     -- does not work too well, since the lit-lit
 191     -- is turned into an Addr that is only evaluated
 192     -- once (environ is changed to point the most
 193     -- current env. block after the addition of new entries).
 194     envp <- _casm_ `` %r=environ; ''
 195     env  <- unvectorize (envp::Addr) 0
 196     return (map (split "") env)
 197   where
 198     split :: String -> String -> (String, String)
 199     split x [] = error ("PosixProcPrim.getEnvironment:no `='? in: "++reverse x)
 200     split x ('=' : xs) = (reverse x, xs)
 201     split x (c:cs) = split (c:x) cs
 202
 203 setEnvironment :: [(String, String)] -> IO ()
 204 setEnvironment pairs = do
 205     env <- vectorize (map (\ (var,val) -> var ++ ('=' : val)) pairs)
 206     nonzero_error (_casm_ ``%r = setenviron((char **)%0);'' env)
 207         "setEnvironment"
 208
 209 getEnvVar :: String -> IO String
 210 getEnvVar name = do
 211     str <- psToByteArrayIO name
 212     str <- _ccall_ getenv str
 213     if str == ``NULL''
 214        then fail (IOError Nothing NoSuchThing
 215                  "getEnvVar: no such environment variable")
 216        else strcpy str
 217
 218 setEnvVar :: String -> String -> IO ()
 219 setEnvVar name value = do
 220     str <- psToByteArrayIO (name ++ ('=' : value))
 221     nonzero_error (_casm_ ``%r = _setenv(%0);'' str) "setEnvVar"
 222
 223 removeEnvVar :: String -> IO ()
 224 removeEnvVar name = do
 225     str <- psToByteArrayIO name
 226     nonzero_error (_ccall_ delenv str) "removeEnvVar"
 227
 228 type Signal = Int
 229
 230 nullSignal :: Signal
 231 nullSignal = 0
 232
 233 backgroundRead, sigTTIN :: Signal
 234 backgroundRead = ``SIGTTIN''
 235 sigTTIN = ``SIGTTIN''
 236
 237 backgroundWrite, sigTTOU :: Signal
 238 backgroundWrite = ``SIGTTOU''
 239 sigTTOU = ``SIGTTOU''
 240
 241 #ifndef cygwin32_TARGET_OS
 242 continueProcess, sigCONT :: Signal
 243 continueProcess = ``SIGCONT''
 244 sigCONT = ``SIGCONT''
 245 #endif
 246
 247 floatingPointException, sigFPE :: Signal
 248 floatingPointException = ``SIGFPE''
 249 sigFPE = ``SIGFPE''
 250
 251 illegalInstruction, sigILL :: Signal
 252 illegalInstruction = ``SIGILL''
 253 sigILL = ``SIGILL''
 254
 255 internalAbort, sigABRT ::Signal
 256 internalAbort = ``SIGABRT''
 257 sigABRT = ``SIGABRT''
 258
 259 keyboardSignal, sigINT :: Signal
 260 keyboardSignal = ``SIGINT''
 261 sigINT = ``SIGINT''
 262
 263 keyboardStop, sigTSTP :: Signal
 264 keyboardStop = ``SIGTSTP''
 265 sigTSTP = ``SIGTSTP''
 266
 267 keyboardTermination, sigQUIT :: Signal
 268 keyboardTermination = ``SIGQUIT''
 269 sigQUIT = ``SIGQUIT''
 270
 271 killProcess, sigKILL :: Signal
 272 killProcess = ``SIGKILL''
 273 sigKILL = ``SIGKILL''
 274
 275 lostConnection, sigHUP :: Signal
 276 lostConnection = ``SIGHUP''
 277 sigHUP = ``SIGHUP''
 278
 279 openEndedPipe, sigPIPE :: Signal
 280 openEndedPipe = ``SIGPIPE''
 281 sigPIPE = ``SIGPIPE''
 282
 283 processStatusChanged, sigCHLD :: Signal
 284 processStatusChanged = ``SIGCHLD''
 285 sigCHLD = ``SIGCHLD''
 286
 287 realTimeAlarm, sigALRM :: Signal
 288 realTimeAlarm = ``SIGALRM''
 289 sigALRM = ``SIGALRM''
 290
 291 segmentationViolation, sigSEGV :: Signal
 292 segmentationViolation = ``SIGSEGV''
 293 sigSEGV = ``SIGSEGV''
 294
 295 softwareStop, sigSTOP :: Signal
 296 softwareStop = ``SIGSTOP''
 297 sigSTOP = ``SIGSTOP''
 298
 299 softwareTermination, sigTERM :: Signal
 300 softwareTermination = ``SIGTERM''
 301 sigTERM = ``SIGTERM''
 302
 303 userDefinedSignal1, sigUSR1 :: Signal
 304 userDefinedSignal1 = ``SIGUSR1''
 305 sigUSR1 = ``SIGUSR1''
 306
 307 userDefinedSignal2, sigUSR2 :: Signal
 308 userDefinedSignal2 = ``SIGUSR2''
 309 sigUSR2 = ``SIGUSR2''
 310
 311 signalProcess :: Signal -> ProcessID -> IO ()
 312 signalProcess int pid =
 313     nonzero_error (_ccall_ kill pid int) "signalProcess"
 314
 315 raiseSignal :: Signal -> IO ()
 316 raiseSignal int = getProcessID >>= signalProcess int
 317
 318 signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
 319 signalProcessGroup int pgid = signalProcess int (-pgid)
 320
 321 setStoppedChildFlag :: Bool -> IO Bool
 322 setStoppedChildFlag b = do
 323     rc <- _casm_ ``%r = nocldstop; nocldstop = %0;'' x
 324     return (rc == 0)
 325   where
 326     x = case b of {True -> 0; False -> 1}
 327
 328 queryStoppedChildFlag :: IO Bool
 329 queryStoppedChildFlag = do
 330     rc <- _casm_ ``%r = nocldstop;''
 331     return (rc == 0)
 332
 333 data Handler = Default
 334              | Ignore
 335              | Catch (IO ())
 336
 337 type SignalSet = ByteArray ()
 338
 339 sigSetSize :: Int
 340 sigSetSize = ``sizeof(sigset_t)''
 341
 342 emptySignalSet :: SignalSet
 343 emptySignalSet = unsafePerformPrimIO $ do
 344     bytes <- allocChars sigSetSize
 345     _casm_ ``(void) sigemptyset((sigset_t *)%0);'' bytes
 346     freeze bytes
 347
 348 fullSignalSet :: SignalSet
 349 fullSignalSet = unsafePerformPrimIO $ do
 350     bytes <- allocChars sigSetSize
 351     _casm_ ``(void) sigfillset((sigset_t *)%0);'' bytes
 352     freeze bytes
 353
 354 addSignal :: Signal -> SignalSet -> SignalSet
 355 addSignal int oldset = unsafePerformPrimIO $ do
 356     bytes <- allocChars sigSetSize
 357     _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1;
 358              (void) sigaddset((sigset_t *)%0, %2);''
 359         bytes oldset int
 360     freeze bytes
 361
 362 inSignalSet :: Signal -> SignalSet -> Bool
 363 inSignalSet int sigset = unsafePerformPrimIO $ do
 364     rc <- _casm_ ``%r = sigismember((sigset_t *)%0, %1);'' sigset int
 365     return (rc == 1)
 366
 367 deleteSignal :: Signal -> SignalSet -> SignalSet
 368 deleteSignal int oldset = unsafePerformPrimIO $ do
 369     bytes <- allocChars sigSetSize
 370     _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1;
 371              (void) sigdelset((sigset_t *)%0, %2);''
 372            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 = error "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}