slynk-profiler.lisp (6901B)
1 (defpackage :slynk-profiler 2 (:use :cl) 3 (:import-from :slynk :defslyfun :from-string :to-string) 4 (:export #:toggle-timing 5 #:untime-spec 6 #:clear-timing-tree 7 #:untime-all 8 #:timed-spec-p 9 #:time-spec)) 10 11 (in-package :slynk-profiler) 12 13 (defvar *timing-lock* (slynk-backend:make-lock :name "slynk-timings lock")) 14 15 (defvar *current-timing* nil) 16 17 (defvar *timed-spec-lists* (make-array 10 18 :fill-pointer 0 19 :adjustable t)) 20 21 (defun started-timing ()) 22 23 (defmethod timed-specs () 24 (aref *timed-spec-lists* (1- (fill-pointer *timed-spec-lists*)))) 25 26 (defmethod (setf timed-specs) (value) 27 (setf (aref *timed-spec-lists* (1- (fill-pointer *timed-spec-lists*))) value)) 28 29 (defclass timing () 30 ((parent :reader parent-of :initform *current-timing* ) 31 (origin :initarg :origin :reader origin-of 32 :initform (error "must provide an ORIGIN for this TIMING")) 33 (start :reader start-of :initform (get-internal-real-time)) 34 (end :accessor end-of :initform nil))) 35 36 (defclass timed-spec () 37 ((spec :initarg :spec :accessor spec-of 38 :initform (error "must provide a spec")) 39 (stats :accessor stats-of) 40 (total :accessor total-of) 41 (subtimings :accessor subtimings-of) 42 (owntimings :accessor owntimings-of))) 43 44 (defun get-singleton-create (spec) 45 (let ((existing (find spec (timed-specs) :test #'equal :key #'spec-of))) 46 (if existing 47 (reinitialize-instance existing) 48 (let ((new (make-instance 'timed-spec :spec spec))) 49 (push new (timed-specs)) 50 new)))) 51 52 (defmethod shared-initialize :after ((ts timed-spec) slot-names &rest initargs) 53 (declare (ignore slot-names)) 54 (setf (stats-of ts) (make-hash-table) 55 (total-of ts) 0 56 (subtimings-of ts) nil 57 (owntimings-of ts) nil) 58 (loop for otherts in (remove ts (timed-specs)) 59 do (setf (gethash ts (stats-of otherts)) 0) 60 (setf (gethash otherts (stats-of ts)) 0))) 61 62 (defmethod initialize-instance :after ((tm timing) &rest initargs) 63 (declare (ignore initargs)) 64 (push tm (owntimings-of (origin-of tm))) 65 (let ((parent (parent-of tm))) 66 (when parent 67 (push tm (subtimings-of (origin-of parent)))))) 68 69 (defmethod (setf end-of) :after (value (tm timing)) 70 (let* ((parent (parent-of tm)) 71 (parent-origin (and parent (origin-of parent))) 72 (origin (origin-of tm)) 73 (tm1 (pop (owntimings-of origin))) 74 (tm2 (and parent 75 (pop (subtimings-of parent-origin)))) 76 (delta (- value (start-of tm)))) 77 (assert (eq tm tm1) nil "Hmm something's gone wrong in the owns") 78 (assert (or (null tm2) 79 (eq tm tm2)) nil "Something's gone wrong in the subs") 80 (when (null (owntimings-of origin)) 81 (incf (total-of origin) delta)) 82 (when (and parent-origin 83 (null (subtimings-of parent-origin))) 84 (incf (gethash origin (stats-of parent-origin)) 85 delta)))) 86 87 (defmethod duration ((tm timing)) 88 (/ (- (or (end-of tm) 89 (get-internal-real-time)) 90 (start-of tm)) 91 internal-time-units-per-second)) 92 93 (defmethod print-object ((tm timing) stream) 94 (print-unreadable-object (tm stream :type t :identity t) 95 (format stream "~a: ~f~a" 96 (spec-of (origin-of tm)) 97 (duration tm) 98 (if (not (end-of tm)) "(unfinished)" "")))) 99 100 (defmethod print-object ((e timed-spec) stream) 101 (print-unreadable-object (e stream :type t) 102 (format stream "~a ~fs" (spec-of e) 103 (/ (total-of e) 104 internal-time-units-per-second)))) 105 106 (defslyfun time-spec (spec) 107 (when (timed-spec-p spec) 108 (warn "~a is apparently already timed! Untiming and retiming." spec) 109 (untime-spec spec)) 110 (let ((timed-spec (get-singleton-create spec))) 111 (flet ((before-hook (args) 112 (declare (ignore args)) 113 (setf *current-timing* 114 (make-instance 'timing :origin timed-spec))) 115 (after-hook (retlist) 116 (declare (ignore retlist)) 117 (let* ((timing *current-timing*)) 118 (when timing 119 (setf (end-of timing) (get-internal-real-time)) 120 (setf *current-timing* (parent-of timing)))))) 121 (slynk-backend:wrap spec 'timings 122 :before #'before-hook 123 :after #'after-hook) 124 (format nil "~a is now timed for timing dialog" spec)))) 125 126 (defslyfun untime-spec (spec) 127 (slynk-backend:unwrap spec 'timings) 128 (let ((moribund (find spec (timed-specs) :test #'equal :key #'spec-of))) 129 (setf (timed-specs) (remove moribund (timed-specs))) 130 (loop for otherts in (timed-specs) 131 do (remhash moribund (stats-of otherts)))) 132 (format nil "~a is now untimed for timing dialog" spec)) 133 134 (defslyfun toggle-timing (spec) 135 136 (if (timed-spec-p spec) 137 (untime-spec spec) 138 (time-spec spec))) 139 140 (defslyfun timed-spec-p (spec) 141 (find spec (timed-specs) :test #'equal :key #'spec-of)) 142 143 (defslyfun untime-all () 144 (mapcar #'untime-spec (timed-specs))) 145 146 147 ;;;; Reporting to emacs 148 ;;; 149 (defun describe-timing-for-emacs (timed-spec) 150 (declare (ignore timed-spec)) 151 `not-implemented) 152 153 (defslyfun report-latest-timings () 154 (loop for spec in (timed-specs) 155 append (loop for partial being the hash-values of (stats-of spec) 156 for path being the hash-keys of (stats-of spec) 157 collect (list (slynk-api:slynk-pprint-to-line spec) partial 158 (slynk-api:slynk-pprint-to-line path))))) 159 160 (defun print-tree () 161 (loop for ts in (timed-specs) 162 for total = (total-of ts) 163 do (format t "~%~a~%~%" ts) 164 (when (plusp total) 165 (loop for partial being the hash-values of (stats-of ts) 166 for path being the hash-keys of (stats-of ts) 167 when (plusp partial) 168 sum partial into total-partials 169 and 170 do (format t " ~8fs ~4f% ~a ~%" 171 (/ partial 172 internal-time-units-per-second) 173 (* 100 (/ partial 174 total)) 175 (spec-of path)) 176 finally 177 (format t " ~8fs ~4f% ~a ~%" 178 (/ (- total total-partials) 179 internal-time-units-per-second) 180 (* 100 (/ (- total total-partials) 181 total)) 182 'other))))) 183 184 (defslyfun clear-timing-tree () 185 (setq *current-timing* nil) 186 (loop for ts in (timed-specs) 187 do (reinitialize-instance ts))) 188 189 (provide :slynk/profiler)