[slime-cvs] CVS slime
heller
heller at common-lisp.net
Mon Aug 11 17:41:56 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv21594
Modified Files:
ChangeLog slime.el swank-backend.lisp swank-clisp.lisp
swank-cmucl.lisp swank-ecl.lisp swank-sbcl.lisp swank.lisp
Log Message:
Improve interrupt safety for single-threaded lisps.
* slime.el (slime-interrupt): Send a :emacs-interrupt message
together with SIGINT. SIGINT now means "check for new events"
instead of "invoke the debugger".
* swank-backend.lisp (install-sigint-handler)
(call-with-user-break-handler): New functions.
* swank.lisp (simple-serve-requests,install-fd-handler): Use it.
(read-packet, read-char): New function. Check for interrupts.
(wait-for-event/event-loop): Check for interrupts.
--- /project/slime/cvsroot/slime/ChangeLog 2008/08/11 17:41:47 1.1440
+++ /project/slime/cvsroot/slime/ChangeLog 2008/08/11 17:41:55 1.1441
@@ -1,5 +1,20 @@
2008-08-11 Helmut Eller <heller at common-lisp.net>
+ Improve interrupt safety for single-threaded lisps.
+
+ * slime.el (slime-interrupt): Send a :emacs-interrupt message
+ together with SIGINT. SIGINT now means "check for new events"
+ instead of "invoke the debugger".
+
+ * swank-backend.lisp (install-sigint-handler)
+ (call-with-user-break-handler): New functions.
+
+ * swank.lisp (simple-serve-requests,install-fd-handler): Use it.
+ (read-packet, read-char): New function. Check for interrupts.
+ (wait-for-event/event-loop): Check for interrupts.
+
+2008-08-11 Helmut Eller <heller at common-lisp.net>
+
* swank-abcl.lisp (preferred-communication-style): Return nil
until we implement receive-if.
--- /project/slime/cvsroot/slime/slime.el 2008/08/11 07:39:10 1.987
+++ /project/slime/cvsroot/slime/slime.el 2008/08/11 17:41:55 1.988
@@ -6454,8 +6454,9 @@
(defun slime-interrupt ()
"Interrupt Lisp."
(interactive)
- (cond ((slime-use-sigint-for-interrupt) (slime-send-sigint))
- (t (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread)))))
+ (slime-dispatch-event `(:emacs-interrupt ,slime-current-thread))
+ (when (slime-use-sigint-for-interrupt)
+ (slime-send-sigint)))
(defun slime-quit ()
(error "Not implemented properly. Use `slime-interrupt' instead."))
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/11 07:37:01 1.143
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/11 17:41:55 1.144
@@ -302,6 +302,17 @@
(definterface getpid ()
"Return the (Unix) process ID of this superior Lisp.")
+(definterface install-sigint-handler (function)
+ "Call FUNCTION on SIGINT (instead of invoking the debugger).
+Return old signal handler."
+ nil)
+
+(definterface call-with-user-break-handler (handler function)
+ "Install the break handler HANDLER while executing FUNCTION."
+ (let ((old-handler (install-sigint-handler handler)))
+ (unwind-protect (funcall function)
+ (install-sigint-handler old-handler))))
+
(definterface lisp-implementation-type-name ()
"Return a short name for the Lisp implementation."
(lisp-implementation-type))
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/04 21:38:07 1.72
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/11 17:41:55 1.73
@@ -99,6 +99,14 @@
#+win32 ((ext:getenv "PID")) ; where does that come from?
(t -1))))
+(defimplementation call-with-user-break-handler (handler function)
+ (handler-bind ((system::simple-interrupt-condition
+ (lambda (c)
+ (declare (ignore c))
+ (funcall handler)
+ (continue))))
+ (funcall function)))
+
(defimplementation lisp-implementation-type-name ()
"clisp")
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/11 07:37:02 1.185
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/11 17:41:55 1.186
@@ -139,6 +139,11 @@
;;;;; Signal-driven I/O
+(defimplementation install-sigint-handler (function)
+ (sys:enable-interrupt :sigint (lambda (signal code scp)
+ (declare (ignore signal code scp))
+ (funcall function))))
+
(defvar *sigio-handlers* '()
"List of (key . function) pairs.
All functions are called on SIGIO, and the key is used for removing
@@ -155,19 +160,28 @@
(defun fcntl (fd command arg)
"fcntl(2) - manipulate a file descriptor."
(multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
- (unless ok (error "fcntl: ~A" (unix:get-unix-error-msg error)))))
+ (cond (ok)
+ (t (error "fcntl: ~A" (unix:get-unix-error-msg error))))))
(defimplementation add-sigio-handler (socket fn)
(set-sigio-handler)
(let ((fd (socket-fd socket)))
(fcntl fd unix:f-setown (unix:unix-getpid))
- (fcntl fd unix:f-setfl unix:fasync)
+ (let ((old-flags (fcntl fd unix:f-getfl 0)))
+ (fcntl fd unix:f-setfl (logior old-flags unix:fasync)))
(push (cons fd fn) *sigio-handlers*)))
(defimplementation remove-sigio-handlers (socket)
(let ((fd (socket-fd socket)))
- (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
- (sys:invalidate-descriptor fd)))
+ (unless (assoc fd *sigio-handlers*)
+ (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
+ (let ((old-flags (fcntl fd unix:f-getfl 0)))
+ (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync)))
+ (sys:invalidate-descriptor fd))
+ #+(or)
+ (when (null *sigio-handlers*)
+ (sys:default-interrupt :sigio))
+ ))
;;;;; SERVE-EVENT
--- /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/11 07:39:23 1.26
+++ /project/slime/cvsroot/slime/swank-ecl.lisp 2008/08/11 17:41:55 1.27
@@ -71,6 +71,18 @@
;;;; Unix signals
+(defimplementation install-sigint-handler (handler)
+ (let ((old-handler (symbol-function 'si:terminal-interrupt)))
+ (setf (symbol-function 'si:terminal-interrupt)
+ (if (consp handler)
+ (car handler)
+ (lambda (&rest args)
+ (declare (ignore args))
+ (funcall handler)
+ (continue))))
+ (list old-handler)))
+
+
(defimplementation getpid ()
(si:getpid))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/11 07:37:06 1.212
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/11 17:41:55 1.213
@@ -112,6 +112,12 @@
(or external-format :iso-latin-1-unix)
(or buffering :full)))
+(defimplementation install-sigint-handler (function)
+ (sb-sys:enable-interrupt sb-unix:sigint
+ (lambda (&rest args)
+ (declare (ignore args))
+ (funcall function))))
+
(defvar *sigio-handlers* '()
"List of (key . fn) pairs to be called on SIGIO.")
--- /project/slime/cvsroot/slime/swank.lisp 2008/08/11 07:39:29 1.565
+++ /project/slime/cvsroot/slime/swank.lisp 2008/08/11 17:41:55 1.566
@@ -236,7 +236,10 @@
;; The communication style used.
(communication-style nil :type (member nil :spawn :sigio :fd-handler))
;; The coding system for network streams.
- (coding-system ))
+ coding-system
+ ;; The SIGINT handler we should restore when the connection is
+ ;; closed.
+ saved-sigint-handler)
(defun print-connection (conn stream depth)
(declare (ignore depth))
@@ -317,6 +320,45 @@
;;;;; Helper macros
+(defvar *slime-interrupts-enabled*)
+
+(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)))))
+
+(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)))))
+
+(defun invoke-or-queue-interrupt (function)
+ (cond ((not (boundp '*slime-interrupts-enabled*))
+ (without-slime-interrupts
+ (funcall function)))
+ (*slime-interrupts-enabled*
+ (funcall function))
+ ((cdr *pending-slime-interrupts*)
+ (simple-break "Two many queued interrupts"))
+ (t
+ (push function *pending-slime-interrupts*))))
+
+(defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
+ (with-simple-restart (continue "Continue from break.")
+ (invoke-slime-debugger (coerce-to-condition datum args))))
+
+(defun coerce-to-condition (datum args)
+ (etypecase datum
+ (string (make-condition 'simple-error :format-control datum
+ :format-arguments args))
+ (symbol (apply #'make-condition datum args))))
+
(defmacro with-io-redirection ((connection) &body body)
"Execute BODY I/O redirection to CONNECTION.
If *REDIRECT-IO* is true then all standard I/O streams are redirected."
@@ -333,9 +375,10 @@
(defun call-with-connection (connection function)
(let ((*emacs-connection* connection))
- (with-swank-error-handler (*emacs-connection*)
- (with-io-redirection (*emacs-connection*)
- (call-with-debugger-hook #'swank-debugger-hook function)))))
+ (without-slime-interrupts
+ (with-swank-error-handler (*emacs-connection*)
+ (with-io-redirection (*emacs-connection*)
+ (call-with-debugger-hook #'swank-debugger-hook function))))))
(defmacro without-interrupts (&body body)
`(call-without-interrupts (lambda () , at body)))
@@ -869,6 +912,7 @@
(connection.socket-io *emacs-connection*))
(defun close-connection (c condition backtrace)
+ (let ((*debugger-hook* nil))
(format *log-output* "~&;; swank:close-connection: ~A~%" condition)
(let ((cleanup (connection.cleanup c)))
(when cleanup
@@ -894,43 +938,8 @@
(ignore-errors (stream-external-format (connection.socket-io c)))
(connection.communication-style c)
*use-dedicated-output-stream*)
- (finish-output *log-output*)))
+ (finish-output *log-output*))))
-(defvar *slime-interrupts-enabled*)
-
-(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)))))
-
-(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)))))
-
-(defun invoke-or-queue-interrupt (function)
- (cond ((not (boundp '*slime-interrupts-enabled*))
- (without-slime-interrupts
- (funcall function)))
- (*slime-interrupts-enabled*
- (funcall function))
- ((cdr *pending-slime-interrupts*)
- (simple-break "Two many queued interrupts"))
- (t
- (push function *pending-slime-interrupts*))))
-
-(defslimefun simple-break (&optional (fstring "Interrupt from Emacs")
- &rest args)
- (call-with-debugger-hook
- #'swank-debugger-hook
- (lambda ()
- (cerror "Return from break." "~?" fstring args))))
;;;;;; Thread based communication
@@ -1033,7 +1042,9 @@
(declare (ignore _))
(encode-message event (current-socket-io)))
(((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
- (send-event (find-thread thread-id) (cons (car event) args)))))
+ (send-event (find-thread thread-id) (cons (car event) args)))
+ (((:end-of-stream))
+ (close-connection *emacs-connection* nil (safe-backtrace)))))
(defvar *event-queue* '())
@@ -1048,6 +1059,7 @@
(defun send-to-emacs (event)
"Send EVENT to Emacs."
+ ;;(log-event "send-to-emacs: ~a" event)
(cond ((use-threads-p)
(send (connection.control-thread *emacs-connection*) event))
(t (dispatch-event event))))
@@ -1068,6 +1080,7 @@
(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
@@ -1119,48 +1132,49 @@
;;;;;; Signal driven IO
(defun install-sigio-handler (connection)
- (let ((client (connection.socket-io connection)))
- (flet ((handler ()
- (cond ((null *swank-state-stack*)
- (handle-requests connection t))
- ((eq (car *swank-state-stack*) :read-next-form))
- (t (process-requests t nil)))))
- (add-sigio-handler client #'handler)
- (handler))))
+ (add-sigio-handler (connection.socket-io connection)
+ (lambda () (process-io-interrupt connection)))
+ (handle-or-process-requests connection))
+
+(defun process-io-interrupt (connection)
+ (log-event "process-io-interrupt~%")
+ (invoke-or-queue-interrupt
+ (lambda () (handle-or-process-requests connection))))
+
+(defun handle-or-process-requests (connection)
+ (log-event "handle-or-process-requests: ~a~%" *swank-state-stack*)
+ (cond ((null *swank-state-stack*)
+ (handle-requests connection t))
+ ((eq (car *swank-state-stack*) :read-next-form))
+ (t (process-requests t nil))))
(defun deinstall-sigio-handler (connection)
- (remove-sigio-handlers (connection.socket-io connection)))
+ (log-event "deinstall-sigio-handler...~%")
+ (remove-sigio-handlers (connection.socket-io connection))
+ (log-event "deinstall-sigio-handler...done~%"))
;;;;;; SERVE-EVENT based IO
(defun install-fd-handler (connection)
- (let ((client (connection.socket-io connection)))
- (flet ((handler ()
- (cond ((null *swank-state-stack*)
- (handle-requests connection t))
- ((eq (car *swank-state-stack*) :read-next-form))
- (t (process-requests t nil)))))
- ;;;; handle sigint
- ;;(install-debugger-globally
- ;; (lambda (c h)
- ;; (with-reader-error-handler (connection)
- ;; (block debugger
- ;; (with-connection (connection)
- ;; (swank-debugger-hook c h)
- ;; (return-from debugger))
- ;; (abort)))))
- (add-fd-handler client #'handler)
- (handler))))
+ (add-fd-handler (connection.socket-io connection)
+ (lambda () (handle-or-process-requests connection)))
+ (setf (connection.saved-sigint-handler connection)
+ (install-sigint-handler (lambda () (process-io-interrupt connection))))
+ (handle-or-process-requests connection))
(defun deinstall-fd-handler (connection)
- (remove-fd-handlers (connection.socket-io connection)))
+ (remove-fd-handlers (connection.socket-io connection))
+ (install-sigint-handler (connection.saved-sigint-handler connection)))
;;;;;; Simple sequential IO
(defun simple-serve-requests (connection)
(unwind-protect
- (with-simple-restart (close-connection "Close SLIME connection")
- (handle-requests connection))
+ (call-with-user-break-handler
+ (lambda () (process-io-interrupt connection))
+ (lambda ()
+ (with-simple-restart (close-connection "Close SLIME connection")
+ (handle-requests connection))))
(close-connection connection nil (safe-backtrace))))
(defun initialize-streams-for-connection (connection)
@@ -1390,23 +1404,29 @@
(defun decode-message (stream &optional timeout)
"Read an S-expression from STREAM using the SLIME protocol."
(assert (or (not timeout) (eq timeout t)))
- (when (and (eq timeout t) (not (input-available-p stream)))
- (return-from decode-message (values nil 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* ((length (decode-message-length stream))
- (string (make-string length))
- (pos (read-sequence string stream)))
- (assert (= pos length) ()
- "Short read: length=~D pos=~D" length pos)
- (log-event "READ: ~S~%" string)
- (values (read-form string) nil)))))
-
-(defun decode-message-length (stream)
- (let ((buffer (make-string 6)))
- (dotimes (i 6)
- (setf (aref buffer i) (read-char stream)))
- (parse-integer buffer :radix #x10)))
+ (let ((c (read-char-no-hang stream nil)))
+ (cond ((and (not c) timeout) (values nil t))
+ (t
+ (and c (unread-char c stream))
+ (values (read-form (read-packet stream)) nil)))))))
+
+(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)))
+ (log-event "READ: ~S~%" payload)
+ payload))
+
+(defun read-chunk (stream length)
+ (let* ((buffer (make-string length))
+ (count (read-sequence buffer stream)))
+ (assert (= count length) () "Short read: length=~D count=~D" length count)
+ buffer))
(defun read-form (string)
(with-standard-io-syntax
More information about the slime-cvs
mailing list