Permalink
Browse files

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.
  • Loading branch information...
1 parent 0f09b06 commit 7be8fd7b4bfa1f2518d6379e8ff3d4306f43ce4b Helmut Eller committed Aug 11, 2008
Showing with 178 additions and 91 deletions.
  1. +15 −0 ChangeLog
  2. +3 −2 slime.el
  3. +11 −0 swank-backend.lisp
  4. +8 −0 swank-clisp.lisp
  5. +18 −4 swank-cmucl.lisp
  6. +12 −0 swank-ecl.lisp
  7. +6 −0 swank-sbcl.lisp
  8. +105 −85 swank.lisp
View
@@ -1,5 +1,20 @@
2008-08-11 Helmut Eller <heller@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@common-lisp.net>
+
* swank-abcl.lisp (preferred-communication-style): Return nil
until we implement receive-if.
View
@@ -6454,8 +6454,9 @@ CL:MACROEXPAND."
(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."))
View
@@ -302,6 +302,17 @@ that the calling thread is the one that interacts with Emacs."
(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))
View
@@ -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")
View
@@ -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 @@ specific functions.")
(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
View
@@ -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))
View
@@ -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.")
Oops, something went wrong.

0 comments on commit 7be8fd7

Please sign in to comment.