dotfiles/emacs/.emacs.d/elpa/slime-20190724.1352/contrib/swank-trace-dialog.lisp

(defpackage :swank-trace-dialog
  (:use :cl)
  (:import-from :swank :defslimefun :from-string :to-string)
  (:export #:clear-trace-tree
           #:dialog-toggle-trace
           #:dialog-trace
           #:dialog-traced-p
           #:dialog-untrace
           #:dialog-untrace-all
           #:inspect-trace-part
           #:report-partial-tree
           #:report-specs
           #:report-total
           #:report-trace-detail
           #:report-specs
           #:trace-format
           #:still-inside
           #:exited-non-locally
           #:*record-backtrace*
           #:*traces-per-report*
           #:*dialog-trace-follows-trace*
           #:find-trace-part
           #:find-trace))

(in-package :swank-trace-dialog)

(defparameter *record-backtrace* nil
  "Record a backtrace of the last 20 calls for each trace.

Beware that this may have a drastic performance impact on your
program.")

(defparameter *traces-per-report* 150
  "Number of traces to report to emacs in each batch.")


;;;; `trace-entry' model
;;;;
(defvar *traces* (make-array 1000 :fill-pointer 0
                                  :adjustable t))

(defvar *trace-lock* (swank/backend:make-lock :name "swank-trace-dialog lock"))

(defvar *current-trace-by-thread* (make-hash-table))

(defclass trace-entry ()
  ((id         :reader   id-of)
   (children   :accessor children-of :initform nil)
   (backtrace  :accessor backtrace-of :initform (when *record-backtrace*
                                                  (useful-backtrace)))

   (spec       :initarg  :spec      :accessor spec-of
               :initform (error "must provide a spec"))
   (args       :initarg  :args      :accessor args-of
               :initform (error "must provide args"))
   (parent     :initarg  :parent    :reader   parent-of
               :initform (error "must provide a parent, even if nil"))
   (retlist    :initarg  :retlist   :accessor retlist-of
               :initform 'still-inside)))

(defmethod initialize-instance :after ((entry trace-entry) &rest initargs)
  (declare (ignore initargs))
  (if (parent-of entry)
      (nconc (children-of (parent-of entry)) (list entry)))
  (swank/backend:call-with-lock-held
   *trace-lock*
   #'(lambda ()
       (setf (slot-value entry 'id) (fill-pointer *traces*))
       (vector-push-extend entry *traces*))))

(defmethod print-object ((entry trace-entry) stream)
  (print-unreadable-object (entry stream)
    (format stream "~a: ~a" (id-of entry) (spec-of entry))))

(defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside)))

(defun find-trace (id)
  (when (<= 0 id (1- (length *traces*)))
    (aref *traces* id)))

(defun find-trace-part (id part-id type)
  (let* ((trace (find-trace id))
         (l (and trace
                 (ecase type
                   (:arg (args-of trace))
                   (:retval (swank::ensure-list (retlist-of trace)))))))
    (values (nth part-id l)
            (< part-id (length l)))))

(defun useful-backtrace ()
  (swank/backend:call-with-debugging-environment
   #'(lambda ()
       (loop for i from 0
             for frame in (swank/backend:compute-backtrace 0 20)
             collect (list i (swank::frame-to-string frame))))))

(defun current-trace ()
  (gethash (swank/backend:current-thread) *current-trace-by-thread*))

(defun (setf current-trace) (trace)
  (setf (gethash (swank/backend:current-thread) *current-trace-by-thread*)
        trace))


;;;; Control of traced specs
;;;
(defvar *traced-specs* '())

(defslimefun dialog-trace (spec)
  (flet ((before-hook (args)
           (setf (current-trace) (make-instance 'trace-entry
                                                :spec      spec
                                                :args      args
                                                :parent    (current-trace))))
         (after-hook (retlist)
           (let ((trace (current-trace)))
             (when trace
               ;; the current trace might have been wiped away if the
               ;; user cleared the tree in the meantime. no biggie,
               ;; don't do anything.
               ;;
               (setf (retlist-of trace) retlist
                     (current-trace) (parent-of trace))))))
    (when (dialog-traced-p spec)
      (warn "~a is apparently already traced! Untracing and retracing." spec)
      (dialog-untrace spec))
    (swank/backend:wrap spec 'trace-dialog
                        :before #'before-hook
                        :after #'after-hook)
    (pushnew spec *traced-specs*)
    (format nil "~a is now traced for trace dialog" spec)))

(defslimefun dialog-untrace (spec)
  (swank/backend:unwrap spec 'trace-dialog)
  (setq *traced-specs* (remove spec *traced-specs* :test #'equal))
  (format nil "~a is now untraced for trace dialog" spec))

(defslimefun dialog-toggle-trace (spec)
  (if (dialog-traced-p spec)
      (dialog-untrace spec)
      (dialog-trace spec)))

(defslimefun dialog-traced-p (spec)
  (find spec *traced-specs* :test #'equal))

(defslimefun dialog-untrace-all ()
  (untrace)
  (mapcar #'dialog-untrace *traced-specs*))

(defparameter *dialog-trace-follows-trace* nil)

(setq swank:*after-toggle-trace-hook*
      #'(lambda (spec traced-p)
          (when *dialog-trace-follows-trace*
            (cond (traced-p
                   (dialog-trace spec)
                   "traced for trace dialog as well")
                  (t
                   (dialog-untrace spec)
                   "untraced for the trace dialog as well")))))


;;;; A special kind of trace call
;;;
(defun trace-format (format-spec &rest format-args)
  "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace."
  (let* ((line (apply #'format nil format-spec format-args)))
    (make-instance 'trace-entry :spec line
                                :args format-args
                                :parent (current-trace)
                                :retlist nil)))


;;;; Reporting to emacs
;;;
(defparameter *visitor-idx* 0)

(defparameter *visitor-key* nil)

(defvar *unfinished-traces* '())

(defun describe-trace-for-emacs (trace)
  `(,(id-of trace)
    ,(and (parent-of trace) (id-of (parent-of trace)))
    ,(spec-of trace)
    ,(loop for arg in (args-of trace)
           for i from 0
           collect (list i (swank::to-line arg)))
    ,(loop for retval in (swank::ensure-list (retlist-of trace))
           for i from 0
           collect (list i (swank::to-line retval)))))

(defslimefun report-partial-tree (key)
  (unless (equal key *visitor-key*)
    (setq *visitor-idx* 0
          *visitor-key* key))
  (let* ((recently-finished
           (loop with i = 0
                 for trace in *unfinished-traces*
                 while (< i *traces-per-report*)
                 when (completed-p trace)
                   collect trace
                   and do
                     (incf i)
                     (setq *unfinished-traces*
                           (remove trace *unfinished-traces*))))
         (new (loop for i
                      from (length recently-finished)
                        below *traces-per-report*
                    while (< *visitor-idx* (length *traces*))
                    for trace = (aref *traces* *visitor-idx*)
                    collect trace
                    unless (completed-p trace)
                      do (push trace *unfinished-traces*)
                    do (incf *visitor-idx*))))
    (list
     (mapcar #'describe-trace-for-emacs
             (append recently-finished new))
     (- (length *traces*) *visitor-idx*)
    key)))

(defslimefun report-trace-detail (trace-id)
  (swank::call-with-bindings
   swank::*inspector-printer-bindings*
   #'(lambda ()
       (let ((trace (find-trace trace-id)))
         (when trace
           (append
            (describe-trace-for-emacs trace)
            (list (backtrace-of trace)
                  (swank::to-line trace))))))))

(defslimefun report-specs ()
  (sort (copy-list *traced-specs*)
        #'string<
        :key #'princ-to-string))

(defslimefun report-total ()
  (length *traces*))

(defslimefun clear-trace-tree ()
  (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*)
        *visitor-key* nil
        *unfinished-traces* nil)
  (swank/backend:call-with-lock-held
   *trace-lock*
   #'(lambda () (setf (fill-pointer *traces*) 0)))
  nil)

;; HACK: `swank::*inspector-history*' is unbound by default and needs
;; a reset in that case so that it won't error `swank::inspect-object'
;; before any other object is inspected in the slime session.
;;
(unless (boundp 'swank::*inspector-history*)
  (swank::reset-inspector))

(defslimefun inspect-trace-part (trace-id part-id type)
  (multiple-value-bind (obj found)
      (find-trace-part trace-id part-id type)
    (if found
        (swank::inspect-object obj)
        (error "No object found with ~a, ~a and ~a" trace-id part-id type))))

(provide :swank-trace-dialog)