[usocket-cvs] r379 - in usocket/branches/new-wfi: . backend
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Tue Jul 22 23:06:15 UTC 2008
Author: ehuelsmann
Date: Tue Jul 22 19:06:15 2008
New Revision: 379
Modified:
usocket/branches/new-wfi/BRANCH-README
usocket/branches/new-wfi/backend/cmucl.lisp
usocket/branches/new-wfi/backend/sbcl.lisp
Log:
Tackle ECL w-f-i, new style. At the same time, simplify the backend greatly by having less inline C code.
Modified: usocket/branches/new-wfi/BRANCH-README
==============================================================================
--- usocket/branches/new-wfi/BRANCH-README (original)
+++ usocket/branches/new-wfi/BRANCH-README Tue Jul 22 19:06:15 2008
@@ -2,5 +2,4 @@
At least these backends are broken, for now:
- - ECL
- Scieneer
Modified: usocket/branches/new-wfi/backend/cmucl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/cmucl.lisp (original)
+++ usocket/branches/new-wfi/backend/cmucl.lisp Tue Jul 22 19:06:15 2008
@@ -166,24 +166,27 @@
(declare (ignore wait-list)))
(defun %add-waiter (wait-list waiter)
- (declare (ignore wait-list waiter)))
+ (declare (ignore wait-list waiter))
+ (push (socket waiter) (wait-list-%wait wait-list)))
(defun %remove-waiter (wait-list waiter)
- (declare (ignore wait-list waiter)))
+ (declare (ignore wait-list waiter))
+ (setf (wait-list-%wait wait-list)
+ (remove (socket waiter) (wait-list-%wait waiter))))
(defun wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(alien:with-alien ((rfds (alien:struct unix:fd-set)))
(unix:fd-zero rfds)
- (dolist (socket (wait-list-waiters wait-list))
- (unix:fd-set (socket socket) rfds))
+ (dolist (socket (wait-list-%wait wait-list))
+ (unix:fd-set socket rfds))
(multiple-value-bind
(secs musecs)
(split-timeout (or timeout 1))
(multiple-value-bind
(count err)
- (unix:unix-fast-select (1+ (reduce #'max (wait-list wait-list)
- :key #'socket))
+ (unix:unix-fast-select (1+ (reduce #'max
+ (wait-list-%wait wait-list)))
(alien:addr rfds) nil nil
(when timeout secs) musecs)
(if (<= 0 count)
Modified: usocket/branches/new-wfi/backend/sbcl.lisp
==============================================================================
--- usocket/branches/new-wfi/backend/sbcl.lisp (original)
+++ usocket/branches/new-wfi/backend/sbcl.lisp Tue Jul 22 19:06:15 2008
@@ -64,10 +64,37 @@
(ffi:c-inline () () :fixnum
"FD_SETSIZE" :one-liner t))
+ (defun fdset-alloc ()
+ (ffi:c-inline () () :pointer-void
+ "cl_alloc_atomic(sizeof(fd_set))" :one-liner t))
+
+ (defun fdset-zero (fdset)
+ (ffi:c-inline (fdset) (:pointer-void) :void
+ "FD_ZERO((fd_set*)#0)" :one-liner t))
+
+ (defun fdset-set (fdset fd)
+ (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+ "FD_SET(#1,(fd_set*)#0)" :one-liner t))
+
+ (defun fdset-clr (fdset fd)
+ (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
+ "FD_CLR(#1,(fd_set*)#0)" :one-liner t))
+
+ (defun fdset-fd-isset (fdset fd)
+ (ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
+ "FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
+
+ (declaim (inline fd-setsize
+ fdset-alloc
+ fdset-zero
+ fdset-set
+ fdset-clr
+ fdset-fd-isset))
+
(defun get-host-name ()
(ffi:c-inline
() () :object
- "{ char *buf = GC_malloc(256);
+ "{ char *buf = cl_alloc_atomic(257);
if (gethostname(buf,256) == 0)
@(return) = make_simple_base_string(buf);
@@ -75,61 +102,47 @@
@(return) = Cnil;
}" :one-liner nil :side-effects nil))
- (defun read-select (read-fds to-secs &optional (to-musecs 0))
- (ffi:c-inline (read-fds to-secs to-musecs) (t t :unsigned-int) t
- "{
- fd_set rfds;
- cl_object cur_fd = #0;
+ (defun read-select (wl to-secs &optional (to-musecs 0))
+ (let* ((sockets (wait-list-waiters wl))
+ (rfds (wait-list-%wait wl))
+ (max-fd (reduce #'(lambda (x y)
+ (let ((sy (sb-bsd-sockets:socket-file-descriptor
+ (socket y))))
+ (if (< x sy) sy x)))
+ (cdr sockets)
+ :initial-value (sb-bsd-sockets:socket-file-descriptor
+ (socket (car sockets))))))
+ (fdset-zero rfds)
+ (dolist (sock sockets)
+ (fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
+ (socket sock))))
+ (let ((count
+ (ffi:c-inline (to-secs to-musecs rfds max-fd)
+ (t :unsigned-int :pointer-void :int)
+ :int
+ "
int count;
- int max_fd = -1;
struct timeval tv;
- FD_ZERO(&rfds);
- while (CONSP(cur_fd)) {
- int fd = fixint(cur_fd->cons.car);
- max_fd = (max_fd > fd) ? max_fd : fd;
- FD_SET(fd, &rfds);
- cur_fd = cur_fd->cons.cdr;
- }
-
- if (#1 != Cnil) {
- tv.tv_sec = fixnnint(#1);
- tv.tv_usec = #2;
+ if (#0 != Cnil) {
+ tv.tv_sec = fixnnint(#0);
+ tv.tv_usec = #1;
}
- count = select(max_fd + 1, &rfds, NULL, NULL,
- (#1 != Cnil) ? &tv : NULL);
+ @(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL,
+ (#0 != Cnil) ? &tv : NULL);
+")))
+ (cond
+ ((= 0 count)
+ (values nil nil))
+ ((< count 0)
+ ;; check for EINTR and EAGAIN; these should not err
+ (values nil (ffi:c-inline () () :int "errno" :one-liner t)))
+ (t
+ (dolist (sock sockets)
+ (when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
+ (socket sock)))
+ (setf (state sock) :READ))))))))
- if (count == 0)
- @(return 0) = Cnil;
- @(return 1) = Cnil;
- else if (count < 0)
- /*###FIXME: We should be raising an error here...
-
- except, ofcourse in case of EINTR or EAGAIN */
-
- @(return 0) = Cnil;
- @(return 1) = MAKE_INTEGER(errno);
- else
- {
- cl_object rv = Cnil;
- cur_fd = #0;
-
- /* when we're going to use the same code on Windows,
- as well as unix, we can't be sure it'll fit into
- a fixnum: these aren't unix filehandle bitmaps sets on
- Windows... */
-
- while (CONSP(cur_fd)) {
- int fd = fixint(cur_fd->cons.car);
- if (FD_ISSET(fd, &rfds))
- rv = CONS(MAKE_INTEGER(fd), rv);
-
- cur_fd = cur_fd->cons.cdr;
- }
- @(return 0) = rv;
- @(return 1) = Cnil;
- }
-}"))
)
@@ -152,6 +165,7 @@
. operation-not-permitted-error)
(sb-bsd-sockets:protocol-not-supported-error
. protocol-not-supported-error)
+ #-ecl
(sb-bsd-sockets:unknown-protocol
. protocol-not-supported-error)
(sb-bsd-sockets:socket-type-not-supported-error
@@ -161,6 +175,7 @@
(sb-bsd-sockets:socket-error . ,#'map-socket-error)
;; Nameservice errors: mapped to unknown-error
+ #-ecl #-ecl #-ecl
(sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)
(sb-bsd-sockets:try-again-error . ns-try-again-condition)
(sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))
@@ -315,23 +330,25 @@
#+ecl
(progn
- (defun wait-for-input-internal (sockets &key timeout)
+ (defun wait-for-input-internal (wl &key timeout)
(with-mapped-conditions ()
(multiple-value-bind
- (secs usecs)
+ (secs usecs)
(split-timeout (or timeout 1))
- (let* ((sock-fds (mapcar #'sb-bsd-sockets:socket-file-descriptor
- (mapcar #'socket sockets))))
- (multiple-value-bind
- (result-fds err)
- (read-select sock-fds (when timeout secs) usecs)
- (if (null err)
- (remove-if #'(lambda (s)
- (not
- (member
- (sb-bsd-sockets:socket-file-descriptor
- (socket s))
- result-fds)))
- sockets)
- (error (map-errno-error err))))))))
+ (multiple-value-bind
+ (result-fds err)
+ (read-select wl (when timeout secs) usecs)
+ (unless (null err)
+ (error (map-errno-error err)))))))
+
+ (defun %setup-wait-list (wl)
+ (setf (wait-list-%wait wl)
+ (fdset-alloc)))
+
+ (defun %add-waiter (wl w)
+ (declare (ignore wl w)))
+
+ (defun %remove-waiter (wl w)
+ (declare (ignore wl w)))
+
)
More information about the usocket-cvs
mailing list