[usocket-cvs] r588 - usocket/branches/0.5.x/backend

[Chun Tian (binghe)]

Author: ctian
Date: Mon Mar 21 21:46:46 2011
New Revision: 588

Log:
Fixes for "SBCL/Win32: finalizer problem, etc", by Anton Kovalenko <anton at sw4me.com>

Modified:
   usocket/branches/0.5.x/backend/sbcl.lisp

Modified: usocket/branches/0.5.x/backend/sbcl.lisp
==============================================================================
--- usocket/branches/0.5.x/backend/sbcl.lisp	(original)
+++ usocket/branches/0.5.x/backend/sbcl.lisp	Mon Mar 21 21:46:46 2011
@@ -199,6 +199,10 @@
                  (if usock-cond
                      (signal usock-cond :socket socket))))))
 
+;;; "The socket stream ends up with a bogus name as it is created before
+;;; the socket is connected, making things harder to debug than they need
+;;; to be." -- Nikodemus Siivola <nikodemus at random-state.net>
+
 (defvar *dummy-stream*
   (let ((stream (make-broadcast-stream)))
     (close stream)
@@ -291,16 +295,29 @@
         (sb-bsd-sockets:socket-close sock)
         (error c)))))
 
+;;; "2. SB-BSD-SOCKETS:SOCKET-ACCEPT method returns NIL for EAGAIN/EINTR,
+;;; instead of raising a condition. It's always possible for
+;;; SOCKET-ACCEPT on non-blocking socket to fail, even after the socket
+;;; was detected to be ready: connection might be reset, for example.
+;;;
+;;; "I had to redefine SOCKET-ACCEPT method of STREAM-SERVER-USOCKET to
+;;; handle this situation. Here is the redefinition:" -- Anton Kovalenko <anton at sw4me.com>
+
 (defmethod socket-accept ((socket stream-server-usocket) &key element-type)
   (with-mapped-conditions (socket)
-     (let ((sock (sb-bsd-sockets:socket-accept (socket socket))))
-       (make-stream-socket
-        :socket sock
-        :stream (sb-bsd-sockets:socket-make-stream
-                 sock
-                 :input t :output t :buffering :full
-                 :element-type (or element-type
-                                   (element-type socket)))))))
+    (let ((sock (sb-bsd-sockets:socket-accept (socket socket))))
+      (if sock
+	  (make-stream-socket
+	   :socket sock
+	   :stream (sb-bsd-sockets:socket-make-stream
+		    sock
+		    :input t :output t :buffering :full
+		    :element-type (or element-type
+				      (element-type socket))))
+
+	  ;; next time wait for event again if we had EAGAIN/EINTR
+	  ;; or else we'd enter a tight loop of failed accepts
+	  (setf (%ready-p socket) nil)))))
 
 ;; Sockets and their associated streams are modelled as
 ;; different objects. Be sure to close the stream (which
@@ -448,7 +465,15 @@
 
 #+(and sbcl win32)
 (progn
-  (sb-alien:define-alien-type ws-socket sb-alien:unsigned-int)
+  ;; "SOCKET is defined as intptr_t in Windows headers; however, WS-SOCKET
+  ;; is defined as unsigned-int, i.e. 32-bit even on 64-bit platform.  It
+  ;; seems to be a good thing to redefine WS-SOCKET as SB-ALIEN:SIGNED,
+  ;; which is always machine word-sized (exactly as intptr_t;
+  ;; N.B. as of Windows/x64, long and signed-long are 32-bit, and thus not
+  ;; enough -- potentially)."
+  ;; -- Anton Kovalenko <anton at sw4me.com>, Mar 22, 2011
+  (sb-alien:define-alien-type ws-socket sb-alien:signed)
+
   (sb-alien:define-alien-type ws-dword sb-alien:unsigned-long)
   (sb-alien:define-alien-type ws-event sb-alien::hinstance)
 
@@ -556,13 +581,33 @@
   (defun (setf os-wait-list-%wait) (value wait-list)
     (setf (sb-alien:deref (wait-list-%wait wait-list)) value))
 
+  ;; "Event handles are leaking in current SBCL backend implementation,
+  ;; because of SBCL-unfriendly usage of finalizers.
+  ;;
+  ;; "SBCL never calls a finalizer that closes over a finalized object: a
+  ;; reference from that closure prevents its collection forever. That's
+  ;; the case with USOCKET in %SETUP-WAIT-LIST.
+  ;;
+  ;; "I use the following redefinition of %SETUP-WAIT-LIST: 
+  ;;
+  ;; "Of course it may be rewritten with more clarity, but you can see the
+  ;; core idea: I'm closing over those components of WAIT-LIST that I need
+  ;; for finalization, not the wait-list itself. With the original
+  ;; %SETUP-WAIT-LIST, hunchentoot stops working after ~100k accepted
+  ;; connections; it doesn't happen with redefined %SETUP-WAIT-LIST."
+  ;;
+  ;; -- Anton Kovalenko <anton at sw4me.com>, Mar 22, 2011
+
   (defun %setup-wait-list (wait-list)
     (setf (wait-list-%wait wait-list) (sb-alien:make-alien ws-event))
     (setf (os-wait-list-%wait wait-list) (wsa-event-create))
     (sb-ext:finalize wait-list
-                     #'(lambda () (unless (null (wait-list-%wait wait-list))
-                                    (wsa-event-close (os-wait-list-%wait wait-list))
-                                    (sb-alien:free-alien (wait-list-%wait wait-list))))))
+		     (let ((event-handle (os-wait-list-%wait wait-list))
+			   (alien (wait-list-%wait wait-list)))
+		       #'(lambda ()
+			   (wsa-event-close event-handle)
+			   (unless (null alien)
+			     (sb-alien:free-alien alien))))))
 
   (defun %add-waiter (wait-list waiter)
     (let ((events (etypecase waiter