diff options
Diffstat (limited to 'vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp')
| -rw-r--r-- | vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp | 264 |
1 files changed, 264 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp b/vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp new file mode 100644 index 0000000..5cf95fd --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-trace-dialog.lisp @@ -0,0 +1,264 @@ +(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) |