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-