[slime-cvs] CVS update: slime/swank-sbcl.lisp

[Helmut Eller]

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

Modified Files:
	swank-sbcl.lisp 
Log Message:
(make-stream-interactive, *auto-flush-streams*)[sb-thread]: Spawn a
thread to flush interactive streams in reasonably short intervals.

Date: Sun Oct 23 09:49:08 2005
Author: heller

Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.146 slime/swank-sbcl.lisp:1.147
--- slime/swank-sbcl.lisp:1.146	Thu Sep 22 22:20:43 2005
+++ slime/swank-sbcl.lisp	Sun Oct 23 09:49:08 2005
@@ -1058,109 +1058,30 @@
                  (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
                                               mutex))))))))
 
-  )
 
-#+(and sb-thread
-       #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(or) '(and)))
-(progn
-  (defimplementation spawn (fn &key name)
-    (declare (ignore name))
-    (sb-thread:make-thread fn))
+  ;;; Auto-flush streams
 
-  (defimplementation startup-multiprocessing ())
-
-  (defimplementation thread-id (thread)
-    (assert (eql (ash (ash thread -5) 5) thread))
-    (ash thread -5))
-
-  (defimplementation find-thread (id)
-    (when (member (ash id 5) (all-threads))
-      (ash id 5)))
-  
-  (defimplementation thread-name (thread)
-    (format nil "Thread ~D" (thread-id thread)))
-
-  (defun %thread-state-slot (thread)
-    (sb-sys:without-gcing
-     (sb-kernel:make-lisp-obj
-      (sb-sys:sap-int
-       (sb-sys:sap-ref-sap (sb-thread::thread-sap-from-id thread)
-                           (* sb-vm::thread-state-slot
-                              sb-vm::n-word-bytes))))))
+  ;; XXX race conditions
+  (defvar *auto-flush-streams* '())
   
-  (defun %thread-state (thread)
-    (ecase (%thread-state-slot thread)
-      (0 :running)
-      (1 :stopping)
-      (2 :stopped)
-      (3 :dead)))
-
-  (defimplementation thread-status (thread)
-    (string (%thread-state thread)))
-
-  (defimplementation make-lock (&key name)
-    (sb-thread:make-mutex :name name))
-
-  (defimplementation call-with-lock-held (lock function)
-    (declare (type function function))
-    (sb-thread:with-mutex (lock) (funcall function)))
-
-  (defimplementation current-thread ()
-    (sb-thread:current-thread-id))
-
-  (defimplementation all-threads ()
-    (let ((tids (sb-sys:without-gcing
-                 (sb-thread::mapcar-threads
-                  (lambda (sap)
-                    (sb-sys:sap-ref-32 sap
-                                       (* sb-vm:n-word-bytes
-                                          sb-vm::thread-os-thread-slot)))))))
-      (remove :dead tids :key #'%thread-state)))
- 
-  (defimplementation interrupt-thread (thread fn)
-    (sb-thread:interrupt-thread thread fn))
-
-  (defimplementation kill-thread (thread)
-    (sb-thread:terminate-thread thread))
-
-  (defimplementation thread-alive-p (thread)
-    (ignore-errors (sb-thread:interrupt-thread thread (lambda ())) t))
-
-  (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
-  (defvar *mailboxes* (list))
-  (declaim (type list *mailboxes*))
-
-  (defstruct (mailbox (:conc-name mailbox.)) 
-    thread
-    (mutex (sb-thread:make-mutex))
-    (waitqueue  (sb-thread:make-waitqueue))
-    (queue '() :type list))
-
-  (defun mailbox (thread)
-    "Return THREAD's mailbox."
-    (sb-thread:with-mutex (*mailbox-lock*)
-      (or (find thread *mailboxes* :key #'mailbox.thread)
-          (let ((mb (make-mailbox :thread thread)))
-            (push mb *mailboxes*)
-            mb))))
-
-  (defimplementation send (thread message)
-    (let* ((mbox (mailbox thread))
-           (mutex (mailbox.mutex mbox)))
-      (sb-thread:with-mutex (mutex)
-        (setf (mailbox.queue mbox)
-              (nconc (mailbox.queue mbox) (list message)))
-        (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
+  (defvar *auto-flush-thread* nil)
 
-  (defimplementation receive ()
-    (let* ((mbox (mailbox (sb-thread:current-thread-id)))
-           (mutex (mailbox.mutex mbox)))
-      (sb-thread:with-mutex (mutex)
-        (loop
-         (let ((q (mailbox.queue mbox)))
-           (cond (q (return (pop (mailbox.queue mbox))))
-                 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
-                                              mutex))))))))
+  (defimplementation make-stream-interactive (stream)
+    (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
+    (unless *auto-flush-thread*
+      (setq *auto-flush-thread*
+            (sb-thread:make-thread #'flush-streams 
+                                   :name "auto-flush-thread"))))
+
+  (defun flush-streams ()
+    (loop
+     (setq *auto-flush-streams* 
+           (remove-if (lambda (x) 
+                        (not (and (open-stream-p x)
+                                  (output-stream-p x))))
+                      *auto-flush-streams*))
+     (mapc #'finish-output *auto-flush-streams*)
+     (sleep 0.15)))
 
   )