microbench.lisp: data-thin -> data-binding.
[commonqt:commonqt.git] / test / microbench.lisp
1 ;;;;
2 ;;;; Evaluate
3 ;;;;   (qt::microbench)
4 ;;;; to run these benchmarks on an otherwise idle computer.  Results are
5 ;;;; written to the REPL, and in a machine readable format also dribbled
6 ;;;; to files.  Files names are, by default, of the form <lisp
7 ;;;; implementation type>.txt.
8 ;;;;
9 ;;;; Notes:
10 ;;;;  1. These are microbenchmarks meant to aid understanding of the
11 ;;;;     implementation.  They do not necessarily reflect overall or
12 ;;;;     real-world performance.
13 ;;;;  2. Since each individual operation is too fast to benchmark, we
14 ;;;;     invoke them a large number of times and compute the average run
15 ;;;;     time afterwards.
16 ;;;;  3. Before running benchmarks, we choose a repetition time depending
17 ;;;;     on how fast (or slow) a simple test case is, so that slow Lisps
18 ;;;;     don't waste endless time running benchmarks.
19 ;;;;  4. Benchmarks are run three times, and only the best run of those
20 ;;;;     three is reported, to account for issues with background activity
21 ;;;;     on the computer ruining the results.
22 ;;;;  5. But you should _still_ run the overall benchmarks several times
23 ;;;;     and see how reproducible the numbers are.
24 ;;;;
25 ;;;; There's no tool to parse the output files and drawn graphs yet, but
26 ;;;; there should be.  (READ-MICROBENCH-RESULTS already fetches the raw
27 ;;;; sexps from each file though, just to check that they are READable).
28
29 (in-package :qt)
30
31 (named-readtables:in-readtable :qt)
32
33
34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35 ;;; bench
36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37
38 (defmacro measure-dotimes ((var repeat) &body body)
39   `(%measure-dotimes (lambda (,var) (declare (ignorable ,var)) ,@body)
40                      ,repeat))
41
42 (defun %measure-dotimes (fun repeat)
43   "Call fun repeatedly without GCing, as often as specified by REPEAT.
44    Return the average run time per repetition in microseconds."
45   (let ((run0 (get-internal-run-time)))
46     (#+ccl ccl::without-gcing
47            #+sbcl sb-sys:without-gcing
48            (dotimes (i repeat)
49              (funcall fun i)))
50     (let* ((run1 (get-internal-run-time))
51            (q
52             (float (* (- run1 run0)
53                       (/ 1000000000 internal-time-units-per-second)
54                       (/ repeat)))))
55       (if (< q 10)
56           q
57           (round q)))))
58
59 (defparameter *repeat*
60   50000)
61
62 (defun bench-new-qobject (&optional (repeat *repeat*))
63   (let ((objects (make-array repeat)))
64     (prog1
65         (measure-dotimes (x repeat)
66           (setf (elt objects x) (#_new QObject)))
67       (iter (for object in-vector objects)
68             (#_delete object)))))
69
70 (defun bench-new-qcolor (&optional (repeat *repeat*))
71   (let ((objects (make-array repeat)))
72     (prog1
73         (measure-dotimes (x repeat)
74           (setf (elt objects x) (#_new QColor)))
75       (iter (for object in-vector objects)
76             (#_delete object)))))
77
78 (defun bench-new-qcolor/3 (&optional (repeat *repeat*))
79   (let ((objects (make-array repeat)))
80     (prog1
81         (measure-dotimes (x repeat)
82           (setf (elt objects x) (#_new QColor #xca #xfe #xba)))
83       (iter (for object in-vector objects)
84             (#_delete object)))))
85
86 (defun bench-new-qcolor/4 (&optional (repeat *repeat*))
87   (let ((objects (make-array repeat)))
88     (prog1
89         (measure-dotimes (x repeat)
90           (setf (elt objects x) (#_new QColor #xca #xfe #xba #xbe)))
91       (iter (for object in-vector objects)
92             (#_delete object)))))
93
94 (defun bench-delete-qobject (&optional (repeat *repeat*))
95   (let ((objects (make-array repeat)))
96     (dotimes (i repeat)
97       (setf (elt objects i)
98             (#_new QObject)))
99     (measure-dotimes (i repeat)
100       (#_delete (elt objects i)))))
101
102 (defun bench-delete-alternating (&optional (repeat *repeat*))
103   (let ((objects (make-array repeat)))
104     (dotimes (i repeat)
105       (setf (elt objects i)
106             (if (evenp i)
107                 (#_new QObject)
108                 (#_new QColor))))
109     (measure-dotimes (i repeat)
110       (#_delete (elt objects i)))))
111
112 (defun measure-on-qobjects (fun repeat)
113   (let ((objects (make-array repeat)))
114     (dotimes (i repeat)
115       (setf (elt objects i)
116             (#_new QObject)))
117     (prog1
118         (measure-dotimes (i repeat)
119           (funcall fun objects i))
120       (iter (for object in-vector objects)
121             (#_delete object)))))
122
123 (defun bench-call-parent (&optional (repeat *repeat*))
124   (measure-on-qobjects (lambda (objects i)
125                          (#_parent (elt objects i)))
126                        repeat))
127
128 (defun bench-call-setparent0 (&optional (repeat *repeat*))
129   (let ((x (null-qobject (find-qclass "QObject"))))
130     (measure-on-qobjects (lambda (objects i)
131                            (#_setParent (elt objects i) x))
132                          repeat)))
133
134 (defun bench-call-setparent (&optional (repeat *repeat*))
135   (let ((others (make-array repeat)))
136     (dotimes (i repeat)
137       (setf (elt others i)
138             (#_new QObject)))
139     (prog1
140         (measure-on-qobjects (lambda (objects i)
141                                (#_setParent (elt objects i)
142                                             (elt others i)))
143                              repeat)
144       (iter (for object in-vector others)
145             (#_delete object)))))
146
147 (defun bench-interpret-new-qobject (&optional (repeat *repeat*))
148   (let ((objects (make-array repeat)))
149     (prog1
150         (measure-dotimes (x repeat)
151           (setf (elt objects x) (interpret-new "QObject")))
152       (iter (for object in-vector objects)
153             (#_delete object)))))
154
155 (defun bench-interpret-new-qcolor (&optional (repeat *repeat*))
156   (let ((objects (make-array repeat)))
157     (prog1
158         (measure-dotimes (x repeat)
159           (setf (elt objects x) (interpret-new "QColor")))
160       (iter (for object in-vector objects)
161             (#_delete object)))))
162
163 (defun bench-interpret-new-qcolor/3 (&optional (repeat *repeat*))
164   (let ((objects (make-array repeat)))
165     (prog1
166         (measure-dotimes (x repeat)
167           (setf (elt objects x) (interpret-new "QColor" #xca #xfe #xba)))
168       (iter (for object in-vector objects)
169             (#_delete object)))))
170
171 (defun bench-interpret-new-qcolor/4 (&optional (repeat *repeat*))
172   (let ((objects (make-array repeat)))
173     (prog1
174         (measure-dotimes (x repeat)
175           (setf (elt objects x) (interpret-new "QColor" #xca #xfe #xba #xbe)))
176       (iter (for object in-vector objects)
177             (#_delete object)))))
178
179 (defun bench-interpret-delete-qobject (&optional (repeat *repeat*))
180   (let ((objects (make-array repeat)))
181     (dotimes (i repeat)
182       (setf (elt objects i)
183             (#_new QObject)))
184     (measure-dotimes (i repeat)
185       (interpret-delete (elt objects i)))))
186
187 (defun bench-interpret-call-parent (&optional (repeat *repeat*))
188   (measure-on-qobjects (lambda (objects i)
189                          (interpret-call (elt objects i) "parent"))
190                        repeat))
191
192 (defun bench-interpret-call-setparent0 (&optional (repeat *repeat*))
193   (let ((x (null-qobject (find-qclass "QObject"))))
194     (measure-on-qobjects (lambda (objects i)
195                            (interpret-call (elt objects i) "setParent" x))
196                          repeat)))
197
198 (defun bench-interpret-call-setparent (&optional (repeat *repeat*))
199   (let ((others (make-array repeat)))
200     (dotimes (i repeat)
201       (setf (elt others i)
202             (#_new QObject)))
203     (prog1
204         (measure-on-qobjects (lambda (objects i)
205                                (interpret-call (elt objects i)
206                                                "setParent"
207                                                (elt others i)))
208                              repeat)
209       (iter (for object in-vector others)
210             (#_delete object)))))
211
212 (defun bench/nop (&optional (repeat *repeat*))
213   (measure-on-qobjects (lambda (objects i)
214                          (declare (ignore objects i)))
215                        repeat))
216
217
218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
219 ;;; cffi
220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
221
222 (defvar <binding>)
223
224 (defvar <classfn-qobject>)
225 (defvar <classfn-qcolor>)
226
227 (defvar <marg-qobject>)
228 (defvar <marg-qobject-dtor>)
229 (defvar <marg-qcolor>)
230 (defvar <marg-qcolor/3>)
231 (defvar <marg-qcolor/4>)
232 (defvar <marg-qobject-parent>)
233 (defvar <marg-qobject-set-parent>)
234
235 (defmacro %with-stack ((var accessor size) &body body)
236   `(cffi:with-foreign-object (,var '|union StackItem| ,size)
237      (macrolet ((,accessor (i slot)
238                   `(cffi:foreign-slot-value
239                     (cffi:mem-aref ,',var '|union StackItem| ,i)
240                     '|union StackItem|
241                     ',slot)))
242        ,@body)))
243
244 (defmacro %call-classfn (fun arg obj stack)
245   `(cffi:foreign-funcall-pointer
246     ,fun
247     ()
248     :short ,arg
249     :pointer ,obj
250     :pointer ,stack
251     :void))
252
253 (defun bench-new-qobject/cffi (&optional (repeat *repeat*))
254   (declare (optimize speed (safety 0) (debug 0)))
255   (let ((objects (make-array repeat)))
256     (prog1
257         (%with-stack (stack item 2)
258           (measure-dotimes (x repeat)
259             (setf (elt objects x)
260                   (progn
261                     (%call-classfn <classfn-qobject>
262                                    <marg-qobject>
263                                    (cffi:null-pointer)
264                                    stack)
265                     (let ((object (item 0 ptr)))
266                       (setf (item 1 ptr) <binding>)
267                       (%call-classfn <classfn-qobject> 0 object stack)
268                       object)))))
269       (let ((class (find-qclass "QObject")))
270         (iter (for object in-vector objects)
271               (#_delete (%qobject class object)))))))
272
273 (defun bench-new-qcolor/cffi (&optional (repeat *repeat*))
274   (declare (optimize speed (safety 0) (debug 0)))
275   (let ((objects (make-array repeat)))
276     (prog1
277         (%with-stack (stack item 2)
278           (measure-dotimes (x repeat)
279             (setf (elt objects x)
280                   (progn
281                     (%call-classfn <classfn-qcolor>
282                                    <marg-qcolor>
283                                    (cffi:null-pointer)
284                                    stack)
285                     (let ((object (item 0 ptr)))
286                       (setf (item 1 ptr) <binding>)
287                       (%call-classfn <classfn-qcolor> 0 object stack)
288                       object)))))
289       (let ((class (find-qclass "QColor")))
290         (iter (for object in-vector objects)
291               (#_delete (%qobject class object)))))))
292
293 (defun bench-new-qcolor3/cffi (&optional (repeat *repeat*))
294   (declare (optimize speed (safety 0) (debug 0)))
295   (let ((objects (make-array repeat)))
296     (prog1
297         (%with-stack (stack item 4)
298           (measure-dotimes (x repeat)
299             (setf (elt objects x)
300                   (progn
301                     (setf (item 1 int) 1)
302                     (setf (item 2 int) 2)
303                     (setf (item 3 int) 3)
304                     (%call-classfn <classfn-qcolor>
305                                    <marg-qcolor/3>
306                                    (cffi:null-pointer)
307                                    stack)
308                     (let ((object (item 0 ptr)))
309                       (setf (item 1 ptr) <binding>)
310                       (%call-classfn <classfn-qcolor> 0 object stack)
311                       object)))))
312       (let ((class (find-qclass "QColor")))
313         (iter (for object in-vector objects)
314               (#_delete (%qobject class object)))))))
315
316 (defun bench-new-qcolor4/cffi (&optional (repeat *repeat*))
317   (declare (optimize speed (safety 0) (debug 0)))
318   (let ((objects (make-array repeat)))
319     (prog1
320         (%with-stack (stack item 5)
321           (measure-dotimes (x repeat)
322             (setf (elt objects x)
323                   (progn
324                     (setf (item 1 int) 1)
325                     (setf (item 2 int) 2)
326                     (setf (item 3 int) 3)
327                     (setf (item 4 int) 4)
328                     (%call-classfn <classfn-qcolor>
329                                    <marg-qcolor/4>
330                                    (cffi:null-pointer)
331                                    stack)
332                     (let ((object (item 0 ptr)))
333                       (setf (item 1 ptr) <binding>)
334                       (%call-classfn <classfn-qcolor> 0 object stack)
335                       object)))))
336       (let ((class (find-qclass "QColor")))
337         (iter (for object in-vector objects)
338               (#_delete (%qobject class object)))))))
339
340 (defun bench-delete-qobject/cffi (&optional (repeat *repeat*))
341   (let ((objects (make-array repeat)))
342     (dotimes (i repeat)
343       (setf (elt objects i)
344             (qobject-pointer (#_new QObject))))
345     (%with-stack (stack item 1)
346           (measure-dotimes (i repeat)
347             (%call-classfn <classfn-qcolor>
348                            <marg-qobject-dtor>
349                            (elt objects i)
350                            stack)))))
351
352 (defun bench-call-parent/cffi (&optional (repeat *repeat*))
353   (let ((objects (make-array repeat)))
354     (dotimes (i repeat)
355       (setf (elt objects i)
356             (qobject-pointer (#_new QObject))))
357     (prog1
358         (%with-stack (stack item 1)
359           (measure-dotimes (i repeat)
360             (%call-classfn <classfn-qcolor>
361                            <marg-qobject-parent>
362                            (elt objects i)
363                            stack)
364             (item 0 ptr)))
365       (let ((class (find-qclass "QObject")))
366         (iter (for object in-vector objects)
367               (#_delete (%qobject class object)))))))
368
369 (defun bench-call-setparent0/cffi (&optional (repeat *repeat*))
370   (let ((objects (make-array repeat)))
371     (dotimes (i repeat)
372       (setf (elt objects i)
373             (qobject-pointer (#_new QObject))))
374     (prog1
375         (%with-stack (stack item 2)
376           (measure-dotimes (i repeat)
377             (setf (item 1 ptr) (cffi:null-pointer))
378             (%call-classfn <classfn-qobject>
379                            <marg-qobject-set-parent>
380                            (elt objects i)
381                            stack)
382             (item 0 ptr)))
383       (let ((class (find-qclass "QObject")))
384         (iter (for object in-vector objects)
385               (#_delete (%qobject class object)))))))
386
387 (defun bench-call-setparent/cffi (&optional (repeat *repeat*))
388   (let ((objects (make-array repeat))
389         (others (make-array repeat)))
390     (dotimes (i repeat)
391       (setf (elt objects i)
392             (qobject-pointer (#_new QObject)))
393       (setf (elt others i)
394             (qobject-pointer (#_new QObject))))
395     (prog1
396         (%with-stack (stack item 2)
397           (measure-dotimes (i repeat)
398             (setf (item 1 ptr) (elt others i))
399             (%call-classfn <classfn-qobject>
400                            <marg-qobject-set-parent>
401                            (elt objects i)
402                            stack)
403             (item 0 ptr)))
404       (let ((class (find-qclass "QObject")))
405         (iter (for object in-vector objects)
406               (#_delete (%qobject class object)))
407         (iter (for object in-vector others)
408               (#_delete (%qobject class object)))))))
409
410 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
411 ;;; BENCH
412 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
413
414 (defun init/cffi ()
415   (setf <classfn-qobject> (qclass-trampoline-fun (find-qclass "QObject")))
416   (setf <classfn-qcolor> (qclass-trampoline-fun (find-qclass "QColor")))
417   (setf <marg-qobject> (qmethod-classfn-index
418                         (find-applicable-method
419                          (find-qclass "QObject")
420                          "QObject"
421                          nil
422                          nil)))
423   (setf <marg-qobject-dtor> (qmethod-classfn-index
424                              (find-applicable-method
425                               (find-qclass "QObject")
426                               "~QObject"
427                               nil
428                               nil)))
429   (setf <marg-qobject-parent> (qmethod-classfn-index
430                                (find-applicable-method
431                                 (find-qclass "QObject")
432                                 "parent"
433                                 nil
434                                 nil)))
435   (setf <marg-qobject-set-parent> (qmethod-classfn-index
436                                    (find-applicable-method
437                                     (find-qclass "QObject")
438                                     "setParent"
439                                     (list (%qobject (find-qclass "QObject")
440                                                     (cffi:null-pointer)))
441                                     nil)))
442   (setf <marg-qcolor> (qmethod-classfn-index
443                        (find-applicable-method
444                         (find-qclass "QColor")
445                         "QColor"
446                         nil
447                         nil)))
448   (setf <marg-qcolor/3> (qmethod-classfn-index
449                          (find-applicable-method
450                           (find-qclass "QColor")
451                           "QColor"
452                           '(0 0 0)
453                           nil)))
454   (setf <marg-qcolor/4> (qmethod-classfn-index
455                          (find-applicable-method
456                           (find-qclass "QColor")
457                           "QColor"
458                           '(0 0 0 0)
459                           nil)))
460   (setf <binding> (data-binding (data-ref 0))))
461
462 (defun commonqt-directory ()
463   (asdf:component-pathname (asdf:find-system :qt)))
464
465 (defun dribble-setup-info (s)
466   (let ((now (get-universal-time)))
467     (format s "(:test-run :date ~A " now)
468     (multiple-value-bind (sec min h d month y) (decode-universal-time now)
469       (format s ";; ======== ~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D~%"
470               y month d h min sec)))
471   (format s ":commonqt ~S~%"
472           (let* ((dir (commonqt-directory))
473                  (.git (merge-pathnames ".git/" dir))
474                  (ref (with-open-file (s (merge-pathnames "HEAD" .git)
475                                          :if-does-not-exist nil)
476                         (and s (subseq (read-line s) 5)))))
477             (if ref
478                 (with-open-file (s (merge-pathnames ref .git))
479                   (subseq (read-line s) 0 8))
480                 "4.unknown")))
481   (format s ":implementation ~S~%"
482           (format nil "~A ~A"
483                   (lisp-implementation-type)
484                   (lisp-implementation-version)))
485   (format s ":machine: ~S~%"
486           (format nil "~A ~A ~A"
487                   (machine-type)
488                   (machine-version)
489                   (machine-instance)))
490   (format s ":software ~S~%"
491           (format nil "~A ~A"
492                   (software-type)
493                   (software-version))))
494
495 (defun choose-repeat-count (&optional (fun 'bench-call-parent)
496                                       (seconds-for-a-test 2))
497   ;; run the call-parent microbench for at least a second to estimate
498   ;; implementation speed, then choose a good iteration count based on that.
499   (let* ((total-time 0)
500          (niterations 0)
501          (1s 1e9)
502          (good-time-for-a-test (* seconds-for-a-test 1s)))
503     (iter (until (> total-time 1s))
504           (incf total-time
505                 (measure-dotimes (dummy 1)
506                   (let ((arbitrary-number 1000))
507                     (funcall fun arbitrary-number)
508                     (incf niterations arbitrary-number)))))
509     (ceiling (* niterations (/ good-time-for-a-test total-time)))))
510
511 (defun best-of-3-funcall (fun)
512   "Call the function three times and return the best result."
513   (min (funcall fun)
514        (funcall fun)
515        (funcall fun)))
516
517 (defun microbench
518     (&optional (name (lisp-implementation-type)))
519   (ensure-smoke :qtcore)
520   (ensure-smoke :qtgui)
521   (with-open-file (s (make-pathname :name name
522                                     :type "bench-txt"
523                                     :defaults (commonqt-directory))
524                      :direction :output
525                      :if-does-not-exist :create
526                      :if-exists :append)
527     (dribble-setup-info s)
528     (let ((*standard-output* (make-broadcast-stream *standard-output* s))
529           (*repeat* (choose-repeat-count)))
530       (format s ":repeat-count ~D~%" *repeat*)
531       (init/cffi)
532       (format s ":results (~%")
533       (dolist (fun '(bench/nop
534                      bench-new-qobject
535                      bench-delete-qobject
536                      bench-new-qcolor
537                      bench-new-qcolor/3
538                      bench-new-qcolor/4
539                      bench-call-parent
540                      bench-call-setparent0
541                      bench-call-setparent))
542         (format t "(~A ~30T~7D)~%" fun (best-of-3-funcall fun)))
543       ;; give the interpreted functions their own repeat count to avoid
544       ;; long delays:
545       (let ((*repeat* (choose-repeat-count 'bench-interpret-call-parent)))
546         (dolist (fun '(bench-interpret-new-qobject
547                        bench-interpret-delete-qobject
548                        bench-interpret-new-qcolor
549                        bench-interpret-new-qcolor/3
550                        bench-interpret-new-qcolor/4
551                        bench-interpret-call-parent
552                        bench-interpret-call-setparent0
553                        bench-interpret-call-setparent))
554           (format t "(~A ~30T~6D)~%" fun (best-of-3-funcall fun))))
555       ;;
556       ;; The /CFFI tests do not benchmark CommonQt as such; they show
557       ;; how fast we "would" be able to run if we had "optimal"
558       ;; performance while still using kdebindings.  The use cffi to
559       ;; call smoke as efficiently as possible, assuming perfect type
560       ;; information, no runtime dispatch, etc.
561       ;;
562       (format t ";; the following numbers are for comparison only:~%")
563       (let ((*repeat* (choose-repeat-count
564                        'bench-new-qcolor/cffi
565                        ;; hmm, need to force a higher repeat count...:
566                        5)))
567         (dolist (fun '(bench-new-qobject/cffi
568                        bench-delete-qobject/cffi
569                        bench-new-qcolor/cffi
570                        bench-new-qcolor3/cffi
571                        bench-new-qcolor4/cffi
572                        bench-call-parent/cffi
573                        bench-call-setparent0/cffi
574                        bench-call-setparent/cffi))
575           (format t "(~A ~30T~6D)~%" fun (best-of-3-funcall fun)))))
576     (format s "))~%")))
577
578 (defun read-microbench-results (&optional (name (lisp-implementation-type)))
579   (with-open-file (s (make-pathname :name name
580                                     :type "bench-txt"
581                                     :defaults (commonqt-directory)))
582     (iter (for form = (read s nil))
583           (while form)
584           (collect form))))