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@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@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@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@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@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