Just a minute ago, I committed the change below to the new-WAIT-FOR-INPUT branch. Hans, I don't know which backend you were measuring your work with, but if it's in the set below, I would much appreciate it if you would take a look at the new functions added. I must admit not having tested much of the committed code, but if you could point out your favorite backend, I could test that so we can see if the api and implementation satisfy your speed requirements. (Ofcourse, with your commit access, you could do all that yourself, if you have time and the desire...) I hope to hear from you! Bye, Erik. ---------- Forwarded message ---------- From: <ehuelsmann@common-lisp.net> Date: Sun, Jun 15, 2008 at 11:17 PM Subject: [usocket-cvs] r343 - in usocket/branches/new-wfi: . backend To: usocket-cvs@common-lisp.net Author: ehuelsmann Date: Sun Jun 15 17:17:23 2008 New Revision: 343 Added: usocket/branches/new-wfi/BRANCH-README (contents, props changed) Modified: usocket/branches/new-wfi/backend/allegro.lisp usocket/branches/new-wfi/backend/clisp.lisp usocket/branches/new-wfi/backend/cmucl.lisp usocket/branches/new-wfi/backend/lispworks.lisp usocket/branches/new-wfi/backend/openmcl.lisp usocket/branches/new-wfi/usocket.lisp Log: Populate new-WAIT-FOR-INPUT branch with intended API. Added: usocket/branches/new-wfi/BRANCH-README ============================================================================== --- (empty file) +++ usocket/branches/new-wfi/BRANCH-README Sun Jun 15 17:17:23 2008 @@ -0,0 +1,8 @@ + + +At least these backends are broken, for now: + + - ABCL + - LispWorks (Win32) + - SBCL/ ECL + - Scieneer Modified: usocket/branches/new-wfi/backend/allegro.lisp ============================================================================== --- usocket/branches/new-wfi/backend/allegro.lisp (original) +++ usocket/branches/new-wfi/backend/allegro.lisp Sun Jun 15 17:17:23 2008 @@ -127,18 +127,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 wait-list))) + +(defun %remove-waiter (wait-list waiter) + (setf (%wait wait-list) + (remove (socket waiter) (%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 wait-list) :timeout timeout) - (mp:wait-for-input-available (mapcar #'socket sockets))))) + (mp:wait-for-input-available (%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-map wait-list))) + :READ)) + wait-list))) Modified: usocket/branches/new-wfi/backend/clisp.lisp ============================================================================== --- usocket/branches/new-wfi/backend/clisp.lisp (original) +++ usocket/branches/new-wfi/backend/clisp.lisp Sun Jun 15 17:17:23 2008 @@ -127,23 +127,33 @@ (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 wait-list))) + +(defun %remove-waiter (wait-list waiter) + (setf (%wait wait-list) + (remove (socket waiter) (%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)) - (status-list (if timeout + (dolist (x (%wait wait-list)) + (setf (cdr x) :INPUT)) + (let* ((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 wait-list))) + (do* ((x (pop sockets) (pop sockets)) + (y (pop status-list) (pop status-list))) + ((or (null sockets) (null status-list))) + (when y + (setf (state x) :READ))) + wait-list)))) ;; Modified: usocket/branches/new-wfi/backend/cmucl.lisp ============================================================================== --- usocket/branches/new-wfi/backend/cmucl.lisp (original) +++ usocket/branches/new-wfi/backend/cmucl.lisp Sun Jun 15 17:17:23 2008 @@ -162,26 +162,35 @@ (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))) + +(defun %remove-waiter (wait-list waiter) + (declare (ignore wait-list 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) + (dolist (socket (wait-list wait-list)) (unix:fd-set (socket 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 + (unix:unix-fast-select (1+ (reduce #'max (wait-list wait-list) :key #'socket)) (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 wait-list)) + (when (unix:fd-isset (socket x) rfds) + (setf (state x) :READ))) (progn ;;###FIXME generate an error, except for EINTR ))))))) Modified: usocket/branches/new-wfi/backend/lispworks.lisp ============================================================================== --- usocket/branches/new-wfi/backend/lispworks.lisp (original) +++ usocket/branches/new-wfi/backend/lispworks.lisp Sun Jun 15 17:17:23 2008 @@ -169,21 +169,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 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 wait-list)) + (dolist (x (wait-list wait-list)) + (mp:unnotice-fd (os-socket-handle x))) + wait-list))) ;;; Modified: usocket/branches/new-wfi/backend/openmcl.lisp ============================================================================== --- usocket/branches/new-wfi/backend/openmcl.lisp (original) +++ usocket/branches/new-wfi/backend/openmcl.lisp Sun Jun 15 17:17:23 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+)))) @@ -136,19 +138,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 (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/new-wfi/usocket.lisp ============================================================================== --- usocket/branches/new-wfi/usocket.lisp (original) +++ usocket/branches/new-wfi/usocket.lisp Sun Jun 15 17:17:23 2008 @@ -15,7 +15,20 @@ ((socket :initarg :socket :accessor socket - :documentation "Implementation specific socket object instance.")) + :documentation "Implementation specific socket object instance.'") + (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. +")) (:documentation "The main socket class. @@ -33,7 +46,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).")) @@ -201,10 +214,46 @@ ,@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 + wait-list ;; the list of all usockets + wait-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-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-map wait-list)) input) + (pushnew input (wait-list wait-list)) + (%add-waiter wait-list input)) + +(defun remove-waiter (wait-list input) + (%remove-waiter wait-list input) + (setf (wait-list wait-list) + (remove input (wait-list wait-list))) + (remhash (socket input) (wait-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,46 +263,51 @@ 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)) + nil))) + (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 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 socket-or-sockets) :key #'state) + socket-or-sockets) + to-result)))) ;; ;; Data utility functions ;; -(defun integer-to-octet-buffer (integer buffer octets &key (start 0)) +(defun integer-to-octready-et-buffer (integer buffer octets &key (start 0)) (do ((b start (1+ b)) (i (ash (1- octets) 3) ;; * 8 (- i 8))) ((> 0 i) buffer) (setf (aref buffer b) - (ldb (byte 8 i) integer)))) + (ldb (byteready- 8 i) integer)))) (defun octet-buffer-to-integer (buffer octets &key (start 0)) (let ((integer 0)) @@ -369,7 +423,7 @@ (when hosts (elt hosts (random (length hosts)))))) - (defun host-to-vector-quad (host) + (defun host-toready--vector-quad (host) "Translate a host specification (vector quad, dotted quad or domain name) to a vector quad." (etypecase host @@ -392,7 +446,7 @@ ((vector t 4) (host-byte-order host)) (integer host)))) -;; +;;ready- ;; Other utility functions ;; @@ -416,7 +470,7 @@ ;; ;; (defun SOCKET-CONNECT (host port &key element-type) ..) ;; - +ready-ready- (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 +487,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 @@ -447,4 +501,4 @@ streams to be created by `socket-accept'. `reuseaddress' is supported for backward compatibility (but deprecated); when both `reuseaddress' and `reuse-address' have been specified, the latter takes precedence. -") +")ready-ready- _______________________________________________ usocket-cvs mailing list usocket-cvs@common-lisp.net http://common-lisp.net/cgi-bin/mailman/listinfo/usocket-cvs