[slime-cvs] CVS slime
heller
heller at common-lisp.net
Sun Sep 14 17:10:35 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv30540
Modified Files:
ChangeLog slime.el swank-backend.lisp swank-clisp.lisp
swank-cmucl.lisp swank.lisp
Log Message:
Introduce a WAIT-FOR-INPUT backend function.
CMUCL's blocking input functions READ-CHAR etc.
are hard to use with interrupts. In the backend
we have a more realistic chance to get interrupts working.
* swank-backend.lisp (wait-for-input): New function.
* swank-cmucl.lisp, swank-clisp.lisp (wait-for-input): Implement
it.
* swank.lisp (wait-for-event/event-loop): Use WAIT-FOR-INPUT and
rescan the event-queue if WAIT-FOR-INPUT was interrupted.
(reader-event): Deleted. Merged into wait-for-event/event-loop
resp. dispatch-loop.
(decode-message): Drop the timeout argument.
(*events-enqueued*): A counter to quickly detect new events after
a wait.
(call-with-connection): If the argument is already the current
connection, don't rebind anything.
(without-slime-interrupts, with-slime-interrupts): Don't rebind
*pending-slime-interrupts*. Just to be save.
* slime.el (sldb-maybe-kill-buffer): New function, to handle
the case when the debugger was interrupted in WAIT-FOR-INPUT and
we want to return to the previous debug level.
--- /project/slime/cvsroot/slime/ChangeLog 2008/09/12 18:55:42 1.1504
+++ /project/slime/cvsroot/slime/ChangeLog 2008/09/14 17:10:34 1.1505
@@ -1,3 +1,31 @@
+2008-09-14 Helmut Eller <heller at common-lisp.net>
+
+ Introduce a WAIT-FOR-INPUT backend function.
+ CMUCL's blocking input functions READ-CHAR etc.
+ are hard to use with interrupts. In the backend
+ we have a more realistic chance to get interrupts working.
+
+ * swank-backend.lisp (wait-for-input): New function.
+
+ * swank-cmucl.lisp, swank-clisp.lisp (wait-for-input): Implement
+ it.
+
+ * swank.lisp (wait-for-event/event-loop): Use WAIT-FOR-INPUT and
+ rescan the event-queue if WAIT-FOR-INPUT was interrupted.
+ (reader-event): Deleted. Merged into wait-for-event/event-loop
+ resp. dispatch-loop.
+ (decode-message): Drop the timeout argument.
+ (*events-enqueued*): A counter to quickly detect new events after
+ a wait.
+ (call-with-connection): If the argument is already the current
+ connection, don't rebind anything.
+ (without-slime-interrupts, with-slime-interrupts): Don't rebind
+ *pending-slime-interrupts*. Just to be save.
+
+ * slime.el (sldb-maybe-kill-buffer): New function, to handle
+ the case when the debugger was interrupted in WAIT-FOR-INPUT and
+ we want to return to the previous debug level.
+
2008-09-12 Helmut Eller <heller at common-lisp.net>
For Lispworks, parse the $LWHOME/lwdoc file.
--- /project/slime/cvsroot/slime/slime.el 2008/09/12 15:51:02 1.1013
+++ /project/slime/cvsroot/slime/slime.el 2008/09/14 17:10:34 1.1014
@@ -2347,7 +2347,7 @@
(funcall (cdr rec) value))
(t
(error "Unexpected reply: %S %S" id value)))))
- ((:debug-activate thread level select)
+ ((:debug-activate thread level &optional select)
(assert thread)
(sldb-activate thread level select))
((:debug thread level condition restarts frames conts)
@@ -6807,8 +6807,24 @@
(let ((inhibit-read-only t))
(erase-buffer))
(setq sldb-level nil))
- (when (and (= level 1) (not stepping))
- (kill-buffer sldb))))
+ (cond ((and (= level 1) (not stepping))
+ (kill-buffer sldb))
+ (t (sldb-maybe-kill-buffer thread (slime-connection))))))
+
+;; If we return to a lower debug level we wait a little before closing
+;; the debugger window. We also send a ping, just in case Lisp was
+;; interrupted in swank:wait-for-input.
+(defun sldb-maybe-kill-buffer (thread connection)
+ (slime-eval-async `(swank:ping nil))
+ (run-with-idle-timer
+ 0.3 nil
+ (lambda (thead connection)
+ (when-let (sldb (sldb-find-buffer thread connection))
+ (with-current-buffer sldb
+ (when (not sldb-level)
+ (kill-buffer sldb)))))
+ thread connection))
+
;;;;;; SLDB buffer insertion
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/09/12 12:27:38 1.151
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/09/14 17:10:34 1.152
@@ -1027,16 +1027,44 @@
(definterface receive-if (predicate &optional timeout)
"Return the first message satisfiying PREDICATE.")
-(defvar *pending-slime-interrupts*)
+(defvar *pending-slime-interrupts* '())
(defun check-slime-interrupts ()
"Execute pending interrupts if any.
This should be called periodically in operations which
can take a long time to complete."
- (when (and (boundp '*pending-slime-interrupts*)
- *pending-slime-interrupts*)
+ (when (and *pending-slime-interrupts*)
(funcall (pop *pending-slime-interrupts*))))
+(definterface wait-for-input (streams &optional timeout)
+ "Wait for input on a list of streams. Return those that are ready.
+STREAMS is a list of streams
+TIMEOUT nil, t, or real number. If TIMEOUT is t, return
+those streams which are ready immediately, without waiting.
+If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
+return nil.
+
+Return :interrupt if an interrupt occurs while waiting."
+ (assert (= (length streams) 1))
+ (let ((stream (car streams)))
+ (case timeout
+ ((nil)
+ (cond (*pending-slime-interrupts* :interrupt)
+ (t (peek-char nil stream nil nil)
+ streams)))
+ ((t)
+ (let ((c (read-char-no-hang stream nil nil)))
+ (cond (c
+ (unread-char c stream)
+ streams)
+ (t '()))))
+ (t
+ (loop
+ (if *pending-slime-interrupts* (return :interrupt))
+ (when (wait-for-input streams t) (return streams))
+ (sleep 0.1)
+ (when (<= (decf timeout 0.1) 0) (return nil)))))))
+
(definterface toggle-trace (spec)
"Toggle tracing of the function(s) given with SPEC.
SPEC can be:
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/09/12 12:27:38 1.75
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/09/14 17:10:34 1.76
@@ -104,6 +104,8 @@
(lambda (c)
(declare (ignore c))
(funcall handler)
+ (when (find-restart 'socket-status)
+ (invoke-restart (find-restart 'socket-status)))
(continue))))
(funcall function)))
@@ -134,6 +136,22 @@
:element-type 'character
:external-format external-format))
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
+ (loop
+ (cond (*pending-slime-interrupts* (return :interrupt))
+ (timeout
+ (socket:socket-status streams 0 0)
+ (return (loop for (s _ . x) in streams
+ if x collect s)))
+ (t
+ (with-simple-restart (socket-status "Return from socket-status.")
+ (socket:socket-status streams 0 500000))
+ (let ((ready (loop for (s _ . x) in streams
+ if x collect s)))
+ (when ready (return ready))))))))
+
;;;; Coding systems
(defvar *external-format-to-coding-system*
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/09/12 12:27:38 1.193
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/09/14 17:10:34 1.194
@@ -192,6 +192,30 @@
(defimplementation remove-fd-handlers (socket)
(sys:invalidate-descriptor (socket-fd socket)))
+(defimplementation wait-for-input (streams &optional timeout)
+ (assert (member timeout '(nil t)))
+ (loop
+ (let ((ready (remove-if-not #'listen streams)))
+ (when ready (return ready)))
+ (when timeout (return nil))
+ (if *pending-slime-interrupts* (return :interrupt))
+ (let* ((f (constantly t))
+ (handlers (loop for s in streams
+ collect (add-one-shot-handler s f))))
+ (unwind-protect
+ (sys:serve-event 0.2)
+ (mapc #'sys:remove-fd-handler handlers)))))
+
+(defun add-one-shot-handler (stream function)
+ (let (handler)
+ (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input
+ (lambda (fd)
+ (declare (ignore fd))
+ (sys:remove-fd-handler handler)
+ (funcall function stream))))))
+
+
+
;;;; Stream handling
;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004)
--- /project/slime/cvsroot/slime/swank.lisp 2008/09/12 12:27:37 1.586
+++ /project/slime/cvsroot/slime/swank.lisp 2008/09/14 17:10:34 1.587
@@ -285,6 +285,9 @@
"Return the value of *SWANK-STATE-STACK*."
*swank-state-stack*)
+(defslimefun ping (tag)
+ tag)
+
;; A conditions to include backtrace information
(define-condition swank-error (error)
((condition :initarg :condition :reader swank-error.condition)
@@ -342,18 +345,18 @@
(defmacro with-slime-interrupts (&body body)
`(progn
(check-slime-interrupts)
- (let ((*slime-interrupts-enabled* t)
- (*pending-slime-interrupts* '()))
- (multiple-value-prog1 (progn , at body)
- (check-slime-interrupts)))))
+ (multiple-value-prog1
+ (let ((*slime-interrupts-enabled* t))
+ , at body)
+ (check-slime-interrupts))))
(defmacro without-slime-interrupts (&body body)
`(progn
(check-slime-interrupts)
- (let ((*slime-interrupts-enabled* nil)
- (*pending-slime-interrupts* '()))
- (multiple-value-prog1 (progn , at body)
- (check-slime-interrupts)))))
+ (multiple-value-prog1
+ (let ((*slime-interrupts-enabled* t))
+ , at body)
+ (check-slime-interrupts))))
(defun invoke-or-queue-interrupt (function)
(log-event "invoke-or-queue-interrupt: ~a" function)
@@ -362,11 +365,14 @@
(funcall function)))
(*slime-interrupts-enabled*
(funcall function))
- ((cdr *pending-slime-interrupts*)
- (simple-break "Two many queued interrupts"))
(t
- (log-event "queue-interrupt: ~a" function)
- (push function *pending-slime-interrupts*))))
+ (setq *pending-slime-interrupts*
+ (nconc *pending-slime-interrupts*
+ (list function)))
+ (cond ((cdr *pending-slime-interrupts*)
+ (check-slime-interrupts))
+ (t
+ (log-event "queue-interrupt: ~a" function))))))
(defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
(with-simple-restart (continue "Continue from break.")
@@ -393,11 +399,13 @@
`(call-with-connection ,connection (lambda () , at body)))
(defun call-with-connection (connection function)
- (let ((*emacs-connection* connection))
- (without-slime-interrupts
- (with-swank-error-handler (*emacs-connection*)
- (with-io-redirection (*emacs-connection*)
- (call-with-debugger-hook #'swank-debugger-hook function))))))
+ (if (eq *emacs-connection* connection)
+ (funcall function)
+ (let ((*emacs-connection* connection))
+ (without-slime-interrupts
+ (with-swank-error-handler (*emacs-connection*)
+ (with-io-redirection (*emacs-connection*)
+ (call-with-debugger-hook #'swank-debugger-hook function)))))))
(defun call-with-retry-restart (msg thunk)
(let ((%ok (gensym "OK+"))
@@ -991,7 +999,7 @@
(defun dispatch-loop (connection)
(let ((*emacs-connection* connection))
(with-panic-handler (connection)
- (loop (dispatch-event (read-event))))))
+ (loop (dispatch-event (receive))))))
(defvar *auto-flush-interval* 0.2)
@@ -1088,15 +1096,14 @@
(current-socket-io)))))
(defvar *event-queue* '())
+(defvar *events-enqueued* 0)
(defun send-event (thread event)
(log-event "send-event: ~s ~s~%" thread event)
(cond ((use-threads-p) (send thread event))
- (t (setf *event-queue* (nconc *event-queue* (list event))))))
-
-(defun read-event (&optional timeout)
- (cond ((use-threads-p) (receive timeout))
- (t (decode-message (current-socket-io) timeout))))
+ (t (setf *event-queue* (nconc *event-queue* (list event)))
+ (setf *events-enqueued* (mod (1+ *events-enqueued*)
+ most-positive-fixnum)))))
(defun send-to-emacs (event)
"Send EVENT to Emacs."
@@ -1112,25 +1119,37 @@
(defun wait-for-event (pattern &optional timeout)
(log-event "wait-for-event: ~s ~s~%" pattern timeout)
- (cond ((use-threads-p)
- (without-slime-interrupts
- (receive-if (lambda (e) (event-match-p e pattern)) timeout)))
- (t
- (wait-for-event/event-loop pattern timeout))))
+ (without-slime-interrupts
+ (cond ((use-threads-p)
+ (receive-if (lambda (e) (event-match-p e pattern)) timeout))
+ (t
+ (wait-for-event/event-loop pattern timeout)))))
(defun wait-for-event/event-loop (pattern timeout)
(assert (or (not timeout) (eq timeout t)))
(loop
(check-slime-interrupts)
- (let ((tail (member-if (lambda (e) (event-match-p e pattern))
- *event-queue*)))
- (when tail
- (setq *event-queue*
- (nconc (ldiff *event-queue* tail) (cdr tail)))
- (return (car tail))))
- (multiple-value-bind (event timeout?) (read-event timeout)
- (when timeout? (return (values nil t)))
- (dispatch-event event))))
+ (let ((event (poll-for-event pattern)))
+ (when event (return (car event))))
+ (let ((events-enqueued *events-enqueued*)
+ (ready (wait-for-input (list (current-socket-io)) timeout)))
+ (cond ((and timeout (not ready))
+ (return (values nil t)))
+ ((or (/= events-enqueued *events-enqueued*)
+ (eq ready :interrupt))
+ ;; rescan event queue, interrupts may enqueue new events
+ )
+ (t
+ (assert (equal ready (list (current-socket-io))))
+ (dispatch-event (decode-message (current-socket-io))))))))
+
+(defun poll-for-event (pattern)
+ (let ((tail (member-if (lambda (e) (event-match-p e pattern))
+ *event-queue*)))
+ (when tail
+ (setq *event-queue* (nconc (ldiff *event-queue* tail)
+ (cdr tail)))
+ tail)))
(defun event-match-p (event pattern)
(cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
@@ -1209,9 +1228,12 @@
(invoke-or-queue-interrupt
(lambda ()
(with-connection (connection)
- (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))))))
+ (dispatch-interrupt-event)))))))
(handle-or-process-requests connection))
+(defun dispatch-interrupt-event ()
+ (dispatch-event `(:emacs-interrupt ,(current-thread-id))))
+
(defun deinstall-fd-handler (connection)
(log-event "deinstall-fd-handler~%")
(remove-fd-handlers (connection.socket-io connection))
@@ -1223,9 +1245,7 @@
(unwind-protect
(call-with-user-break-handler
(lambda ()
- (invoke-or-queue-interrupt
- (lambda ()
- (dispatch-event `(:emacs-interrupt ,(current-thread-id))))))
+ (invoke-or-queue-interrupt #'dispatch-interrupt-event))
(lambda ()
(with-simple-restart (close-connection "Close SLIME connection")
(handle-requests connection))))
@@ -1455,24 +1475,17 @@
(defmacro with-thread-description (description &body body)
`(call-with-thread-description ,description #'(lambda () , at body)))
-(defun decode-message (stream &optional timeout)
+(defun decode-message (stream)
"Read an S-expression from STREAM using the SLIME protocol."
- (assert (or (not timeout) (eq timeout t)))
;;(log-event "decode-message~%")
(let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
(handler-bind ((error (lambda (c) (error (make-swank-error c)))))
- (let ((c (read-char-no-hang stream)))
- (cond ((and (not c) timeout) (values nil t))
- (t
- (and c (unread-char c stream))
- (let ((packet (read-packet stream)))
- (handler-case (values (read-form packet) nil)
- (reader-error (c)
- `(:reader-error ,packet ,c))))))))))
+ (let ((packet (read-packet stream)))
+ (handler-case (values (read-form packet) nil)
+ (reader-error (c)
+ `(:reader-error ,packet ,c)))))))
(defun read-packet (stream)
- (peek-char nil stream) ; wait while queuing interrupts
- (check-slime-interrupts)
(let* ((header (read-chunk stream 6))
(length (parse-integer header :radix #x10))
(payload (read-chunk stream length)))
More information about the slime-cvs
mailing list