Add COMM debugging

src/cl-jupyter/kernel.lisp

@@ -47,7 +47,8 @@
   (bordeaux-threads:make-thread
     (lambda ()
       (jupyter:inform :info k "Loading CLHS map")
-      (load-clhs-map))))
+      (load-clhs-map))
+    :name "Jupyter Kernel Startup"))
 
 
 (defclass debug-environment (jupyter:debug-environment)
@@ -393,7 +394,7 @@
 
 (defun read-evaluated-form ()
   (format *query-io* "~&Type a form to be evaluated:~%")
-  (jupyter:handling-comm-errors
+  (jupyter:with-debugger ()
     (multiple-value-list (eval-in-frame (read *query-io*) jupyter:*debug-frame*))))
 
 
@@ -404,7 +405,6 @@
   #+ecl   (si:eval-with-env form (cdr data))
   #+sbcl  (sb-di:eval-in-frame data form))
 
-
 (defmacro debugging-errors (&body body)
   `(unwind-protect
        (prog ((*debugger-hook* #'debugger-hook)
@@ -427,7 +427,7 @@
          (restart-bind
              ((eval
                 (lambda (&rest results)
-                  (jupyter:handling-comm-errors
+                  (jupyter:with-debugger ()
                     (dolist (result results)
                       (jupyter:display result)))
                   (jupyter:debug-enter-loop))
@@ -684,7 +684,7 @@
          next
           (when (multiple-value-call #'jupyter:evaluate-form
                                      jupyter:*kernel* stream source-path breakpoints
-                                     (source-line-column source-path))
+                                     (source-line-column source-path 0))
             (go next))))
       #+clasp
       (with-open-file (stream source-path)
@@ -737,10 +737,8 @@
           (when (jupyter:evaluate-form jupyter:*kernel* stream nil breakpoints)
             (go repeat)))))))
 
-
 (defmethod jupyter:evaluate-code ((k kernel) code &optional source-path breakpoints)
   (if (jupyter:kernel-debugger-started jupyter:*kernel*)
-    (debugging-errors (repl code source-path breakpoints))
-    #+(or)(jupyter:handling-errors (repl code source-path breakpoints))
-    (with-simple-restart (abort "Exit debugger, returning to top level.")
-      (repl code source-path breakpoints))))
+      (debugging-errors (repl code source-path breakpoints))
+      (jupyter:with-debugger (:internal t)
+        (repl code source-path breakpoints))))

src/cl-jupyter/utils.lisp

@@ -187,7 +187,8 @@
                          (setf right (file-position stream))
                          (go next))))))
 
-(defun source-line-column (pathname position1 #+(or cmucl sbcl) position2)
+(defun source-line-column (pathname position1 &optional position2)
+  (declare (ignorable position2))
   (handler-case
       #+(or cmucl sbcl) (values-list (elt (elt (get-source-map pathname) position1) position2))
       #+(or ccl ecl) (let ((record (find-if (lambda (record)

src/heartbeat.lisp

@@ -25,5 +25,5 @@
                   (unless (zerop (pzmq:poll items +zmq-poll-timeout+))
                     (send-heartbeat hb (recv-heartbeat hb)))
                   (bordeaux-threads:thread-yield)
-                  (go poll))))))))
-
+                   (go poll))))
+            :name "Jupyter Heartbeat"))))

src/iopub.lisp

@@ -8,7 +8,7 @@
 
 (defclass iopub-channel (channel)
   ((name :initarg :name
-         :initform "stdout"
+         :initform '*standard-output*
          :accessor iopub-channel-name)
    (value :initarg :value
           :initform (make-array *iopub-stream-size*
@@ -104,16 +104,19 @@
   (message-send iopub
                 (make-message (channel-session iopub) "stream"
                               (list :object-plist
-                                    "name" stream-name
+                                    "name" (ecase stream-name
+                                             (*standard-output* "stdout")
+                                             (*error-output* "stderr"))
                                     "text" data))))
 
 (defun iopub-write-char (iopub name char)
   (with-accessors ((current-name iopub-channel-name)
                    (value iopub-channel-value)
+                   (column iopub-channel-column)
                    (prompt-prefix iopub-channel-prompt-prefix)
                    (prompt-suffix iopub-channel-prompt-suffix))
       iopub
-    (unless (string= current-name name)
+    (unless (eq current-name name)
       (when (plusp (length value))
         (send-stream iopub current-name value)
         (setf (fill-pointer value) 0))
@@ -149,7 +152,7 @@
                    (value iopub-channel-value))
       iopub
     (when (and (or (null name)
-                   (string= current-name name))
+                   (eq current-name name))
                (plusp (length value)))
         (send-stream iopub current-name value)
         (setf (fill-pointer value) 0))))

src/kernel.lisp

@@ -2,7 +2,6 @@
 
 
 (defvar *payload* nil)
-(defvar *debugger* t)
 (defvar *markdown-output* nil)
 (defvar *html-output* nil)
 (defvar *thread-id* nil)
@@ -12,14 +11,11 @@
 (defconstant +max-thread-count+ (ash 1 +thread-bits+))
 (defconstant +thread-mask+ (1- +max-thread-count+))
 
-
 (defvar *page-output* nil
   "Output stream sent to Jupyter pager. Available during calls to evaluate-code.")
 
-
 (defconstant +zmq-poll-timeout+ 500)
 
-
 (defclass thread ()
   ((queue
      :reader thread-queue
@@ -667,6 +663,92 @@
        (values))))
 
 
+(defun control-debugger-hook (condition me-or-my-encapsulation)
+  (declare (ignore me-or-my-encapsulation))
+  (inform (if (typep condition 'warning)
+              :warning
+              :error)
+          "[~S] ~A~%" (type-of condition) condition)
+  (abort))
+
+(defun shell-debugger-hook (condition me-or-my-encapsulation)
+  (declare (ignore me-or-my-encapsulation))
+  (let ((stream (if (typep condition 'warning)
+                    *standard-output*
+                    *error-output*)))
+    (format stream "[~S] ~A~%" (type-of condition) condition)
+    (finish-output stream)
+    (abort)))
+
+(defun debugger-type ()
+  (cond #+(or clasp sbcl)
+        (#+clasp (core:debugger-disabled-p)
+         #+sbcl (eq sb-ext:*invoke-debugger-hook* 'sb-debug::debugger-disabled-hook)
+         :none)
+        #+(or clasp sbcl)
+        (#+clasp ext:*invoke-debugger-hook*
+         #+sbcl sb-ext:*invoke-debugger-hook*
+         :external)
+        (t
+         :interal)))
+
+(defun builtin-debugger-p ()
+  (and *builtin-debugger*
+       #+clasp (not (core:debugger-disabled-p))
+       #+sbcl (not (eq sb-ext:*invoke-debugger-hook* 'sb-debug::debugger-disabled-hook))))
+
+(defun external-debugger-p ()
+  (and #+sbcl      sb-ext:*invoke-debugger-hook*
+       #+ccl       ccl:*break-hook*
+       #+ecl       ext:*invoke-debugger-hook*
+       #+clasp     ext:*invoke-debugger-hook*
+       #+abcl      sys::*invoke-debugger-hook*
+       #+clisp     sys::*break-driver*
+       #+allegro   excl::*break-hook*
+       #+lispworks dbg::*debugger-wrapper-list*
+       #+mezzano   mezzano.debug:*global-debugger*
+       #-(or sbcl ccl ecl clasp abcl clisp allegro lispworks mezzano)
+       nil
+       t))
+
+(defmacro with-debugger ((&key control internal) &body body)
+  (let ((debugger-hook (if control
+                           'control-debugger-hook
+                           'shell-debugger-hook)))
+  `(flet ((body-func ()
+           (with-simple-restart
+               (abort "Exit debugger, returning to top level.")
+             ,@body)))
+     (case (debugger-type)
+       (:external
+        (body-func))
+       ,@(when internal
+           #+clasp
+           `((:internal
+              (catch sys::*quit-tag*
+                (body-func))))
+           #-clasp
+           `((:internal
+              (body-func))))
+       (otherwise
+        (let ((*debugger-hook* ',debugger-hook)
+              #+sbcl      (sb-ext:*invoke-debugger-hook* ',debugger-hook)
+              #+ccl       (ccl:*break-hook* ',debugger-hook)
+              #+ecl       (ext:*invoke-debugger-hook* ',debugger-hook)
+              #+clasp     (ext:*invoke-debugger-hook* ',debugger-hook)
+              #+abcl      (sys::*invoke-debugger-hook* ',debugger-hook)
+              #+clisp     (sys::*break-driver* (lambda (continuable &optional condition print)
+                                                 (declare (ignore continuable print))
+                                                 (,debugger-hook condition nil)))
+              #+allegro   (excl::*break-hook* (lambda (&rest args)
+                                                (,debugger-hook (fifth args))))
+              #+lispworks (dbg::*debugger-wrapper-list* (lambda (function condition)
+                                                          (declare (ignore function))
+                                                          (,debugger-hook condition nil)))
+              #+mezzano   (mezzano.debug:*global-debugger* (lambda (condition)
+                                                             (,debugger-hook condition nil))))
+          (body-func)))))))
+
 (defun debug-enter-loop ()
   "Re-enter the debug loop after a restart which implements a debugger command."
   (throw 'enter-loop t))
@@ -680,7 +762,7 @@
   (finish-output *html-output*)
   (finish-output)
   (finish-output *error-output*)
-  (handling-comm-errors
+  (with-debugger ()
     (with-slots (stopped queue)
                 (aref (kernel-threads *kernel*) *thread-id*)
       (setf stopped t)
@@ -815,8 +897,8 @@
                                          (make-pathname :directory '(:relative "common-lisp-jupyter")
                                                         :name language-name
                                                         :type "history")))
-          error-output (make-iopub-stream iopub "stderr")
-          standard-output (make-iopub-stream iopub "stdout")
+          error-output (make-iopub-stream iopub '*error-output*)
+          standard-output (make-iopub-stream iopub '*standard-output*)
           standard-input (make-stdin-stream stdin iopub))
     (start mac)
     (start hb)
@@ -830,7 +912,7 @@
     (setf (kernel-shell-thread k)
           (bordeaux-threads:make-thread (lambda ()
                                           (run-shell k))
-                                        :name "SHELL Thread"))))
+                                        :name "Jupyter Shell"))))
 
 
 ;; Stop all channels and destroy the control.
@@ -936,7 +1018,7 @@
       (when (zerop (pzmq:poll items +zmq-poll-timeout+))
         #+cmucl (bordeaux-threads:thread-yield)
         (go poll))
-      (handling-control-errors
+      (with-debugger (:control t)
         (setf *message* (message-recv control)
               msg-type (format nil "~A~@[/~A~]"
                                (gethash "msg_type" (message-header *message*))
@@ -996,6 +1078,8 @@
   (let ((kernel (make-instance kernel-class
                                :connection-file connection-file
                                :control-thread (bordeaux-threads:current-thread))))
+    #+sbcl (setf (sb-thread:thread-name (bordeaux-threads:current-thread))
+                 "Jupyter Control")
     (add-thread kernel)
     (start kernel)
     (unwind-protect
@@ -1554,7 +1638,7 @@
 
 (defun handle-comm-open ()
   (inform :info *kernel* "Handling comm_open message")
-  (handling-comm-errors
+  (with-debugger ()
     (let* ((content (message-content *message*))
            (metadata (message-metadata *message*))
            (buffers (message-buffers *message*))
@@ -1572,7 +1656,7 @@
 
 (defun handle-comm-message ()
   (inform :info *kernel* "Handling comm_msg message")
-  (handling-comm-errors
+  (with-debugger ()
     (let* ((content (message-content *message*))
            (metadata (message-metadata *message*))
            (buffers (message-buffers *message*))
@@ -1586,7 +1670,7 @@
 
 (defun handle-comm-close ()
   (inform :info *kernel* "Handling comm_close")
-  (handling-comm-errors
+  (with-debugger ()
     (with-slots (comms iopub)
                 *kernel*
       (let* ((content (message-content *message*))
@@ -1671,4 +1755,3 @@
 (defun clear (&optional (wait nil))
   "Send clear output message to frontend."
   (send-clear-output (kernel-iopub *kernel*) wait))
-