[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