[usocket-cvs] r385 - in usocket/branches/0.4.x: . backend
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Sat Jul 26 21:54:21 UTC 2008
Author: ehuelsmann
Date: Sat Jul 26 17:54:21 2008
New Revision: 385
Modified:
usocket/branches/0.4.x/backend/allegro.lisp
usocket/branches/0.4.x/backend/armedbear.lisp
usocket/branches/0.4.x/backend/clisp.lisp
usocket/branches/0.4.x/backend/cmucl.lisp
usocket/branches/0.4.x/backend/lispworks.lisp
usocket/branches/0.4.x/backend/openmcl.lisp
usocket/branches/0.4.x/backend/sbcl.lisp
usocket/branches/0.4.x/backend/scl.lisp
usocket/branches/0.4.x/package.lisp
usocket/branches/0.4.x/usocket.lisp
Log:
Backport new-wfi branch to 0.4.x release branch.
Modified: usocket/branches/0.4.x/backend/allegro.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/allegro.lisp (original)
+++ usocket/branches/0.4.x/backend/allegro.lisp Sat Jul 26 17:54:21 2008
@@ -63,6 +63,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))))
@@ -127,18 +129,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/branches/0.4.x/backend/armedbear.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/armedbear.lisp (original)
+++ usocket/branches/0.4.x/backend/armedbear.lisp Sat Jul 26 17:54:21 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)
@@ -196,7 +197,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
@@ -245,6 +245,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")))
@@ -252,6 +254,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))))
@@ -349,20 +353,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")
@@ -376,7 +380,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))
@@ -385,33 +389,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/branches/0.4.x/backend/clisp.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/clisp.lisp (original)
+++ usocket/branches/0.4.x/backend/clisp.lisp Sat Jul 26 17:54:21 2008
@@ -1,4 +1,4 @@
-;;;; $Id$
+`;;;; $Id$
;;;; $URL$
;;;; See LICENSE for licensing information.
@@ -96,10 +96,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))
@@ -127,21 +131,32 @@
(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))))
Modified: usocket/branches/0.4.x/backend/cmucl.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/cmucl.lisp (original)
+++ usocket/branches/0.4.x/backend/cmucl.lisp Sat Jul 26 17:54:21 2008
@@ -97,11 +97,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))))
@@ -162,26 +166,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/branches/0.4.x/backend/lispworks.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/lispworks.lisp (original)
+++ usocket/branches/0.4.x/backend/lispworks.lisp Sat Jul 26 17:54:21 2008
@@ -117,9 +117,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))))
@@ -169,21 +173,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)))
;;;
@@ -228,6 +247,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)
@@ -272,7 +308,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
@@ -292,14 +328,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))
@@ -308,43 +336,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/branches/0.4.x/backend/openmcl.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/openmcl.lisp (original)
+++ usocket/branches/0.4.x/backend/openmcl.lisp Sat Jul 26 17:54:21 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+))))
@@ -104,6 +106,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))))
@@ -136,19 +140,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/branches/0.4.x/backend/sbcl.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/sbcl.lisp (original)
+++ usocket/branches/0.4.x/backend/sbcl.lisp Sat Jul 26 17:54:21 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 = cl_alloc_atomic(256);
+ "{ char *buf = cl_alloc_atomic(257);
if (gethostname(buf,256) == 0)
@(return) = make_simple_base_string(buf);
@@ -75,62 +102,46 @@
@(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(CAR(cur_fd));
- max_fd = (max_fd > fd) ? max_fd : fd;
- FD_SET(fd, &rfds);
- cur_fd = CDR(cur_fd);
- }
-
- 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);
-
- 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;
- }
-}"))
-
+ @(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))))))))
)
(defun map-socket-error (sock-err)
@@ -231,10 +242,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))))
@@ -270,13 +285,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)
@@ -284,7 +311,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)
@@ -293,12 +320,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...")
@@ -306,23 +332,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/branches/0.4.x/backend/scl.lisp
==============================================================================
--- usocket/branches/0.4.x/backend/scl.lisp (original)
+++ usocket/branches/0.4.x/backend/scl.lisp Sat Jul 26 17:54:21 2008
@@ -69,11 +69,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/branches/0.4.x/package.lisp
==============================================================================
--- usocket/branches/0.4.x/package.lisp (original)
+++ usocket/branches/0.4.x/package.lisp Sat Jul 26 17:54:21 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/branches/0.4.x/usocket.lisp
==============================================================================
--- usocket/branches/0.4.x/usocket.lisp (original)
+++ usocket/branches/0.4.x/usocket.lisp Sat Jul 26 17:54:21 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."))
@@ -195,10 +214,52 @@
, at 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.
@@ -208,33 +269,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))))
;;
;; IP(v4) utility functions
@@ -350,7 +416,7 @@
((vector t 4) (host-byte-order host))
(integer host))))
-;;
+;;ready-
;; Other utility functions
;;
@@ -374,7 +440,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).
@@ -391,7 +456,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
More information about the usocket-cvs
mailing list