Author: ehuelsmann Date: Sat Jul 26 17:53:00 2008 New Revision: 384
Modified: usocket/trunk/backend/allegro.lisp usocket/trunk/backend/armedbear.lisp usocket/trunk/backend/clisp.lisp usocket/trunk/backend/cmucl.lisp usocket/trunk/backend/lispworks.lisp usocket/trunk/backend/openmcl.lisp usocket/trunk/backend/sbcl.lisp usocket/trunk/backend/scl.lisp usocket/trunk/package.lisp usocket/trunk/usocket.lisp Log: Backport new-wfi branch.
Modified: usocket/trunk/backend/allegro.lisp ============================================================================== --- usocket/trunk/backend/allegro.lisp (original) +++ usocket/trunk/backend/allegro.lisp Sat Jul 26 17:53:00 2008 @@ -68,6 +68,8 @@ ;; because socket-streams are also sockets. (defmethod socket-close ((usocket usocket)) "Close socket." + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket usocket))))
@@ -132,18 +134,29 @@ (list (hbo-to-vector-quad (socket:lookup-hostname (host-to-hostname name))))))
-(defun wait-for-input-internal (sockets &key timeout) +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (push (socket waiter) (wait-list-%wait wait-list))) + +(defun %remove-waiter (wait-list waiter) + (setf (wait-list-%wait wait-list) + (remove (socket waiter) (wait-list-%wait wait-list)))) + +(defun wait-for-input-internal (wait-list &key timeout) (with-mapped-conditions () (let ((active-internal-sockets (if timeout - (mp:wait-for-input-available (mapcar #'socket sockets) + (mp:wait-for-input-available (wait-list-%wait wait-list) :timeout timeout) - (mp:wait-for-input-available (mapcar #'socket sockets))))) + (mp:wait-for-input-available (wait-list-%wait wait-list))))) ;; this is quadratic, but hey, the active-internal-sockets ;; list is very short and it's only quadratic in the length of that one. ;; When I have more time I could recode it to something of linear ;; complexity. - ;; [Same code is also used in lispworks.lisp, openmcl.lisp] - (remove-if #'(lambda (x) - (not (member (socket x) active-internal-sockets))) - sockets)))) + ;; [Same code is also used in openmcl.lisp] + (dolist (x active-internal-sockets) + (setf (state (gethash x (wait-list-map wait-list))) + :READ)) + wait-list)))
Modified: usocket/trunk/backend/armedbear.lisp ============================================================================== --- usocket/trunk/backend/armedbear.lisp (original) +++ usocket/trunk/backend/armedbear.lisp Sat Jul 26 17:53:00 2008 @@ -88,6 +88,7 @@ (t (java:jclass-name (jop-class instance)))))
+(declaim (inline jop-deref)) (defun jop-deref (instance) (if (java-object-proxy-p instance) (jop-value instance) @@ -198,7 +199,6 @@ (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel" "open" sock-addr)) (sock (jdi:do-jmethod-call jchan "socket"))) - (describe sock) (setf usock (make-stream-socket :socket jchan @@ -247,6 +247,8 @@ ;; (print (jcall (jmethod "java.net.BindException" "getMessage") native-exception))))
(defmethod socket-close ((usocket usocket)) + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (jdi:do-jmethod (socket usocket) "close")))
@@ -254,6 +256,8 @@ ;; socket streams. Closing the stream flushes ;; its buffers *and* closes the socket. (defmethod socket-close ((usocket stream-usocket)) + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket-stream usocket))))
@@ -351,20 +355,20 @@ ((datagram-usocket-p socket) "java.nio.channels.DatagramChannel")))
-(defun wait-for-input-internal (sockets &key timeout) - (let* ((ops (logior (op-read) (op-accept))) +(defun wait-for-input-internal (wait-list &key timeout) + (let* ((sockets (wait-list-waiters wait-list)) + (ops (logior (op-read) (op-accept))) (selector (jdi:do-jstatic "java.nio.channels.Selector" "open")) (channels (mapcar #'socket sockets))) (unwind-protect (with-mapped-conditions () - (let ((jfalse (java:make-immediate-object nil :boolean)) - (sel (jdi:jop-deref selector))) + (let ((sel (jdi:jop-deref selector))) (dolist (channel channels) (let ((chan (jdi:jop-deref channel))) (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" "configureBlocking" "boolean") - chan jfalse) + chan (java:make-immediate-object nil :boolean)) (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" "register" "java.nio.channels.Selector" "int") @@ -378,7 +382,7 @@ ;; we actually have work to do (let* ((selkeys (jdi:do-jmethod selector "selectedKeys")) (selkey-iterator (jdi:do-jmethod selkeys "iterator")) - ready-sockets) + (%wait (wait-list-%wait wait-list))) (loop while (java:jcall (java:jmethod "java.util.Iterator" "hasNext") (jdi:jop-deref selkey-iterator)) @@ -387,33 +391,40 @@ "java.nio.channels.SelectionKey")) (chan (jdi:jop-deref (jdi:do-jmethod key "channel")))) - (push chan ready-sockets))) - (remove-if #'(lambda (s) - (not (member (jdi:jop-deref (socket s)) - ready-sockets - :test #'(lambda (x y) - (java:jcall (java:jmethod "java.lang.Object" - "equals" - "java.lang.Object") - x y))))) - sockets)))))) - ;; cancel all Selector registrations - (let* ((keys (jdi:do-jmethod selector "keys")) - (iter (jdi:do-jmethod keys "iterator"))) - (loop while (java:jcall (java:jmethod "java.util.Iterator" "hasNext") - (jdi:jop-deref iter)) - do (java:jcall - (java:jmethod "java.nio.channels.SelectionKey" "cancel") - (java:jcall (java:jmethod "java.util.Iterator" "next") - (jdi:jop-deref iter))))) - ;; close the selector + (setf (state (gethash chan %wait)) + :READ)))))))) + ;; close the selector: all keys will be deregistered (java:jcall (java:jmethod "java.nio.channels.Selector" "close") (jdi:jop-deref selector)) ;; make all sockets blocking again. - (let ((jtrue (java:make-immediate-object t :boolean))) - (dolist (chan channels) - (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" - "configureBlocking" - "boolean") - (jdi:jop-deref chan) jtrue)))))) + (dolist (channel channels) + (java:jcall (java:jmethod "java.nio.channels.SelectableChannel" + "configureBlocking" + "boolean") + (jdi:jop-deref channel) + (java:make-immediate-object t :boolean)))))) + + +;; +;; +;; +;; The WAIT-LIST part +;; + +;; +;; Note that even though Java has the concept of the Selector class, which +;; remotely looks like a wait-list, it requires the sockets to be non-blocking. +;; usocket however doesn't make any such guarantees and is therefore unable to +;; use the concept outside of the waiting routine itself (blergh!). +;; + +(defun %setup-wait-list (wl) + (setf (wait-list-%wait wl) + (make-hash-table :test #'equal :rehash-size 1.3d0))) + +(defun %add-waiter (wl w) + (setf (gethash (jdi:jop-deref (socket w)) (wait-list-%wait wl)) + w))
+(defun %remove-waiter (wl w) + (remhash (socket w) (wait-list-%wait wl))) \ No newline at end of file
Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Sat Jul 26 17:53:00 2008 @@ -101,10 +101,14 @@ ;; are the same object (defmethod socket-close ((usocket usocket)) "Close socket." + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket usocket))))
(defmethod socket-close ((usocket stream-server-usocket)) + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (socket:socket-server-close (socket usocket)))
(defmethod get-local-name ((usocket usocket)) @@ -132,23 +136,34 @@ (nth-value 1 (get-peer-name usocket)))
-(defmethod wait-for-input-internal (sockets &key timeout) +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (push (cons (socket waiter) NIL) (wait-list-%wait wait-list))) + +(defun %remove-waiter (wait-list waiter) + (setf (wait-list-%wait wait-list) + (remove (socket waiter) (wait-list-%wait wait-list) :key #'car))) + +(defmethod wait-for-input-internal (wait-list &key timeout) (with-mapped-conditions () (multiple-value-bind (secs musecs) (split-timeout (or timeout 1)) - (let* ((request-list (mapcar #'(lambda (x) - (if (stream-server-usocket-p x) - (socket x) - (list (socket x) :input))) - sockets)) + (dolist (x (wait-list-%wait wait-list)) + (setf (cdr x) :INPUT)) + (let* ((request-list (wait-list-%wait wait-list)) (status-list (if timeout (socket:socket-status request-list secs musecs) - (socket:socket-status request-list)))) - (remove nil - (mapcar #'(lambda (x y) - (when y x)) - sockets status-list)))))) + (socket:socket-status request-list))) + (sockets (wait-list-waiters wait-list))) + (do* ((x (pop sockets) (pop sockets)) + (y (pop status-list) (pop status-list))) + ((null x)) + (when (eq y :INPUT) + (setf (state x) :READ))) + wait-list))))
;; @@ -221,6 +236,8 @@ rv))
(defmethod socket-close ((usocket datagram-usocket)) + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (rawsock:sock-close (socket usocket)))
)
Modified: usocket/trunk/backend/cmucl.lisp ============================================================================== --- usocket/trunk/backend/cmucl.lisp (original) +++ usocket/trunk/backend/cmucl.lisp Sat Jul 26 17:53:00 2008 @@ -99,11 +99,15 @@ ;; socket stream when closing a stream socket. (defmethod socket-close ((usocket stream-usocket)) "Close socket." + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket-stream usocket))))
(defmethod socket-close ((usocket usocket)) "Close socket." + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (ext:close-socket (socket usocket))))
@@ -164,26 +168,38 @@ (defun get-host-name () (unix:unix-gethostname))
-(defun wait-for-input-internal (sockets &key timeout) +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (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)) + (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 sockets) - (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 sockets - :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) ;; process the result... - (remove-if #'(lambda (x) - (not (unix:fd-isset (socket x) rfds))) - sockets) + (dolist (x (wait-list-waiters wait-list)) + (when (unix:fd-isset (socket x) rfds) + (setf (state x) :READ))) (progn ;;###FIXME generate an error, except for EINTR )))))))
Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sat Jul 26 17:53:00 2008 @@ -119,9 +119,13 @@ ;; are correctly flushed and the socket closed. (defmethod socket-close ((usocket stream-usocket)) "Close socket." + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (close (socket-stream usocket)))
(defmethod socket-close ((usocket usocket)) + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (comm::close-socket (socket usocket))))
@@ -171,21 +175,36 @@ ;;;
#-win32 -(defun wait-for-input-internal (sockets &key timeout) - (with-mapped-conditions () - ;; unfortunately, it's impossible to share code between - ;; non-win32 and win32 platforms... - ;; Can we have a sane -pref. complete [UDP!?]- API next time, please? - (dolist (x sockets) - (mp:notice-fd (os-socket-handle x))) - (mp:process-wait-with-timeout "Waiting for a socket to become active" - (truncate timeout) - #'(lambda (socks) - (some #'usocket-listen socks)) - sockets) - (dolist (x sockets) - (mp:unnotice-fd (os-socket-handle x))) - (remove nil (mapcar #'usocket-listen sockets)))) +(progn + + (defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + + (defun %add-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + + (defun %remove-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + + (defun wait-for-input-internal (wait-list &key timeout) + (with-mapped-conditions () + ;; unfortunately, it's impossible to share code between + ;; non-win32 and win32 platforms... + ;; Can we have a sane -pref. complete [UDP!?]- API next time, please? + (dolist (x (wait-list-waiters wait-list)) + (mp:notice-fd (os-socket-handle x))) + (mp:process-wait-with-timeout "Waiting for a socket to become active" + (truncate timeout) + #'(lambda (socks) + (let (rv) + (dolist (x socks rv) + (when (usocket-listen x) + (setf (state x) :READ + rv t))))) + (wait-list-waiters wait-list)) + (dolist (x (wait-list-waiters wait-list)) + (mp:unnotice-fd (os-socket-handle x))) + wait-list)))
;;; @@ -230,6 +249,23 @@
(defconstant fionread 1074030207)
+ + ;; Note: + ;; + ;; If special finalization has to occur for a given + ;; system resource (handle), an associated object should + ;; be created. A special cleanup action should be added + ;; to the system and a special cleanup action should + ;; be flagged on all objects created for resources like it + ;; + ;; We have 2 functions to do so: + ;; * hcl:add-special-free-action (function-symbol) + ;; * hcl:flag-special-free-action (object) + ;; + ;; Note that the special free action will be called on all + ;; objects which have been flagged for special free, so be + ;; sure to check for the right argument type! + (fli:define-foreign-type ws-socket () '(:unsigned :int)) (fli:define-foreign-type win32-handle () '(:unsigned :int)) (fli:define-c-struct wsa-network-events (network-events :long) @@ -274,7 +310,7 @@
;; Now that we have access to the system calls, this is the plan:
- ;; 1. Receive a list of sockets to listen to + ;; 1. Receive a wait-list with associated sockets to wait for ;; 2. Add all those sockets to an event handle ;; 3. Listen for an event on that handle (we have a LispWorks system:: internal for that) ;; 4. After listening, detect if there are errors @@ -294,14 +330,6 @@ (fli:dereference int-ptr) 0))))
- (defun add-socket-to-event (socket event-object) - (let ((events (etypecase socket - (stream-server-usocket (logior fd-connect fd-accept fd-close)) - (stream-usocket (logior fd-connect fd-read fd-oob fd-close))))) - (maybe-wsa-error - (wsa-event-select (os-socket-handle socket) event-object events) - socket))) - (defun socket-ready-p (socket) (if (typep socket 'stream-usocket) (< 0 (bytes-available-for-read socket)) @@ -310,43 +338,65 @@ (defun waiting-required (sockets) (notany #'socket-ready-p sockets))
- (defun wait-for-input-internal (sockets &key timeout) - (let ((event-object (wsa-event-create))) - (unwind-protect - (progn - (when (waiting-required sockets) - (dolist (socket sockets) - (add-socket-to-event socket event-object)) - (system:wait-for-single-object event-object - "Waiting for socket activity" timeout)) - (update-ready-slots sockets) - (sockets-ready sockets)) - (wsa-event-close event-object)))) + (defun wait-for-input-internal (wait-list &key timeout) + (when (waiting-required (wait-list-waiters wait-list)) + (system:wait-for-single-object (wait-list-%wait wait-list) + "Waiting for socket activity" timeout)) + (update-ready-and-state-slots (wait-list-waiters wait-list)))
+ (defun map-network-events (func network-events) (let ((event-map (fli:foreign-slot-value network-events 'network-events)) (error-array (fli:foreign-slot-pointer network-events 'error-code))) (unless (zerop event-map) (dotimes (i fd-max-events) - (unless (zerop (ldb (byte 1 i) event-map)) + (unless (zerop (ldb (byte 1 i) event-map)) ;;### could be faster with ash and logand? (funcall func (fli:foreign-aref error-array i)))))))
- (defun update-ready-slots (sockets) + (defun update-ready-and-state-slots (sockets) (dolist (socket sockets) - (unless (or (stream-usocket-p socket) ;; no need to check status for streams - (%ready-p socket)) ;; and sockets already marked ready - (multiple-value-bind - (rv network-events) - (wsa-enum-network-events (os-socket-handle socket) 0 t) - (if (zerop rv) + (if (or (and (stream-usocket-p socket) + (listen (socket-stream socket))) + (%ready-p socket)) + (setf (state socket) :READ) + (multiple-value-bind + (rv network-events) + (wsa-enum-network-events (os-socket-handle socket) 0 t) + (if (zerop rv) (map-network-events #'(lambda (err-code) (if (zerop err-code) - (setf (%ready-p socket) t) + (setf (%ready-p socket) t + (state socket) :READ) (raise-usock-err err-code socket))) network-events) (maybe-wsa-error rv socket))))))
- (defun sockets-ready (sockets) - (remove-if-not #'socket-ready-p sockets)) + + + ;; The wait-list part + + (defun free-wait-list (wl) + (when (wait-list-p wl) + (unless (null (wait-list-%wait wl)) + (wsa-event-close (wait-list-%wait wl))))) + + (hcl:add-special-free-action 'free-wait-list) + + (defun %setup-wait-list (wait-list) + (hcl:flag-special-free-action wait-list) + (setf (wait-list-%wait wait-list) (wsa-event-create))) + + (defun %add-waiter (wait-list waiter) + (let ((events (etypecase waiter + (stream-server-usocket (logior fd-connect fd-accept fd-close)) + (stream-usocket (logior fd-connect fd-read fd-oob fd-close))))) + (maybe-wsa-error + (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events) + waiter))) + + (defun %remove-waiter (wait-list waiter) + (maybe-wsa-error + (wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) 0) + waiter))
);; end of WIN32-block
Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Sat Jul 26 17:53:00 2008 @@ -32,21 +32,23 @@ (defun input-available-p (sockets &optional ticks-to-wait) (ccl::rletZ ((tv :timeval)) (ccl::ticks-to-timeval ticks-to-wait tv) + ;;### The trickery below can be moved to the wait-list now... (ccl::%stack-block ((infds ccl::*fd-set-size*)) (ccl::fd-zero infds) (let ((max-fd -1)) (dolist (sock sockets) - (let ((fd (openmcl-socket:socket-os-fd sock))) + (let ((fd (openmcl-socket:socket-os-fd (socket sock)))) (setf max-fd (max max-fd fd)) (ccl::fd-set fd infds))) (let* ((res (#_select (1+ max-fd) infds (ccl::%null-ptr) (ccl::%null-ptr) (if ticks-to-wait tv (ccl::%null-ptr))))) (when (> res 0) - (remove-if #'(lambda (x) - (not (ccl::fd-is-set (openmcl-socket:socket-os-fd x) - infds))) - sockets))))))) + (dolist (x sockets) + (when (ccl::fd-is-set (openmcl-socket:socket-os-fd (socket x)) + infds) + (setf (state x) :READ)))) + sockets)))))
(defun raise-error-from-id (condition-id socket real-condition) (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+)))) @@ -109,6 +111,8 @@ ;; and their associated objects are represented ;; by the same object. (defmethod socket-close ((usocket usocket)) + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket usocket))))
@@ -141,19 +145,23 @@ (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname (host-to-hostname name))))))
-(defun wait-for-input-internal (sockets &key timeout) + +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + +(defun %remove-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + +(defun wait-for-input-internal (wait-list &key timeout) (with-mapped-conditions () - (let* ((ticks-timeout (truncate (* (or timeout 1) ccl::*ticks-per-second*))) + (let* ((ticks-timeout (truncate (* (or timeout 1) + ccl::*ticks-per-second*))) (active-internal-sockets - (input-available-p (mapcar #'socket sockets) + (input-available-p (wait-list-waiters wait-list) (when timeout ticks-timeout)))) - ;; this is quadratic, but hey, the active-internal-sockets - ;; list is very short and it's only quadratic in the length of that one. - ;; When I have more time I could recode it to something of linear - ;; complexity. - ;; [Same code is also used in lispworks.lisp, allegro.lisp] - (remove-if #'(lambda (x) - (not (member (socket x) active-internal-sockets))) - sockets)))) + wait-list)))
Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sat Jul 26 17:53:00 2008 @@ -64,6 +64,33 @@ (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 @@ -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))) @@ -232,10 +247,14 @@ ;; different objects. Be sure to close the stream (which ;; closes the socket too) when closing a stream-socket. (defmethod socket-close ((usocket usocket)) + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (sb-bsd-sockets:socket-close (socket usocket))))
(defmethod socket-close ((usocket stream-usocket)) + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket-stream usocket))))
@@ -271,13 +290,25 @@ #+sbcl (progn #-win32 +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (push (socket waiter) (wait-list-%wait wait-list))) + +(defun %remove-waiter (wait-list waiter) + (setf (wait-list-%wait wait-list) + (remove (socket waiter) (wait-list-%wait wait-list)))) + + + (defun wait-for-input-internal (sockets &key timeout) (with-mapped-conditions () (sb-alien:with-alien ((rfds (sb-alien:struct sb-unix:fd-set))) (sb-unix:fd-zero rfds) - (dolist (socket sockets) + (dolist (socket (wait-list-%wait sockets)) (sb-unix:fd-set - (sb-bsd-sockets:socket-file-descriptor (socket socket)) + (sb-bsd-sockets:socket-file-descriptor socket) rfds)) (multiple-value-bind (secs musecs) @@ -285,7 +316,7 @@ (multiple-value-bind (count err) (sb-unix:unix-fast-select - (1+ (reduce #'max (mapcar #'socket sockets) + (1+ (reduce #'max (mapcar #'socket (wait-list-waiters sockets)) :key #'sb-bsd-sockets:socket-file-descriptor)) (sb-alien:addr rfds) nil nil (when timeout secs) musecs) @@ -294,12 +325,11 @@ (error (map-errno-error err))) (when (< 0 count) ;; process the result... - (remove-if - #'(lambda (x) - (not (sb-unix:fd-isset - (sb-bsd-sockets:socket-file-descriptor (socket x)) - rfds))) - sockets)))))))) + (dolist (x (wait-list-waiters sockets)) + (when (not (sb-unix:fd-isset + (sb-bsd-sockets:socket-file-descriptor (socket x)) + rfds)) + (setf (state x) :READ))))))))))
#+win32 (warn "wait-for-input not (yet!) supported...") @@ -307,23 +337,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))) + )
Modified: usocket/trunk/backend/scl.lisp ============================================================================== --- usocket/trunk/backend/scl.lisp (original) +++ usocket/trunk/backend/scl.lisp Sat Jul 26 17:53:00 2008 @@ -71,11 +71,15 @@ ;; are flushed and the socket is closed correctly afterwards. (defmethod socket-close ((usocket usocket)) "Close socket." + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (ext:close-socket (socket usocket))))
(defmethod socket-close ((usocket stream-usocket)) "Close socket." + (when (wait-list usocket) + (remove-waiter (wait-list usocket) usocket)) (with-mapped-conditions (usocket) (close (socket-stream usocket))))
Modified: usocket/trunk/package.lisp ============================================================================== --- usocket/trunk/package.lisp (original) +++ usocket/trunk/package.lisp Sat Jul 26 17:53:00 2008 @@ -15,7 +15,6 @@ #:socket-listen #:socket-accept #:socket-close - #:wait-for-input #:get-local-address #:get-peer-address #:get-local-port @@ -23,6 +22,12 @@ #:get-local-name #:get-peer-name
+ #:wait-for-input ; waiting for input-ready state (select() like) + #:make-wait-list + #:add-waiter + #:remove-waiter + #:remove-all-waiters + #:with-connected-socket ; convenience macros #:with-server-socket #:with-client-socket
Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Sat Jul 26 17:53:00 2008 @@ -15,7 +15,40 @@ ((socket :initarg :socket :accessor socket - :documentation "Implementation specific socket object instance.")) + :documentation "Implementation specific socket object instance.'") + (wait-list + :initform nil + :accessor wait-list + :documentation "WAIT-LIST the object is associated with.") + (state + :initform nil + :accessor state + :documentation "Per-socket return value for the `wait-for-input' function. + +The value stored in this slot can be any of + NIL - not ready + :READ - ready to read + :READ-WRITE - ready to read and write + :WRITE - ready to write + +The last two remain unused in the current version. +") + #+(and lispworks win32) + (%ready-p + :initform nil + :accessor %ready-p + :documentation "Indicates whether the socket has been signalled +as ready for reading a new connection. + +The value will be set to T by `wait-for-input-internal' (given the +right conditions) and reset to NIL by `socket-accept'. + +Don't modify this slot or depend on it as it is really intended +to be internal only. + +Note: Accessed, but not used for 'stream-usocket'. +" + )) (:documentation "The main socket class.
@@ -33,7 +66,7 @@ )) (:documentation "Stream socket class. - +' Contrary to other sockets, these sockets may be closed either with the `socket-close' method or by closing the associated stream (which can be retrieved with the `socket-stream' accessor).")) @@ -45,21 +78,7 @@ #+lispworks 'base-char :reader element-type :documentation "Default element type for streams created by -`socket-accept'.") - #+(and lispworks win32) - (%ready-p - :initform nil - :accessor %ready-p - :documentation "Indicates whether the socket has been signalled -as ready for reading a new connection. - -The value will be set to T by `wait-for-input-internal' (given the -right conditions) and reset to NIL by `socket-accept'. - -Don't modify this slot or depend on it as it is really intended -to be internal only. -" - )) +`socket-accept'.")) (:documentation "Socket which listens for stream connections to be initiated from remote sockets."))
@@ -201,10 +220,52 @@ ,@body))
-(defgeneric wait-for-input (socket-or-sockets - &key timeout) - (:documentation -"Waits for one or more streams to become ready for reading from +(defstruct (wait-list (:constructor %make-wait-list)) + %wait ;; implementation specific + waiters ;; the list of all usockets + map ;; maps implementation sockets to usockets + ) + +;; Implementation specific: +;; +;; %setup-wait-list +;; %add-waiter +;; %remove-waiter + +(declaim (inline %setup-wait-list + %add-waiter + %remove-waiter)) + +(defun make-wait-list (waiters) + (let ((wl (%make-wait-list))) + (setf (wait-list-map wl) (make-hash-table)) + (%setup-wait-list wl) + (dolist (x waiters) + (add-waiter wl x)) + wl)) + +(defun add-waiter (wait-list input) + (setf (gethash (socket input) (wait-list-map wait-list)) input + (wait-list input) wait-list) + (pushnew input (wait-list-waiters wait-list)) + (%add-waiter wait-list input)) + +(defun remove-waiter (wait-list input) + (%remove-waiter wait-list input) + (setf (wait-list-waiters wait-list) + (remove input (wait-list-waiters wait-list)) + (wait-list input) nil) + (remhash (socket input) (wait-list-map wait-list))) + +(defun remove-all-waiters (wait-list) + (dolist (waiter (wait-list-waiters wait-list)) + (%remove-waiter waiter)) + (setf (wait-list-waiters wait-list) nil) + (clrhash (wait-list-map wait-list))) + + +(defun wait-for-input (socket-or-sockets &key timeout ready-only) + "Waits for one or more streams to become ready for reading from the socket. When `timeout' (a non-negative real number) is specified, wait `timeout' seconds, or wait indefinitely when it isn't specified. A `timeout' value of 0 (zero) means polling. @@ -214,34 +275,38 @@ be returned for this value either when waiting timed out or when it was interrupted (EINTR). The second value is a real number indicating the time remaining within the timeout period or NIL if -none.")) - - -(defmethod wait-for-input (socket-or-sockets &key timeout) +none." + (unless (wait-list-p socket-or-sockets) + (let ((wl (make-wait-list (if (listp socket-or-sockets) + socket-or-sockets (list socket-or-sockets))))) + (multiple-value-bind + (socks to) + (wait-for-input wl :timeout timeout :ready-only ready-only) + (return-from wait-for-input + (values (if ready-only socks socket-or-sockets) to))))) (let* ((start (get-internal-real-time)) - (sockets (if (listp socket-or-sockets) - socket-or-sockets - (list socket-or-sockets))) - ;; retrieve a list of all sockets which are ready without waiting - (ready-sockets - (remove-if (complement #'(lambda (x) - (and (stream-usocket-p x) - (listen (socket-stream x))))) - sockets)) + (sockets-ready 0)) + (dolist (x (wait-list-waiters socket-or-sockets)) + (when (setf (state x) + (if (and (stream-usocket-p x) + (listen (socket-stream x))) + :READ NIL)) + (incf sockets-ready))) ;; the internal routine is responsibe for ;; making sure the wait doesn't block on socket-streams of - ;; which the socket isn't ready, but there's space left in the + ;; which theready- socket isn't ready, but there's space left in the ;; buffer - (result (wait-for-input-internal - sockets - :timeout (if (null ready-sockets) timeout 0)))) - (values (union ready-sockets result) - (when timeout - (let ((elapsed (/ (- (get-internal-real-time) start) - internal-time-units-per-second))) - (when (< elapsed timeout) - (- timeout elapsed))))))) - + (wait-for-input-internal socket-or-sockets + :timeout (if (zerop sockets-ready) timeout 0)) + (let ((to-result (when timeout + (let ((elapsed (/ (- (get-internal-real-time) start) + internal-time-units-per-second))) + (when (< elapsed timeout) + (- timeout elapsed)))))) + (values (if ready-only + (remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state) + socket-or-sockets) + to-result))))
;; ;; Data utility functions @@ -392,7 +457,7 @@ ((vector t 4) (host-byte-order host)) (integer host))))
-;; +;;ready- ;; Other utility functions ;;
@@ -416,7 +481,6 @@ ;; ;; (defun SOCKET-CONNECT (host port &key element-type) ..) ;; - (setf (documentation 'socket-connect 'function) "Connect to `host' on `port'. `host' is assumed to be a string or an IP address represented in vector notation, such as #(192 168 1 1). @@ -433,7 +497,7 @@ ;;###FIXME: extend with default-element-type (setf (documentation 'socket-listen 'function) "Bind to interface `host' on `port'. `host' should be the -representation of an interface address. The implementation is not +representation of an ready-interface address. The implementation is not required to do an address lookup, making no guarantees that hostnames will be correctly resolved. If `*wildcard-host*' is passed for `host', the socket will be bound to all available interfaces for the IPv4