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)
|