[project @ 1999-09-11 16:49:02 by sof]

Added hSelect

diff --git a/ghc/lib/misc/Select.lhs b/ghc/lib/misc/Select.lhs
new file mode 100644 (file)
index 0000000..4fdf3ac
--- /dev/null
+++ b/ghc/lib/misc/Select.lhs
@@ -0,0 +1,128 @@
+%
+% (c) sof, 1999
+%
+
+Haskell wrapper for select() OS functionality. It's use
+shouldn't be all that common in a Haskell system that implements
+IO in such a way that's thread friendly, but still.
+
+\begin{code}
+{-# OPTIONS -#include "cbits/selectFrom.h" #-}
+module Select
+    (
+      hSelect     -- :: [Handle]
+                  -- -> [Handle]
+                 -- -> [Handle]
+                 -- -> TimeOut
+                 -- -> IO SelectResult
+    , TimeOut(..) -- type _ = Maybe Int
+    , SelectResult(..) 
+    ) where
+
+import Posix
+import GlaExts
+import IO
+import Monad
+import Maybe
+import PrelIOBase
+import PosixUtil (fdToInt)
+
+\end{code}
+
+This stuff should really be done using HDirect.
+
+\begin{code}
+type TimeOut
+ = Maybe Int
+    -- Nothing => wait indefinitely.
+    -- Just x | x >= 0    => block waiting for 'x' micro seconds.
+    --        | otherwise => block waiting for '-x' micro seconds.
+
+type SelectResult
+ = ([Handle], [Handle], [Handle])
+
+hSelect :: [Handle]  -- input/read handles
+        -> [Handle]  -- output/write handles
+       -> [Handle]  -- exceptional handles
+       -> TimeOut
+       -> IO SelectResult
+hSelect ins outs excps timeout = do
+     ins_         <- mapM getFd ins
+     outs_        <- mapM getFd outs
+     excps_       <- mapM getFd excps
+     (max_in,  fds_ins)   <- marshallFDs ins_
+     (max_out, fds_outs)  <- marshallFDs outs_
+     (max_excp,fds_excps) <- marshallFDs excps_
+     tout                 <- marshallTimeout timeout
+     let max_fd = max_in `max` max_out `max` max_excp
+     rc                <- selectFrom__ fds_ins
+                                      fds_outs
+                                      fds_excps
+                                      (max_fd+1) tout
+     if (rc /= 0)
+      then constructErrorAndFail "hSelect"
+      else
+         let 
+          -- thunk these so that we only pay unmarshalling costs if demanded.
+         ins_ready   = unsafePerformIO (getReadyOnes fds_ins ins_)
+          outs_ready  = unsafePerformIO (getReadyOnes fds_outs outs_)
+          excps_ready = unsafePerformIO (getReadyOnes fds_outs outs_)
+        in
+        return (ins_ready, outs_ready, excps_ready)
+
+getFd :: Handle -> IO (Fd,Handle)
+getFd h = do
+  f <- handleToFd h
+  return (f,h)
+
+foreign import "selectFrom__" 
+               selectFrom__ :: ByteArray Int
+                            -> ByteArray Int
+                            -> ByteArray Int
+                            -> Int
+                            -> Int
+                            -> IO Int
+
+marshallTimeout :: Maybe Int -> IO Int
+marshallTimeout Nothing  = return (-1)
+marshallTimeout (Just x) = return (abs x)
+
+getReadyOnes :: ByteArray Int -> [(Fd,Handle)] -> IO [Handle]
+getReadyOnes ba ls = do
+  xs <- mapM isReady ls
+  return (catMaybes xs)
+ where
+  isReady (f,h) = do
+     let fi = fdToInt f
+     flg <- is_fd_set ba fi
+     if (flg /= 0) then
+        return (Just h)
+      else 
+        return Nothing
+
+marshallFDs :: [(Fd,Handle)] -> IO (Int, ByteArray Int)
+marshallFDs ls = do
+  ba <- stToIO (newCharArray (0, sizeof_fd_set))
+  fd_zero ba
+  let
+   fillIn acc (f,_) = do
+     let fi = fdToInt f
+     fd_set ba fi
+     return (max acc fi)
+  x  <- foldM fillIn 0 ls
+  ba <- stToIO (unsafeFreezeByteArray ba)
+  return (x, ba)
+
+foreign import "is_fd_set__"
+              is_fd_set :: ByteArray Int -> Int -> IO Int
+
+foreign import "fd_zero__"
+              fd_zero :: MutableByteArray RealWorld Int -> IO ()
+
+foreign import "fd_set__"
+              fd_set :: MutableByteArray RealWorld Int -> Int -> IO ()
+
+foreign import "sizeof_fd_set__"
+              sizeof_fd_set :: Int
+
+\end{code}

diff --git a/ghc/lib/misc/cbits/selectFrom.c b/ghc/lib/misc/cbits/selectFrom.c
new file mode 100644 (file)
index 0000000..55e6516
--- /dev/null
+++ b/ghc/lib/misc/cbits/selectFrom.c
@@ -0,0 +1,72 @@
+/*
+ * (c) sof, 1999
+ *
+ * Stubs to help implement Select module.
+ */
+
+/* we're outside the realms of POSIX here... */
+#define NON_POSIX_SOURCE
+
+#include "Rts.h"
+#include "selectFrom.h"
+#include "stgio.h"
+
+# if defined(HAVE_SYS_TYPES_H)
+#  include <sys/types.h>
+# endif
+
+# ifdef HAVE_SYS_TIME_H
+#  include <sys/time.h>
+# endif
+
+
+/* Helpers for the Haskell-side unmarshalling */
+
+int
+sizeof_fd_set__()
+{
+ return (sizeof(fd_set));
+}
+
+void
+fd_zero__(StgByteArray a)
+{
+  FD_ZERO((fd_set*)a);
+}
+
+void
+fd_set__(StgByteArray a, StgInt fd)
+{
+  FD_SET(fd,(fd_set*)a);
+}
+
+int
+is_fd_set__(StgByteArray a, StgInt fd)
+{
+  return FD_ISSET(fd,(fd_set*)a);
+}
+
+StgInt
+selectFrom__( StgByteArray rfd
+            , StgByteArray wfd
+           , StgByteArray efd
+           , StgInt mFd
+           , StgInt tout
+           )
+{
+ int rc, i;
+ struct timeval tv;
+
+ if (tout != (-1)) {
+   tv.tv_sec = tout / 1000000;
+   tv.tv_usec = tout % 1000000;
+ }
+
+ while ((rc = select(mFd, (fd_set*)rfd, (fd_set*)wfd, (fd_set*)efd, (tout == -1 ? NULL : &tv))) < 0) {
+      if (errno != EINTR) {
+       break;
+      }
+ }
+ return 0;
+}
+

diff --git a/ghc/lib/misc/cbits/selectFrom.h b/ghc/lib/misc/cbits/selectFrom.h
new file mode 100644 (file)
index 0000000..7504df0
--- /dev/null
+++ b/ghc/lib/misc/cbits/selectFrom.h
@@ -0,0 +1,21 @@
+/*
+ * (c) sof, 1999
+ *
+ * Stubs to help implement Select module
+ */
+#ifndef __SELECTFROM_H__
+#define __SELECTFROM_H__
+
+extern StgInt sizeof_fd_set__();
+extern void fd_zero__(StgByteArray fds);
+extern void fd_set__(StgByteArray a, StgInt fd);
+extern StgInt is_fd_set__(StgByteArray a, StgInt fd);
+extern StgInt selectFrom__
+            ( StgByteArray rfd
+            , StgByteArray wfd
+           , StgByteArray efd
+           , StgInt mFd
+           , StgInt tout
+           );
+
+#endif /* __SELECTFROM_H__ */