265 lines
8.7 KiB
Common Lisp
265 lines
8.7 KiB
Common 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)
|