(defpackage :slynk-trace-dialog
(:use :cl :slynk-api)
(: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-specs
#:trace-format
#:still-inside
#:exited-non-locally
#:*record-backtrace*
#:*traces-per-report*
#:*dialog-trace-follows-trace*
#:instrument
#:pprint-trace-part
#:describe-trace-part
#:trace-part-or-lose
#:inspect-trace
#:trace-or-lose
#:trace-arguments-or-lose
#:trace-location))
(in-package :slynk-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.")
(defparameter *dialog-trace-follows-trace* nil)
(defvar *traced-specs* '())
(defparameter *visitor-idx* 0)
(defparameter *visitor-key* nil)
(defvar *unfinished-traces* '())
;;;; `trace-entry' model
;;;;
(defvar *traces* (make-array 1000 :fill-pointer 0
:adjustable t))
(defvar *trace-lock* (slynk-backend:make-lock :name "slynk-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"))
(function :initarg :function :accessor function-of)
(args :initarg :args :reader args-of
:initform (error "must provide args"))
(printed-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)
(printed-retlist :initform ":STILL-INSIDE")))
(defmethod initialize-instance :after ((entry trace-entry) &key)
(with-slots (parent id printed-args args) entry
(if parent
(nconc (children-of parent) (list entry)))
(setf printed-args
(mapcar (lambda (arg)
(present-for-emacs arg #'slynk-pprint-to-line))
args))
(slynk-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 trace-arguments (trace-id)
(values-list (args-of (trace-or-lose trace-id))))
(defun useful-backtrace ()
(slynk-backend:call-with-debugging-environment
#'(lambda ()
(loop for i from 0
for frame in (slynk-backend:compute-backtrace 0 20)
collect (list i (slynk::frame-to-string frame))))))
(defun current-trace ()
(gethash (slynk-backend:current-thread) *current-trace-by-thread*))
(defun (setf current-trace) (trace)
(setf (gethash (slynk-backend:current-thread) *current-trace-by-thread*)
trace))
;;;; Helpers
;;;;
(defun describe-trace-for-emacs (trace)
(with-slots (id args parent spec printed-args retlist printed-retlist) trace
`(,id
,(and parent (id-of parent))
,(cons (string-downcase (present-for-emacs spec)) spec)
,(loop for arg in args
for printed-arg in printed-args
for i from 0
collect (list i printed-arg))
,(loop for retval in (slynk::ensure-list retlist)
for printed-retval in (slynk::ensure-list printed-retlist)
for i from 0
collect (list i printed-retval)))))
;;;; slyfuns
;;;;
(defslyfun 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)))
(defslyfun trace-or-lose (id)
(when (<= 0 id (1- (length *traces*)))
(or (aref *traces* id)
(error "No trace with id ~a" id))))
(defslyfun 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)))
(defslyfun report-specs ()
(mapcar (lambda (spec)
(cons (string-downcase (present-for-emacs spec))
spec))
(sort (copy-list *traced-specs*)
#'string<
:key #'princ-to-string)))
(defslyfun report-total ()
(length *traces*))
(defslyfun clear-trace-tree ()
(setf *current-trace-by-thread* (clrhash *current-trace-by-thread*)
*visitor-key* nil
*unfinished-traces* nil)
(slynk-backend:call-with-lock-held
*trace-lock*
#'(lambda () (setf (fill-pointer *traces*) 0)))
nil)
(defslyfun trace-part-or-lose (id part-id type)
(let* ((trace (trace-or-lose id))
(l (ecase type
(:arg (args-of trace))
(:retval (slynk::ensure-list (retlist-of trace))))))
(or (nth part-id l)
(error "Cannot find a trace part with id ~a and part-id ~a"
id part-id))))
(defslyfun trace-arguments-or-lose (trace-id)
(values-list (args-of (trace-or-lose trace-id))))
(defslyfun inspect-trace-part (trace-id part-id type)
(slynk::inspect-object
(trace-part-or-lose trace-id part-id type)))
(defslyfun pprint-trace-part (trace-id part-id type)
(slynk::slynk-pprint (list (trace-part-or-lose trace-id part-id type))))
(defslyfun describe-trace-part (trace-id part-id type)
(slynk::describe-to-string (trace-part-or-lose trace-id part-id type)))
(defslyfun inspect-trace (trace-id)
(slynk::inspect-object (trace-or-lose trace-id)))
(defslyfun trace-location (trace-id)
(slynk-backend:find-source-location (function-of (trace-or-lose trace-id))))
(defslyfun dialog-trace (spec)
(let ((function nil))
(flet ((before-hook (args)
(setf (current-trace) (make-instance 'trace-entry
:spec spec
:function (or function
spec)
:args args
:parent (current-trace))))
(after-hook (returned-values)
(let ((trace (current-trace)))
(when trace
(with-slots (retlist parent printed-retlist) 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 returned-values
printed-retlist
(mapcar (lambda (obj)
(present-for-emacs obj #'slynk-pprint-to-line))
(slynk::ensure-list retlist))
(current-trace) parent))))))
(when (dialog-traced-p spec)
(warn "~a is apparently already traced! Untracing and retracing." spec)
(dialog-untrace spec))
(setq function
(slynk-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))))
(defslyfun dialog-untrace (spec)
(with-simple-restart
(continue "Never mind, i really want this trace to go away")
(slynk-backend:unwrap spec 'trace-dialog))
(setq *traced-specs* (remove spec *traced-specs* :test #'equal))
(format nil "~a is now untraced for trace dialog" spec))
(defslyfun dialog-toggle-trace (spec)
(if (dialog-traced-p spec)
(dialog-untrace spec)
(dialog-trace spec)))
(defslyfun dialog-traced-p (spec)
(find spec *traced-specs* :test #'equal))
(defslyfun dialog-untrace-all ()
(let ((regular (length (trace)))
(dialog (length *traced-specs*)))
(untrace)
(mapcar #'dialog-untrace *traced-specs*)
(cons regular dialog)))
;;;; Hook onto emacs
;;;;
(setq slynk:*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")))))
;;;; Instrumentation
;;;;
(defmacro instrument (x &optional (id (gensym "EXPLICIT-INSTRUMENT-")) )
(let ((values-sym (gensym)))
`(let ((,values-sym (multiple-value-list ,x)))
(trace-format (format nil "~a: ~a" ',id "~a => ~{~a~^, ~}") ',x
,values-sym)
(values-list ,values-sym))))
(provide :slynk/trace-dialog)