Guest User

Untitled

a guest
Mar 1st, 2012
83
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. -- Posix extras module from http://web.archiveorange.com/archive/v/2B0uXg72rgFNm2yKVyxc (Glasgow Haskell mailing list)
  2. -- Wait4 haskell implementation
  3.  
  4. -- $Id$
  5.  
  6. module PosixExtras
  7. (
  8.   ProcessResourceUsage(..),
  9.   reapChildProcess
  10. )
  11. where
  12.  
  13. import Ratio
  14. import System
  15. import System.Posix hiding (userTime, systemTime)
  16. import System.IO.Error
  17. import Foreign
  18. import Foreign.C
  19. import Data.Time.Clock
  20.  
  21.  
  22. data ProcessResourceUsage = ProcessResourceUsage { userTime, systemTime :: DiffTime }
  23.                           deriving (Show)
  24.  
  25.  
  26. reapChildProcess :: Bool -> Bool -> ProcessID
  27.         -> IO (Maybe (ProcessID, ProcessStatus, ProcessResourceUsage))
  28. reapChildProcess block stopped pid = alloca $ \p_wstat ->
  29.   allocaBytes structRusageSize $ \p_sru -> do
  30.     pid' <- throwErrnoIfMinus1 "reapChildProcess"
  31.              (c_wait4 (fromIntegral pid) p_wstat
  32.                       (waitOptions block stopped) p_sru)
  33.    case pid' of
  34.       0 -> return Nothing
  35.       _ -> do ps  <- decipherWaitStatus p_wstat
  36.               pru <- makeProcessResourceUsage p_sru
  37.               return (Just (fromIntegral pid', ps, pru))
  38.  
  39.  
  40. structRusageSize = 144  -- I think it's 72.  Include 100% slop.
  41.  
  42. type CRusage = CInt  -- cheat
  43.  
  44. makeProcessResourceUsage :: Ptr CInt -> IO ProcessResourceUsage
  45. makeProcessResourceUsage p_sru = do
  46.   -- Assume that ru_utime and ru_stime are at the beginning of struct rusage.
  47.   [uhi, ulo, shi, slo] <- mapM get [0..3]
  48.   let u = time uhi ulo
  49.       s = time shi slo
  50.   return $ ProcessResourceUsage{ userTime = u, systemTime = s }
  51.  where
  52.   get n = fmap fromIntegral $ peekElemOff p_sru n
  53.   time hi lo = picosecondsToDiffTime ((fromIntegral hi)*10^6 + ((fromIntegral lo)))*10^6
  54.  
  55. foreign import ccall unsafe "wait4"
  56.    c_wait4 :: CPid -> Ptr CInt -> CInt -> Ptr CRusage -> IO CPid
  57.  
  58. -- The following was scarfed from
  59. -- fptools/libraries/unix/System/Posix/Process.hsc?rev=1.4
  60.  
  61. waitOptions :: Bool -> Bool -> CInt
  62. --             block   stopped
  63. waitOptions False False = 1 -- (#const WNOHANG)
  64. waitOptions False True  = 3 -- (#const (WNOHANG|WUNTRACED))
  65. waitOptions True  False = 0
  66. waitOptions True  True  = 2 -- (#const WUNTRACED)
  67.  
  68. -- Turn a (ptr to a) wait status into a ProcessStatus
  69.  
  70. decipherWaitStatus :: Ptr CInt -> IO ProcessStatus
  71. decipherWaitStatus wstatp = do
  72.   wstat <- peek wstatp
  73.   if c_WIFEXITED wstat /= 0
  74.       then do
  75.         let exitstatus = c_WEXITSTATUS wstat
  76.         if exitstatus == 0
  77.            then return (Exited ExitSuccess)
  78.            else return (Exited (ExitFailure (fromIntegral exitstatus)))
  79.       else do
  80.         if c_WIFSIGNALED wstat /= 0
  81.            then do
  82.                 let termsig = c_WTERMSIG wstat
  83.                 return (Terminated (fromIntegral termsig))
  84.            else do
  85.                 if c_WIFSTOPPED wstat /= 0
  86.                    then do
  87.                         let stopsig = c_WSTOPSIG wstat
  88.                         return (Stopped (fromIntegral stopsig))
  89.                    else do
  90.                         ioError (mkIOError illegalOperationErrorType
  91.                                    "waitStatus" Nothing Nothing)
  92.  
  93. {-
  94.  
  95. foreign import ccall unsafe "__hsunix_wifexited"
  96.   c_WIFEXITED :: CInt -> CInt
  97.  
  98. foreign import ccall unsafe "__hsunix_wexitstatus"
  99.   c_WEXITSTATUS :: CInt -> CInt
  100.  
  101. foreign import ccall unsafe "__hsunix_wifsignaled"
  102.   c_WIFSIGNALED :: CInt -> CInt
  103.  
  104. foreign import ccall unsafe "__hsunix_wtermsig"
  105.   c_WTERMSIG :: CInt -> CInt
  106.  
  107. foreign import ccall unsafe "__hsunix_wifstopped"
  108.   c_WIFSTOPPED :: CInt -> CInt
  109.  
  110. foreign import ccall unsafe "__hsunix_wstopsig"
  111.   c_WSTOPSIG :: CInt -> CInt
  112.  
  113. -}
  114.  
  115. c_WIFEXITED :: CInt -> CInt
  116. c_WIFEXITED c = h2c $ fromEnum $ low7 (c2h c) == 0
  117.  
  118. c_WEXITSTATUS :: CInt -> CInt
  119. c_WEXITSTATUS c = h2c $ high8 $ c2h c
  120.  
  121. c_WIFSIGNALED :: CInt -> CInt
  122. c_WIFSIGNALED c = h2c $ fromEnum $ c_WIFSTOPPED c /= 0 && c_WIFEXITED c /= 0
  123.  
  124. c_WTERMSIG :: CInt -> CInt
  125. c_WTERMSIG c = h2c $ low7 $ c2h c
  126.  
  127. c_WIFSTOPPED :: CInt -> CInt
  128. c_WIFSTOPPED c = h2c $ fromEnum $ low8 (c2h c) == 127
  129.  
  130. c_WSTOPSIG :: CInt -> CInt
  131. c_WSTOPSIG c = h2c $ high8 $ c2h c
  132.  
  133. low7  x = x `rem` 128
  134. low8  x = x `rem` 256
  135. high8 x = x `div` 256
  136.  
  137. c2h = fromIntegral
  138. h2c = fromIntegral
RAW Paste Data