slynk-trace-dialog.lisp (10637B)
1 (defpackage :slynk-trace-dialog 2 (:use :cl :slynk-api) 3 (:export #:clear-trace-tree 4 #:dialog-toggle-trace 5 #:dialog-trace 6 #:dialog-traced-p 7 #:dialog-untrace 8 #:dialog-untrace-all 9 #:inspect-trace-part 10 #:report-partial-tree 11 #:report-specs 12 #:report-total 13 #:report-specs 14 #:trace-format 15 #:still-inside 16 #:exited-non-locally 17 #:*record-backtrace* 18 #:*traces-per-report* 19 #:*dialog-trace-follows-trace* 20 #:instrument 21 22 #:pprint-trace-part 23 #:describe-trace-part 24 #:trace-part-or-lose 25 #:inspect-trace 26 #:trace-or-lose 27 #:trace-arguments-or-lose 28 #:trace-location)) 29 30 (in-package :slynk-trace-dialog) 31 32 (defparameter *record-backtrace* nil 33 "Record a backtrace of the last 20 calls for each trace. 34 35 Beware that this may have a drastic performance impact on your 36 program.") 37 38 (defparameter *traces-per-report* 150 39 "Number of traces to report to emacs in each batch.") 40 41 (defparameter *dialog-trace-follows-trace* nil) 42 43 (defvar *traced-specs* '()) 44 45 (defparameter *visitor-idx* 0) 46 47 (defparameter *visitor-key* nil) 48 49 (defvar *unfinished-traces* '()) 50 51 52 ;;;; `trace-entry' model 53 ;;;; 54 (defvar *traces* (make-array 1000 :fill-pointer 0 55 :adjustable t)) 56 57 (defvar *trace-lock* (slynk-backend:make-lock :name "slynk-trace-dialog lock")) 58 59 (defvar *current-trace-by-thread* (make-hash-table)) 60 61 (defclass trace-entry () 62 ((id :reader id-of) 63 (children :accessor children-of :initform nil) 64 (backtrace :accessor backtrace-of :initform (when *record-backtrace* 65 (useful-backtrace))) 66 67 (spec :initarg :spec :accessor spec-of 68 :initform (error "must provide a spec")) 69 (function :initarg :function :accessor function-of) 70 (args :initarg :args :reader args-of 71 :initform (error "must provide args")) 72 (printed-args) 73 (parent :initarg :parent :reader parent-of 74 :initform (error "must provide a parent, even if nil")) 75 (retlist :initarg :retlist :accessor retlist-of 76 :initform 'still-inside) 77 (printed-retlist :initform ":STILL-INSIDE"))) 78 79 (defmethod initialize-instance :after ((entry trace-entry) &key) 80 (with-slots (parent id printed-args args) entry 81 (if parent 82 (nconc (children-of parent) (list entry))) 83 (setf printed-args 84 (mapcar (lambda (arg) 85 (present-for-emacs arg #'slynk-pprint-to-line)) 86 args)) 87 (slynk-backend:call-with-lock-held 88 *trace-lock* 89 #'(lambda () 90 (setf (slot-value entry 'id) (fill-pointer *traces*)) 91 (vector-push-extend entry *traces*))))) 92 93 (defmethod print-object ((entry trace-entry) stream) 94 (print-unreadable-object (entry stream) 95 (format stream "~a=~a" (id-of entry) (spec-of entry)))) 96 97 (defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside))) 98 99 (defun trace-arguments (trace-id) 100 (values-list (args-of (trace-or-lose trace-id)))) 101 102 (defun useful-backtrace () 103 (slynk-backend:call-with-debugging-environment 104 #'(lambda () 105 (loop for i from 0 106 for frame in (slynk-backend:compute-backtrace 0 20) 107 collect (list i (slynk::frame-to-string frame)))))) 108 109 (defun current-trace () 110 (gethash (slynk-backend:current-thread) *current-trace-by-thread*)) 111 112 (defun (setf current-trace) (trace) 113 (setf (gethash (slynk-backend:current-thread) *current-trace-by-thread*) 114 trace)) 115 116 117 ;;;; Helpers 118 ;;;; 119 (defun describe-trace-for-emacs (trace) 120 (with-slots (id args parent spec printed-args retlist printed-retlist) trace 121 `(,id 122 ,(and parent (id-of parent)) 123 ,(cons (string-downcase (present-for-emacs spec)) spec) 124 ,(loop for arg in args 125 for printed-arg in printed-args 126 for i from 0 127 collect (list i printed-arg)) 128 ,(loop for retval in (slynk::ensure-list retlist) 129 for printed-retval in (slynk::ensure-list printed-retlist) 130 for i from 0 131 collect (list i printed-retval))))) 132 133 134 ;;;; slyfuns 135 ;;;; 136 (defslyfun trace-format (format-spec &rest format-args) 137 "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace." 138 (let* ((line (apply #'format nil format-spec format-args))) 139 (make-instance 'trace-entry :spec line 140 :args format-args 141 :parent (current-trace) 142 :retlist nil))) 143 144 (defslyfun trace-or-lose (id) 145 (when (<= 0 id (1- (length *traces*))) 146 (or (aref *traces* id) 147 (error "No trace with id ~a" id)))) 148 149 (defslyfun report-partial-tree (key) 150 (unless (equal key *visitor-key*) 151 (setq *visitor-idx* 0 152 *visitor-key* key)) 153 (let* ((recently-finished 154 (loop with i = 0 155 for trace in *unfinished-traces* 156 while (< i *traces-per-report*) 157 when (completed-p trace) 158 collect trace 159 and do 160 (incf i) 161 (setq *unfinished-traces* 162 (remove trace *unfinished-traces*)))) 163 (new (loop for i 164 from (length recently-finished) 165 below *traces-per-report* 166 while (< *visitor-idx* (length *traces*)) 167 for trace = (aref *traces* *visitor-idx*) 168 collect trace 169 unless (completed-p trace) 170 do (push trace *unfinished-traces*) 171 do (incf *visitor-idx*)))) 172 (list 173 (mapcar #'describe-trace-for-emacs 174 (append recently-finished new)) 175 (- (length *traces*) *visitor-idx*) 176 key))) 177 178 (defslyfun report-specs () 179 (mapcar (lambda (spec) 180 (cons (string-downcase (present-for-emacs spec)) 181 spec)) 182 (sort (copy-list *traced-specs*) 183 #'string< 184 :key #'princ-to-string))) 185 186 (defslyfun report-total () 187 (length *traces*)) 188 189 (defslyfun clear-trace-tree () 190 (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*) 191 *visitor-key* nil 192 *unfinished-traces* nil) 193 (slynk-backend:call-with-lock-held 194 *trace-lock* 195 #'(lambda () (setf (fill-pointer *traces*) 0))) 196 nil) 197 198 (defslyfun trace-part-or-lose (id part-id type) 199 (let* ((trace (trace-or-lose id)) 200 (l (ecase type 201 (:arg (args-of trace)) 202 (:retval (slynk::ensure-list (retlist-of trace)))))) 203 (or (nth part-id l) 204 (error "Cannot find a trace part with id ~a and part-id ~a" 205 id part-id)))) 206 207 (defslyfun trace-arguments-or-lose (trace-id) 208 (values-list (args-of (trace-or-lose trace-id)))) 209 210 (defslyfun inspect-trace-part (trace-id part-id type) 211 (slynk::inspect-object 212 (trace-part-or-lose trace-id part-id type))) 213 214 (defslyfun pprint-trace-part (trace-id part-id type) 215 (slynk::slynk-pprint (list (trace-part-or-lose trace-id part-id type)))) 216 217 (defslyfun describe-trace-part (trace-id part-id type) 218 (slynk::describe-to-string (trace-part-or-lose trace-id part-id type))) 219 220 (defslyfun inspect-trace (trace-id) 221 (slynk::inspect-object (trace-or-lose trace-id))) 222 223 (defslyfun trace-location (trace-id) 224 (slynk-backend:find-source-location (function-of (trace-or-lose trace-id)))) 225 226 (defslyfun dialog-trace (spec) 227 (let ((function nil)) 228 (flet ((before-hook (args) 229 (setf (current-trace) (make-instance 'trace-entry 230 :spec spec 231 :function (or function 232 spec) 233 :args args 234 :parent (current-trace)))) 235 (after-hook (returned-values) 236 (let ((trace (current-trace))) 237 (when trace 238 (with-slots (retlist parent printed-retlist) trace 239 ;; the current trace might have been wiped away if the 240 ;; user cleared the tree in the meantime. no biggie, 241 ;; don't do anything. 242 ;; 243 (setf retlist returned-values 244 printed-retlist 245 (mapcar (lambda (obj) 246 (present-for-emacs obj #'slynk-pprint-to-line)) 247 (slynk::ensure-list retlist)) 248 (current-trace) parent)))))) 249 (when (dialog-traced-p spec) 250 (warn "~a is apparently already traced! Untracing and retracing." spec) 251 (dialog-untrace spec)) 252 (setq function 253 (slynk-backend:wrap spec 'trace-dialog 254 :before #'before-hook 255 :after #'after-hook)) 256 (pushnew spec *traced-specs*) 257 (format nil "~a is now traced for trace dialog" spec)))) 258 259 (defslyfun dialog-untrace (spec) 260 (with-simple-restart 261 (continue "Never mind, i really want this trace to go away") 262 (slynk-backend:unwrap spec 'trace-dialog)) 263 (setq *traced-specs* (remove spec *traced-specs* :test #'equal)) 264 (format nil "~a is now untraced for trace dialog" spec)) 265 266 (defslyfun dialog-toggle-trace (spec) 267 (if (dialog-traced-p spec) 268 (dialog-untrace spec) 269 (dialog-trace spec))) 270 271 (defslyfun dialog-traced-p (spec) 272 (find spec *traced-specs* :test #'equal)) 273 274 (defslyfun dialog-untrace-all () 275 (let ((regular (length (trace))) 276 (dialog (length *traced-specs*))) 277 (untrace) 278 (mapcar #'dialog-untrace *traced-specs*) 279 (cons regular dialog))) 280 281 282 283 284 ;;;; Hook onto emacs 285 ;;;; 286 (setq slynk:*after-toggle-trace-hook* 287 #'(lambda (spec traced-p) 288 (when *dialog-trace-follows-trace* 289 (cond (traced-p 290 (dialog-trace spec) 291 "traced for trace dialog as well") 292 (t 293 (dialog-untrace spec) 294 "untraced for the trace dialog as well"))))) 295 296 297 ;;;; Instrumentation 298 ;;;; 299 (defmacro instrument (x &optional (id (gensym "EXPLICIT-INSTRUMENT-")) ) 300 (let ((values-sym (gensym))) 301 `(let ((,values-sym (multiple-value-list ,x))) 302 (trace-format (format nil "~a: ~a" ',id "~a => ~{~a~^, ~}") ',x 303 ,values-sym) 304 (values-list ,values-sym)))) 305 306 (provide :slynk/trace-dialog)