From 064567b95b91462ca310d1f94ef7df8646632e48 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Sat, 11 Sep 1999 16:49:03 +0000
Subject: [PATCH] [project @ 1999-09-11 16:49:02 by sof] Added hSelect
---
ghc/lib/misc/Select.lhs | 128 ++++++++++++++++++++++++++++++++
ghc/lib/misc/cbits/selectFrom.c | 72 ++++++++++++++++++
ghc/lib/misc/cbits/selectFrom.h | 21 ++++++
3 files changed, 221 insertions(+)
create mode 100644 ghc/lib/misc/Select.lhs
create mode 100644 ghc/lib/misc/cbits/selectFrom.c
create mode 100644 ghc/lib/misc/cbits/selectFrom.h
diff --git a/ghc/lib/misc/Select.lhs b/ghc/lib/misc/Select.lhs
new file mode 100644
index 000000000000..4fdf3ac7aaf0
--- /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
index 000000000000..55e6516ef34f
--- /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
index 000000000000..7504df051468
--- /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__ */
--
GitLab