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))) + )