[slime-cvs] CVS slime

[CVS User nsiivola]

Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv4418

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
sbcl: another run at WAIT-FOR-INPUT

  This is still disturbingly under-the-hood stuff, but at least we're using
  fewer internal symbols: drop poll() based solution, use SYSREAD-MAY-BLOCK-P
  in INPUT-READ-P instead.


--- /project/slime/cvsroot/slime/ChangeLog	2011/12/03 12:03:37	1.2260
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/03 15:31:08	1.2261
@@ -1,3 +1,9 @@
+2011-12-03  Nikodemus Siivola  <nikodemus at random-state.net>
+
+	* swank-sbcl.lisp (wait-for-input): Another go at this. Rip out POLL,
+	build on top of just INPUT-READY-P.
+	(input-ready-p): Outside Windows, use SYSREAD-MAY-BLOCK-P to check.
+
 2011-12-03  Gábor Melis  <mega at retes.hu>
 
 	* swank-allegro.lisp (set-default-initial-binding): In 9.0 alpha,
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/02 20:24:03	1.297
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2011/12/03 15:31:08	1.298
@@ -179,86 +179,30 @@
 
 (defvar *wait-for-input-called*)
 
-#+(or win32 os-provides-poll)
 (defimplementation wait-for-input (streams &optional timeout)
   (assert (member timeout '(nil t)))
   (when (boundp '*wait-for-input-called*)
     (setq *wait-for-input-called* t))
   (let ((*wait-for-input-called* nil))
     (loop
-     (let ((ready (remove-if-not #'input-ready-p streams)))
-       (when ready (return ready)))
-     (when (check-slime-interrupts) (return :interrupt))
-     (when *wait-for-input-called* (return :interrupt))
-     #+os-provides-poll
-     (let ((readable (poll streams () (ecase timeout 
-                                        ((nil) nil)
-                                        ((t) 0)))))
-       (when readable (return readable))
-       (when timeout (return nil)))
-
-     #-os-provides-poll
-     (progn
-       (when timeout (return nil))
-       (sleep 0.1)))))
-
-(defun fd-stream-input-buffer-empty-p (stream)
-  (let ((buffer (sb-impl::fd-stream-ibuf stream)))
-    (or (not buffer)
-        (= (sb-impl::buffer-head buffer)
-           (sb-impl::buffer-tail buffer)))))
-
-#+os-provides-poll
-(progn
-  (defun input-ready-p (stream)
-    (not (fd-stream-input-buffer-empty-p stream)))
-
-  (sb-alien:define-alien-type pollfd (sb-alien:struct sb-unix::pollfd))
-  (sb-alien:define-alien-routine ("poll" poll%) sb-alien:int
-    (descs (sb-alien:* pollfd)) (ndescs sb-alien:int) (millis sb-alien:int))
-
-  (defun poll (read-streams write-streams milliseconds)
-    (let* ((rlen (length read-streams))
-           (wlen (length write-streams))
-           (len (+ rlen wlen)))
-      (assert (< len 10))
-      (sb-alien:with-alien ((pollfds (sb-alien:array pollfd 10)))
-        (flet ((set-events (i stream flags)
-                 (symbol-macrolet ((pfd (sb-alien:deref pollfds i)))
-                   (setf (sb-alien:slot pfd 'sb-unix::fd)
-                         (sb-impl::fd-stream-fd stream))
-                   (setf (sb-alien:slot pfd 'sb-unix::events) flags)
-                   (setf (sb-alien:slot pfd 'sb-unix::revents) 0)))
-               (revents? (i)
-                 (let ((revents (sb-alien:slot (sb-alien:deref pollfds i)
-                                               'sb-unix::revents)))
-                   (not (zerop revents)))))
-          (declare (inline set-events revents?))
-          (loop with rflags = (logior sb-unix::pollin
-                                      #+linux #x2000 #|POLLRDHUP|#)
-                for i below rlen  for s in read-streams 
-                do (set-events i s rflags))
-          (loop for i from rlen below len  for s in write-streams 
-                do (set-events i s sb-unix::pollout))
-          (let* ((timeout (etypecase milliseconds
-                            (null -1)
-                            (integer milliseconds)))
-                 (code (poll% (sb-alien:addr (sb-alien:deref pollfds 0))
-                              len timeout))
-                 (errno (sb-alien:get-errno)))
-            (cond ((zerop code)
-                   (values () ()))
-                  ((plusp code)
-                   (values 
-                    (loop for i below rlen  for s in read-streams
-                          if (revents? i) collect s)
-                    (loop for i from rlen below len for s in write-streams
-                          if (revents? i) collect s)))
-                  ((= errno sb-posix:eintr)
-                   :interrupt)
-                  (t
-                   (error "~a" (sb-int:strerror errno)))))))))
-  )
+      (let ((ready (remove-if-not #'input-ready-p streams)))
+        (when ready (return ready)))
+      (when (check-slime-interrupts)
+        (return :interrupt))
+      (when *wait-for-input-called*
+        (return :interrupt))
+      (when timeout
+        (return nil))
+      (sleep 0.1))))
+
+#-win32
+(defun input-ready-p (stream)
+  (or (let ((buffer (sb-impl::fd-stream-ibuf stream)))
+        (when buffer
+          (= (sb-impl::buffer-head buffer)
+             (sb-impl::buffer-tail buffer))))
+      (eq :regular (sb-impl::fd-stream-fd-type stream))
+      (not (sb-impl::sysread-may-block-p stream))))
 
 #+win32
 (progn