Mercurial > core / lisp/lib/rt/tracing.lisp
changeset 698: |
96958d3eb5b0 |
parent: |
12287fab15d0
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
1 ;;; lib/rt/tracing.lisp --- Tracing Framework 3 ;; This package provides utilities for tracing Lisp code and 4 ;; displaying traces to the user. In addition to extending the 5 ;; built-in TRACE macro and SB-DEBUG functionality we have a tracer 6 ;; which works with Chrome's built-in tracer: chrome://trace. 8 ;; The chrome tracer is a slightly modernized version of TeMPOraL's 9 ;; work available here: https://github.com/TeMPOraL/tracer. 11 ;; ref: https://www.chromium.org/developers/how-tos/trace-event-profiling-tool/ 13 ;; - sb-debug manual: https://www.sbcl.org/manual/#Debugger 15 ;; - sb-debug notes: https://gist.github.com/nikodemus/659495 18 (in-package :rt/tracing) 20 (defmacro traced-flet (functions &body body) 21 (flet ((add-traces (function) 23 (name lambda-list &body body) function 26 "Calling ~a with ~@{~a=~a, ~}~%" 28 ,@(loop for symbol in lambda-list 29 collecting `(quote ,symbol) 32 `(flet ,(mapcar #'add-traces functions) ,@body))) 34 ;;; This is an implementation of a chromium-based Lisp tracer authored 35 ;;; by TeMPOraL. The source is available here: 36 ;;; https://github.com/TeMPOraL/tracer/tree/master 38 (defvar *trace-events* nil "A list of trace entries, pushed onto from the beginning.") 40 (defvar *original-trace-start-breakpoint-fun* #'sb-debug::trace-start-breakpoint-fun "Original SBCL function being overwritten by the tracer.") 41 (defvar *original-trace-end-breakpoint-fun* #'sb-debug::trace-end-breakpoint-fun "Original SBCL function being overwritten by the tracer.") 43 (defvar *clock-reset-fun* nil) 44 (defvar *clock-get-time-fun* nil) 46 (defvar *trace-event-default-pid* 1 "The default value for PID for the trace events. This library is currently intended for use within a single process only.") 48 (defvar +arg-converter-ignore-all+ (constantly nil) "A converter that rejects all parameters.") 49 (defvar +arg-converter-passthrough+ (lambda (&rest args) args) "A converter that remembers all args as is, without modifying them.") 50 (defvar +arg-converter-store-only-simple-objects+ (lambda (&rest args) 53 ((or boolean character number symbol) 58 "A converter that remembers directly only objects of simple types, that cannot or are very unlikely to be destructively modified.") 59 (defvar +arg-converter-store-only-simple-objects-and-strings+ (lambda (&rest args) 62 ((or boolean character number symbol string) 67 "Like `+ARG-CONVERTER-STORE-ONLY-SIMPLE-OBJECTS+', but also records strings as-is, hoping they don't get destructively modified too much.") 69 (defvar *default-arg-converter* +arg-converter-ignore-all+) 70 (defvar *tracing-arg-converters* (make-hash-table :test 'equal)) 74 ;;; The format of trace event; created primarily for reference, though later on we might upgrade to vector storage, and then it'll come helpful. 75 (defstruct (trace-event (:type list)) 76 "A single event being traced. " 77 (phase :undefined :type keyword) 78 (name nil :type (or symbol cons)) 80 (timestamp 0 :type fixnum) 82 (duration 0 :type (or null (unsigned-byte 62))) 85 ;;; TODO: define accessors manually, to save performance? or somehow optimize it. -- Jacek Złydach, 2019-11-04 87 (declaim (inline convert-args)) 88 (defun convert-args (traced-fn-name args) 89 "Depending on the function being traced, named `TRACED-FN-NAME', and the value of `*DEFAULT-ARG-CONVERTER*' 90 convert the list of arguments `ARGS' to a form suitable for storing with the trace event, using a converter 91 registered under `*TRACING-ARG-CONVERTERS*'. 92 Returns the representation of `ARGS' to store." 93 (declare (optimize (speed 3))) 94 (apply (the function (gethash traced-fn-name *tracing-arg-converters* *default-arg-converter*)) 97 (declaim (inline make-trace-event-fast)) 98 (defun make-trace-event-fast (phase name thread timestamp args duration id) 99 "Like `MAKE-TRACE-EVENT', but inlined, unsafe and without typechecking." 100 (declare (optimize (speed 3))) 101 (list phase name thread timestamp (convert-args name args) duration id)) 105 ;;; TODO: make it so that user can plug a high-resolution timer here. -- Jacek Złydach, 2019-10-18 107 (sb-ext:defglobal *hack-clock-jitter* 0 "A crude hack because our clock has too little resolution.") 108 (declaim (type fixnum *hack-clock-jitter*)) 110 ;;; TODO: this needs to be a function that can be changed between invocations of tracing! 111 ;;; I want to allow for injecting higher resolution clocks if available. 112 ;;; -- Jacek Złydach, 2019-11-01 114 (defun get-current-time-usec* () 115 "Get current time with microsecond resolution." 116 (sb-ext:atomic-incf *hack-clock-jitter*) 117 (the (unsigned-byte 62) 118 (+ (* (get-internal-real-time) 1000) 119 *hack-clock-jitter*))) 121 (declaim (ftype (function () (unsigned-byte 62)) get-current-time-usec*) 122 (inline get-current-time-usec*)) 123 (defun get-current-time-usec-nojitter () 124 "Get current time with microsecond resolution. No extra jitter involved." 125 (declare (optimize (speed 3))) 126 (the (unsigned-byte 62) (* (get-internal-real-time) 1000))) 128 ;;; XXX: below is our new, usec clock -- Jacek Złydach, 2019-11-02 129 (let ((clock-offset 0)) 130 (declare (type (unsigned-byte 62) clock-offset)) 131 (defun %%start-clock () 132 (setf clock-offset (sb-kernel::get-time-of-day))) 133 (defun %%get-time-usec () 134 (multiple-value-bind (sec usec) 135 (sb-kernel::get-time-of-day) 136 (+ (* (- sec clock-offset) 1000000) usec))) 137 (defun %%time (thunk) 138 (let ((start (%%get-time-usec))) 140 (- (%%get-time-usec) start))) 141 (setf *clock-reset-fun* #'%%start-clock 142 *clock-get-time-fun* #'%%get-time-usec)) 144 (declaim (ftype (function () (values (unsigned-byte 62) &optional)) get-current-time) 145 (inline get-current-time)) 146 (defun get-current-time () 147 (funcall *clock-get-time-fun*)) 149 (defun post-process-entries (entries &key correct-zero-duration) 150 "Destructively modify `ENTRIES', making it more compact and, if `CORRECT-ZERO-DURATION' is T, 151 changing zero-length events to have 1us length, also modifying other times to offset for that. 152 `ENTRIES' is expected to be in order entries were added. The function maintain separate offsets per (process, thread) pair. 153 Returns a processed list, to replace old value `ENTRIES'. As additional values, returns the total accumulated clock offset, 154 and the stacks containing unclosed duration entries, keyed by thread." 156 (stacks (make-hash-table :test 'equal))) 157 (dolist (entry entries entries) 158 ;; Always update event time to account for clock offset. 159 (incf (trace-event-timestamp entry) offset) 161 ;; Match starting and ending events to offset clock in case of zero-length events, and to convert 162 ;; matching pairs of Duration events into Complete events. 163 (let ((entry-ht-id (cons 1 (trace-event-thread entry)))) ;1 is the currently supported PID 164 (ecase (trace-event-phase entry) 166 ;; Push the :enter entry to stack. 167 (push entry (gethash entry-ht-id stacks))) 169 (let ((begin-event (first (gethash entry-ht-id stacks)))) 170 (if (equalp (trace-event-name begin-event) 171 (trace-event-name entry)) 173 ;; Actual post-processing happens here. 174 ;; If zero-length and correct-zero-duration is on, update close time and offset. 175 (when (and correct-zero-duration 176 (= (trace-event-timestamp begin-event) 177 (trace-event-timestamp entry))) 178 (incf (trace-event-timestamp entry)) 181 ;; Convert task into complete task + counter 182 (setf (trace-event-phase begin-event) :complete 183 (trace-event-phase entry) :skip ;TODO: counters, if any, go here -- Jacek Złydach, 2019-11-04 184 (trace-event-duration begin-event) (- (trace-event-timestamp entry) (trace-event-timestamp begin-event)) 185 (trace-event-args begin-event) `(:in ,(trace-event-args begin-event) :out ,(trace-event-args entry))) 187 ;; Pop the updated entry from stack. 188 (pop (gethash entry-ht-id stacks))) 189 (warn "Recorded entries misordered; expected ~A, got ~A." (trace-event-name begin-event) (trace-event-name entry)))))))) 190 ;; Go over the list again, and remove "skip" entries. 191 (deletef entries :skip :key #'trace-event-phase) 198 (defun %trace-start-breakpoint-fun (info) 201 (lambda (frame bpt &rest args) 202 (declare (ignore bpt)) 203 (sb-debug::discard-invalid-entries frame) 204 (let ((condition (sb-debug::trace-info-condition info)) 205 (wherein (sb-debug::trace-info-wherein info))) 207 (and (not sb-debug::*in-trace*) 209 (apply (cdr condition) frame args)) 211 (sb-debug::trace-wherein-p frame wherein nil))))) 213 (when (sb-debug::trace-info-encapsulated info) 214 (sb-ext:atomic-push (make-trace-event-fast :enter 215 (sb-debug::trace-info-what info) 216 sb-thread:*current-thread* 222 ;; TODO: perhaps remove this, it seems unneeded -- Jacek Złydach, 2019-11-05 223 (with-standard-io-syntax 224 (apply #'sb-debug::trace-maybe-break info (sb-debug::trace-info-break info) "before" 226 (lambda (frame cookie) 227 (declare (ignore frame)) 228 (push (cons cookie conditionp) sb-debug::*traced-entries*))))) 230 (declaim (ftype (function (sb-debug::trace-info) function) %trace-end-breakpoint-fun)) 231 (defun %trace-end-breakpoint-fun (info) 232 (lambda (frame bpt values cookie) 233 (declare (ignore bpt)) 234 (unless (eq cookie (caar sb-debug::*traced-entries*)) 235 (setf sb-debug::*traced-entries* 236 (member cookie sb-debug::*traced-entries* :key #'car))) 238 (let ((entry (pop sb-debug::*traced-entries*))) 239 (when (and (not (sb-debug::trace-info-untraced info)) 241 (let ((cond (sb-debug::trace-info-condition-after info))) 242 (and cond (apply #'funcall (cdr cond) frame values))))) 243 (sb-ext:atomic-push (make-trace-event-fast :exit 244 (sb-debug::trace-info-what info) 245 sb-thread:*current-thread* 252 (apply #'sb-debug::trace-maybe-break info (sb-debug::trace-info-break-after info) "after" 255 (defun install-tracing-overrides () 256 (sb-ext:unlock-package (find-package 'sb-debug)) 257 (setf (symbol-function 'sb-debug::trace-start-breakpoint-fun) #'%trace-start-breakpoint-fun 258 (symbol-function 'sb-debug::trace-end-breakpoint-fun) #'%trace-end-breakpoint-fun) 259 (sb-ext:lock-package (find-package 'sb-debug))) 261 (defun uninstall-tracing-overrides () 262 (sb-ext:unlock-package (find-package 'sb-debug)) 263 (setf (symbol-function 'sb-debug::trace-start-breakpoint-fun) *original-trace-start-breakpoint-fun* 264 (symbol-function 'sb-debug::trace-end-breakpoint-fun) *original-trace-end-breakpoint-fun*) 265 (sb-ext:lock-package (find-package 'sb-debug))) 267 (defun start-tracing (specs) 268 (install-tracing-overrides) 270 (trace :encapsulate t :methods t ,@specs))) 272 (defun stop-tracing () 274 (uninstall-tracing-overrides) 275 #+nil(setf *trace-events* (nreverse *trace-events*)) 276 (multiple-value-bind (events offset stacks) 277 (post-process-entries (nreverse *trace-events*)) 278 (declare (ignore offset stacks)) 279 (setf *trace-events* events)) 280 ;; TODO: report offsets and stacks -- Jacek Złydach, 2019-11-05 283 (defun reset-tracing () 284 (setf *trace-events* nil 285 *hack-clock-jitter* 0)) 287 (defun get-tracing-report-data () 290 ;;; Trace operations: 293 ;;; 2.5 snapshot tracing? 297 (defvar *tracing-p* nil "Is currently tracing activity happening?") 299 ;;; Trace info entry type, for function call 302 ;;; - Function args maybe? (trace-with-args), on enter 303 ;;; - Function return value, on exit 304 ;;; - Beginning or ending 309 ;;; This prints a representation of the return values delivered. 310 ;;; First, this checks to see that cookie is at the top of 311 ;;; *TRACED-ENTRIES*; if it is not, then we need to adjust this list 312 ;;; to determine the correct indentation for output. We then check to 313 ;;; see whether the function is still traced and that the condition 314 ;;; succeeded before printing anything. 316 (defmacro with-tracing ((&rest specs) &body body) 320 (start-tracing ',specs) 327 (defun function-name->name-and-category (function-name) 328 (etypecase function-name 330 (values (symbol-name function-name) (package-name (symbol-package function-name)))) 332 (ecase (first function-name) 334 (values (format nil "~S" function-name) (package-name (symbol-package (second function-name))))) 336 ((method sb-pcl::combined-method) 337 (values (remove #\Newline (format nil "~S" function-name)) 338 (if (consp (second function-name)) 339 (package-name (symbol-package (second (second function-name)))) 340 (package-name (symbol-package (second function-name)))))))))) 342 (defgeneric post-process-arg (arg) 344 "Passthrough method." 346 (prin1-to-string arg)) 347 "!!Error printing argument!!")) 348 (:documentation "A hook useful for changing the printed representation of input and return values.")) 350 (defmethod post-process-arg ((arg sequence)) 351 (if (every (lambda (el) (typep el 'number)) arg) 352 (format nil "[~{~F~^, ~}]" (coerce arg 'list)) 355 ;;; FIXME: Something breaks if not collecting args, and :skip-args is NIL. Probably the getf in printing. -- Jacek Złydach, 2019-11-05 356 (defun trace-event->json (trace-event &key (skip-args nil)) 357 (flet ((sanitize-and-format-args-list (argslist) 358 (if skip-args "\"_\"" 359 (substitute #\Space #\Newline (format nil "[~{~S~^, ~}]" (mapcar #'post-process-arg argslist)))))) 360 (ecase (trace-event-phase trace-event) 362 (multiple-value-bind (name category) 363 (function-name->name-and-category (trace-event-name trace-event)) 365 "{ \"name\" : ~S, \"cat\" : ~S, \"ph\" : \"B\", \"pid\" : 1, \"tid\" : ~D, \"ts\" : ~D, \"args\" : { \"in\" : ~A }}" 368 (sb-impl::get-lisp-obj-address (trace-event-thread trace-event)) 369 (trace-event-timestamp trace-event) 370 (sanitize-and-format-args-list (trace-event-args trace-event))))) 372 (multiple-value-bind (name category) 373 (function-name->name-and-category (trace-event-name trace-event)) 375 "{ \"name\" : ~S, \"cat\" : ~S, \"ph\" : \"E\", \"pid\" : 1, \"tid\" : ~D, \"ts\" : ~D, \"args\" : { \"out\" : ~A }}" 378 (sb-impl::get-lisp-obj-address (trace-event-thread trace-event)) 379 (trace-event-timestamp trace-event) 380 (sanitize-and-format-args-list (trace-event-args trace-event))))) 382 (multiple-value-bind (name category) 383 (function-name->name-and-category (trace-event-name trace-event)) 385 "{ \"name\" : ~S, \"cat\" : ~S, \"ph\" : \"X\", \"pid\" : 1, \"tid\" : ~D, \"ts\" : ~D, \"dur\" : ~D, \"args\" : { \"in\" : ~A, \"out\" : ~A }}" 388 (sb-impl::get-lisp-obj-address (trace-event-thread trace-event)) 389 (trace-event-timestamp trace-event) 390 (trace-event-duration trace-event) 391 (sanitize-and-format-args-list (getf (trace-event-args trace-event) :in)) 392 (sanitize-and-format-args-list (getf (trace-event-args trace-event) :out)))))))) 394 (defun thread->json (thread) 396 "{ \"name\" : \"thread_name\", \"ph\" : \"M\", \"pid\" : 1, \"tid\" : ~D, \"args\" : { \"name\" : ~S }}" 397 (sb-impl::get-lisp-obj-address thread) 398 (sb-thread:thread-name thread))) 400 (defun extract-threads (events) 402 with uniques-ht = (make-hash-table :test #'eq) 405 (setf (gethash (trace-event-thread event) uniques-ht) t) 407 (return (hash-table-keys uniques-ht)))) 409 ;;; FIXME: save with streams instead? -- Jacek Złydach, 2019-10-14 410 (defun save-report (output-file-name &key (skip-args t)) 411 (with-open-file (stream output-file-name :direction :output :if-exists :supersede) 412 ;; TODO: preamble -- Jacek Złydach, 2019-10-14 413 (format stream "{~%\"traceEvents\" : [~%") 415 for (entry . restp) on *trace-events* 417 (write-string (trace-event->json entry :skip-args skip-args) stream) 419 (write-string "," stream) 422 for (thread . restp) on (extract-threads *trace-events*) 424 (write-string "," stream) 427 (write-string (thread->json thread) stream) 429 (write-string "," stream) 433 \"displayTimeUnit\" : \"ms\", 434 \"application\" : \"FIXME\", 435 \"version\" : \"FIXME\", 438 " TODO local-time independent time" 439 ;;(local-time:format-timestring nil (local-time:now)) 445 ;;; Helper function for blacklisting symbols when tracing whole packages. 446 (defun package-symbols-except (name &rest exceptions) 448 (package (sb-impl::find-undeleted-package-or-lose name))) 449 (do-all-symbols (symbol (find-package name)) 450 (when (eql package (symbol-package symbol)) 451 (when (and (fboundp symbol) 452 (not (macro-function symbol)) 453 (not (special-operator-p symbol))) 454 (push symbol symbols)) 455 (let ((setf-name `(setf ,symbol))) 456 (when (fboundp setf-name) 457 (push setf-name symbols))))) 458 (set-difference symbols exceptions :key (lambda (x) 461 (string x))) :test #'string-equal)))