Set a console Ctrl handler for Windows

Install a Lisp callback using SetConsoleCtrlHandler, allowing users
to interrupt SBCL using C-c in the Windows console.

We cannot currently control the size of the stack available to us in
this handler, but since we are mainly only calling INTERRUPT-THREAD,
even a small stack might be sufficient for our purposes.

Thanks to Anton Kovalenko.

diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index 3fd22f3..d380760 100644 (file)
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -214,6 +214,15 @@
   (declare (type system-area-pointer context))
   (/show "in Lisp-level SIGINT handler" (sap-int context))
   (flet ((interrupt-it ()
+           ;; This seems wrong to me on multi-threaded builds.  The
+           ;; closed-over signal context belongs to a SIGINT handler.
+           ;; But this function gets run through INTERRUPT-THREAD,
+           ;; i.e. in in a SIGPIPE handler, at a different point in time
+           ;; or even a different thread.  How do we know that the
+           ;; SIGINT's context structure from the other thread is still
+           ;; alive and meaningful?  Why do we care?  If we even need
+           ;; the context and PC, shouldn't they come from the SIGPIPE's
+           ;; context? --DFL
            (with-alien ((context (* os-context-t) context))
              (with-interrupts
                (let ((int (make-condition 'interactive-interrupt

diff --git a/src/code/warm-mswin.lisp b/src/code/warm-mswin.lisp
index eef4e56..5a973ff 100644 (file)
--- a/src/code/warm-mswin.lisp
+++ b/src/code/warm-mswin.lisp
@@ -104,3 +104,65 @@
                               (if got code -1))))
                     child))
               -2))))))
+
+(define-alien-routine ("SetConsoleCtrlHandler" set-console-ctrl-handler) int
+  (callback (function (:stdcall int) int))
+  (enable int))
+
+(defun windows-console-control-handler (event-code)
+  (case event-code
+    (0
+     (flet ((interrupt-it ()
+              (let* ((context
+                       (sb-di::nth-interrupt-context
+                        (1- sb-kernel:*free-interrupt-context-index*)))
+                     (pc (sb-vm:context-pc context)))
+                (with-interrupts
+                  (let ((int (make-condition
+                              'interactive-interrupt
+                              :context context
+                              :address (sb-sys:sap-int pc))))
+                    ;; First SIGNAL, so that handlers can run.
+                    (signal int)
+                    (%break 'sigint int))))))
+       (sb-thread:interrupt-thread (sb-thread::foreground-thread)
+                                   #'interrupt-it)
+       t))))
+
+(defvar *console-control-handler* #'windows-console-control-handler)
+(defvar *console-control-enabled* nil)
+(defvar *console-control-spec* nil)
+
+(sb-alien::define-alien-callback *alien-console-control-handler* (:stdcall int)
+    ((event-code int))
+  (if (ignore-errors (funcall *console-control-handler* event-code)) 1 0))
+
+(defun console-control-handler ()
+  "Get or set windows console control handler.
+
+Boolean value: use default handler (NIL) or ignore event (T).  Symbol
+or function: designator for a function that receives an event code and
+returns generalized boolean (false to fall back to other handlers,
+true to stop searching)." *console-control-spec*)
+
+(defun (setf console-control-handler) (new-handler)
+  (etypecase new-handler
+    (boolean
+     (aver (plusp (set-console-ctrl-handler
+                   (sap-alien (int-sap 0)
+                              (function (:stdcall int) int))
+                   (if new-handler 1 0))))
+     (setf *console-control-enabled* nil))
+    ((or symbol function)
+     (setf *console-control-handler* new-handler)
+     (aver (plusp (set-console-ctrl-handler *alien-console-control-handler* 1)))))
+  (setf *console-control-spec* new-handler))
+
+(defun initialize-console-control-handler (&optional reset-to-default-p)
+  (setf (console-control-handler)
+        (if reset-to-default-p
+            'windows-console-control-handler
+            (console-control-handler))))
+
+(initialize-console-control-handler t)
+(pushnew 'initialize-console-control-handler sb-ext:*init-hooks*)