ghc/lib/misc/Select.lhs

   1 %
   2 % (c) sof, 1999
   3 %
   4
   5 Haskell wrapper for select() OS functionality. It's use
   6 shouldn't be all that common in a Haskell system that implements
   7 IO in such a way that's thread friendly, but still.
   8
   9 \begin{code}
  10 {-# OPTIONS -#include "cbits/selectFrom.h" #-}
  11 module Select
  12     (
  13       hSelect     -- :: [Handle]
  14                   -- -> [Handle]
  15                   -- -> [Handle]
  16                   -- -> TimeOut
  17                   -- -> IO SelectResult
  18     , TimeOut(..) -- type _ = Maybe Int
  19     , SelectResult(..)
  20     ) where
  21
  22 import Posix
  23 import GlaExts
  24 import IO
  25 import Monad
  26 import Maybe
  27 import PrelIOBase
  28 import PosixUtil (fdToInt)
  29 \end{code}
  30
  31 This stuff should really be done using HDirect.
  32
  33 \begin{code}
  34 type TimeOut
  35  = Maybe Int
  36     -- Nothing => wait indefinitely.
  37     -- Just x | x >= 0    => block waiting for 'x' micro seconds.
  38     --        | otherwise => block waiting for '-x' micro seconds.
  39
  40 type SelectResult
  41  = ([Handle], [Handle], [Handle])
  42
  43 hSelect :: [Handle]  -- input/read handles
  44         -> [Handle]  -- output/write handles
  45         -> [Handle]  -- exceptional handles
  46         -> TimeOut
  47         -> IO SelectResult
  48 hSelect ins outs excps timeout = do
  49      ins_         <- mapM getFd ins
  50      outs_        <- mapM getFd outs
  51      excps_       <- mapM getFd excps
  52      (max_in,  fds_ins)   <- marshallFDs ins_
  53      (max_out, fds_outs)  <- marshallFDs outs_
  54      (max_excp,fds_excps) <- marshallFDs excps_
  55      tout                 <- marshallTimeout timeout
  56      let max_fd = max_in `max` max_out `max` max_excp
  57      rc                <- selectFrom__ fds_ins
  58                                        fds_outs
  59                                        fds_excps
  60                                        (max_fd+1) tout
  61      if (rc /= 0)
  62       then constructErrorAndFail "hSelect"
  63       else
  64          let
  65            -- thunk these so that we only pay unmarshalling costs if demanded.
  66           ins_ready   = unsafePerformIO (getReadyOnes fds_ins ins_)
  67           outs_ready  = unsafePerformIO (getReadyOnes fds_outs outs_)
  68           excps_ready = unsafePerformIO (getReadyOnes fds_outs outs_)
  69          in
  70          return (ins_ready, outs_ready, excps_ready)
  71
  72 getFd :: Handle -> IO (Fd,Handle)
  73 getFd h = do
  74   f <- handleToFd h
  75   return (f,h)
  76
  77 foreign import "selectFrom__" unsafe
  78                 selectFrom__ :: ByteArray Int
  79                              -> ByteArray Int
  80                              -> ByteArray Int
  81                              -> Int
  82                              -> Int
  83                              -> IO Int
  84
  85 marshallTimeout :: Maybe Int -> IO Int
  86 marshallTimeout Nothing  = return (-1)
  87 marshallTimeout (Just x) = return (abs x)
  88
  89 getReadyOnes :: ByteArray Int -> [(Fd,Handle)] -> IO [Handle]
  90 getReadyOnes ba ls = do
  91   xs <- mapM isReady ls
  92   return (catMaybes xs)
  93  where
  94   isReady (f,h) = do
  95      let fi = fdToInt f
  96      flg <- is_fd_set ba fi
  97      if (flg /= 0) then
  98         return (Just h)
  99       else
 100         return Nothing
 101
 102 marshallFDs :: [(Fd,Handle)] -> IO (Int, ByteArray Int)
 103 marshallFDs ls = do
 104   ba <- stToIO (newCharArray (0, sizeof_fd_set))
 105   fd_zero ba
 106   let
 107    fillIn acc (f,_) = do
 108      let fi = fdToInt f
 109      fd_set ba fi
 110      return (max acc fi)
 111   x  <- foldM fillIn 0 ls
 112   ba <- stToIO (unsafeFreezeByteArray ba)
 113   return (x, ba)
 114
 115 foreign import "is_fd_set__" unsafe
 116                is_fd_set :: ByteArray Int -> Int -> IO Int
 117
 118 foreign import "fd_zero__" unsafe
 119                fd_zero :: MutableByteArray RealWorld Int -> IO ()
 120
 121 foreign import "fd_set__" unsafe
 122                fd_set :: MutableByteArray RealWorld Int -> Int -> IO ()
 123
 124 foreign import "sizeof_fd_set__" unsafe
 125                sizeof_fd_set :: Int
 126
 127 \end{code}