-
-
Notifications
You must be signed in to change notification settings - Fork 7
/
timer.lisp
164 lines (139 loc) · 6.28 KB
/
timer.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
(in-package #:org.shirakumo.trivial-benchmark)
(defvar *default-computations* '(:total :minimum :maximum :median :average :deviation))
(defvar *default-metrics* ())
(defgeneric compute (thing samples))
(defgeneric report-to (stream thing &key))
(defgeneric samples (timer metric))
(defgeneric metric-types (timer))
(defgeneric reset (timer))
(defun report (thing &rest args &key (stream T) &allow-other-keys)
(remf args :stream)
(apply #'report-to stream thing args))
(defmethod compute ((x (eql :count)) (samples vector))
(length samples))
(defmethod compute ((x (eql :samples)) (samples vector))
(length samples))
(defmethod compute ((x (eql :total)) (samples vector))
(if (= 0 (length samples))
:n/a
(reduce #'+ samples)))
(defmethod compute ((x (eql :minimum)) (samples vector))
(if (= 0 (length samples))
:n/a
(reduce #'min samples)))
(defmethod compute ((x (eql :maximum)) (samples vector))
(if (= 0 (length samples))
:n/a
(reduce #'max samples)))
(defmethod compute ((x (eql :median)) (samples vector))
(if (= 0 (length samples))
:n/a
(elt (sort (copy-seq samples) #'<)
(1- (ceiling (/ (length samples) 2))))))
(defmethod compute ((x (eql :average)) (samples vector))
(if (= 0 (length samples))
:n/a
(/ (reduce #'+ samples) (length samples))))
(defmethod compute ((x (eql :deviation)) (samples vector))
(if (= 0 (length samples))
:n/a
(let ((average (compute :average samples)))
(sqrt
(/ (reduce #'+ samples :key (lambda (a) (expt (- a average) 2)))
(length samples))))))
(defmethod compute ((computations sequence) samples)
(map (type-of computations) (lambda (thing) (compute thing samples)) computations))
(defmethod report-to ((stream (eql T)) thing &rest args &key &allow-other-keys)
(apply #'report-to *standard-output* thing args))
(defmethod report-to ((string (eql NIL)) thing &rest args &key &allow-other-keys)
(with-output-to-string (stream)
(apply #'report-to stream thing args)))
(defmethod report-to ((stream stream) (samples vector) &rest args &key computations &allow-other-keys)
(remf args :computations)
(apply #'print-table
(cons (list :computation :value)
(loop for comp in computations
collect (list comp (compute comp samples))))
:stream stream args))
(defclass timer ()
((metrics :initform (make-hash-table :test 'eql) :accessor metrics)))
(defmethod print-object ((timer timer) stream)
(print-unreadable-object (timer stream :type T)
(format stream "~{~a~^ ~}" (metric-types timer))))
(defmethod samples ((timer timer) metric)
(or (gethash metric (metrics timer))
(setf (gethash metric (metrics timer)) (make-array 1024 :adjustable T :fill-pointer 0))))
(defmethod metric-types ((timer timer))
(loop for key being the hash-keys of (metrics timer) collect key))
(defun format-timer-stats (stream timer &rest args
&key (computations *default-computations*)
(metrics *default-metrics*)
&allow-other-keys)
(remf args :computations)
(remf args :metrics)
(apply #'print-table
(cons (cons :- computations)
(loop for metric in (or metrics
(loop for k being the hash-keys of (metrics timer) collect k))
for samples = (samples timer metric)
when (< 0 (length samples))
collect (list* metric
(mapcar (lambda (a)
(typecase a
(float (round-to a 6))
(T a)))
(compute computations samples)))))
:stream stream args))
(defmethod describe-object ((timer timer) stream)
(let ((*print-pretty* T))
(format stream "This is an object for keeping benchmarking data.")
(format stream "~&~%It tracks the following metric types:")
(pprint-indent :block 2 stream)
(format stream "~&~{~a~^, ~}" (metric-types timer))
(terpri stream)
(format stream "~&~%The statistics for the timer are:~&")
(report timer :stream stream)))
(defmethod report-to ((stream stream) (timer timer) &rest args &key &allow-other-keys)
(if (loop for samples being the hash-values of (metrics timer)
thereis (< 0 (length samples)))
(apply #'format-timer-stats stream timer args)
(format stream "No metric has any samples yet."))
timer)
(defmethod reset ((timer timer))
(loop for samples being the hash-values of (metrics timer)
do (setf (fill-pointer samples) 0))
timer)
(defmacro with-sampling ((timer-form &rest samplers) &body forms)
(let* ((timer (gensym "TIMER"))
(commit-fn (gensym "COMMIT"))
(samplers (loop for sampler in (or samplers *default-samplers*)
collect (make-instance sampler)))
(form `(progn ,@forms))
(vars (loop for sampler in samplers
append (variables sampler))))
(loop for sampler in samplers
do (setf form (wrap-measurement-form sampler form)))
`(let ((,timer ,timer-form)
,@(loop for var in vars
collect `(,(first var) ,(second var))))
(declare ,@(loop for var in vars
collect `(type ,(third var) ,(first var))))
(multiple-value-prog1
,form
(macrolet ((,commit-fn (&rest pairs)
`(progn ,@(loop for (metric sample) on pairs by #'cddr
collect `(vector-push-extend (float ,sample 0f0) (samples ,',timer ',metric))))))
,@(loop for sampler in samplers
collect (commit-samples-form sampler commit-fn)))))))
(defmacro with-timing ((n &rest report-args
&key ((:timer timer-form) '(make-instance 'timer))
(samplers *default-samplers*))
&body forms)
(remf report-args :samplers)
(remf report-args :timer)
(let ((timer (gensym "TIMER")))
`(let ((,timer ,timer-form))
(loop repeat ,n
do (with-sampling (,timer ,@samplers)
,@forms))
(report ,timer ,@report-args))))