1
;;;-*- Mode: Lisp; Syntax: Common-lisp; Package: user -*-
3
(in-package :bench :use '(:lisp #-pcl :clos))
6
(eval-when (compile load eval)
7
(shadowing-import 'pcl::dotimes)
11
(eval-when (compile load eval) (pcl::use-package-pcl))
14
(defmacro declaim (arg)
17
;;;Here are a few homebrew benchmarks for testing out Lisp performance.
18
;;; BENCH-THIS-LISP: benchmarks for common lisp.
19
;;; BENCH-THIS-CLOS: benchmarks for CLOS.
20
;;; BENCH-FLAVORS: ditto for Symbolics flavors.
21
;;; BE SURE TO CHANGE THE PACKAGE DEFINITION TO GET THE CLOS + LISP
24
;;;Each benchmark is reported as operations per second. Without-interrupts is
25
;;; used, so the scheduler isn't supposed to get in the way. Accuracy is
26
;;; generally between one and five percent.
28
;;;Elapsed time is measured using get-internal-run-time. Because the accuracy
29
;;; of this number is fairly crude, it is important to use a large number of
30
;;; iterations to get an accurate benchmark. The function median-time may
31
;;; complain to you if you didn't pick enough iterations.
33
;;;July 1992. Watch out! In some cases the instruction being timed will be
34
;;; optimized away by a clever compiler. Beware of benchmarks that are
35
;;; nearly as fast as *speed-of-empty-loop*.
37
;;;Thanks to Ken Anderson for much of this code.
43
(eval-when (compile load eval)
44
(import '(clos-internals::allocate-instance)))
46
(declaim (optimize (speed 3) (safety 1) (space 0)
47
#+lucid (compilation-speed 0)))
49
;;;*********************************************************************
51
(deftype positive-integer () '(integer 0 *))
52
(deftype positive-fixnum () '(and fixnum positive-integer))
55
(declare (type function fn) (type positive-integer n))
56
(multiple-value-bind (ngroups last)
57
(floor n most-positive-fixnum)
58
(declare (type positive-fixnum ngroups last))
60
(declare (type positive-fixnum i))
61
(dotimes (j most-positive-fixnum)
65
(declare (type positive-fixnum j))
69
;; Most compilers other than KCL have optimizers that make this technique
70
;; unreliable for simple forms.
71
(eval-when (compile load eval)
72
(declaim (fixnum *simple-repeat-count* *simple-iteration-count*
73
*total-simple-iterations*))
74
(defparameter *simple-repeat-count* #-kcl 1 #+kcl 10)
75
(defparameter *simple-iteration-count* #-kcl 1 #+kcl 10)
76
(defparameter *total-simple-iterations*
77
(* *simple-repeat-count* *simple-iteration-count*))
80
(defmacro simple-repeat (form)
81
(if (eql *simple-iteration-count* 1)
83
(let ((result (make-symbol "RESULT")))
85
(dotimes (.i. ,*simple-iteration-count* ,result)
86
(declare (fixnum .i.))
88
(dotimes (i *simple-repeat-count* forms)
89
(push `(setq ,result ,form) forms))))))))
92
(defvar *estimated-bytes-per-call* 0)
93
(defvar *bytes-per-word* 4)
94
(declaim (type (and (integer 0 *) fixnum)
95
*bytes-per-word* *estimated-bytes-per-call*))
97
(defmacro with-optional-gc-control (&body body)
99
(ext:*bytes-consed-between-gcs*
101
(+ ext:*bytes-consed-between-gcs*
102
(* *estimated-bytes-per-call* n))
103
ext:*bytes-consed-between-gcs*)))
106
(declaim (single-float *min-time* *one-percent-of-min-time*))
108
(defvar *min-time* (max 1.0 (/ 400.0 (float internal-time-units-per-second)))
109
"At least 2 orders of magnitude larger than our time resolution.")
111
(defparameter *one-percent-of-min-time* (* *min-time* 0.01))
113
(defvar *elapsed-time-result*)
115
(defun elapsed-time (function n)
116
"Returns the time (seconds) it takes to call function n times."
117
(declare (type function function) (integer n))
118
(when (and *use-gc-p* (plusp *estimated-bytes-per-call*))
119
#+cmu (lisp::gc nil))
120
(let ((start-time (get-internal-run-time)))
121
(setq *elapsed-time-result* (repeat function n))
122
(let ((end-time (get-internal-run-time)))
123
(/ (float (abs (- end-time start-time)))
124
(float internal-time-units-per-second)))))
126
(defmacro without-interruption (&body forms)
127
#+genera `(scl:without-interrupts ,@forms)
128
#+lucid `(lcl::with-scheduling-inhibited ,@forms)
129
#+allegro `(excl:without-interrupts ,@forms)
130
#+(and (not genera) (not lucid) (not allegro)) `(progn ,@forms))
132
(declaim (type (function (t function &optional fixnum t) single-float)
133
median-time-internal))
135
(defvar *warn-if-too-fast-p* nil)
137
(defun median-time-internal (form function n &optional (I 5)
138
(warn-p *warn-if-too-fast-p*))
139
"Return the median time it takes to evaluate form."
140
;; I: number of samples to take.
141
(declare (type function function) (fixnum i))
142
(without-interruption
146
(declare (fixnum ignore))
147
(let ((time (elapsed-time function n)))
148
(declare (single-float time))
149
(when (and (< time *min-time*) warn-p)
150
(format t "~% Warning. Evaluating ~S took only ~S seconds.~
151
~% You should probably use more iterations."
153
(push time results)))
154
(nth (truncate I 2) (sort results #'<)))))
156
(defmacro median-time (form n &optional (I 5)
157
(warn-p *warn-if-too-fast-p*))
158
"Return the median time it takes to evaluate form n times."
159
;; I: number of samples to take.
160
`(median-time-internal
162
#'(lambda () (simple-repeat ,form))
163
(ceiling ,n ,*total-simple-iterations*)
168
(defun test () (median-time (sleep 1.0) 5))
171
;;;*********************************************************************
173
;;; OPERATIONS-PER-SECOND actually does the work of computing a benchmark.
174
;;; The amount of time it takes to execute the form N times is recorded,
175
;;; minus the time it takes to execute the empty loop. OP/S = N/time.
176
;;; This quantity is recomputed five times and the median value is returned.
177
;;; Variance in the numbers increases when memory is being allocated (cons,
178
;;; make-instance, etc).
180
(declaim (type (function (t function &optional fixnum integer) single-float)
183
(defun time-form-internal (form function &optional (i 5) (default 100))
184
(declare (integer default) (fixnum i))
185
(with-optional-gc-control
186
(let ((time (median-time-internal form function default i nil)))
187
(declare (single-float time))
188
(loop (when (> time *one-percent-of-min-time*)
190
(setq default (* default 10))
191
(setq time (median-time-internal form function default i nil)))
192
(when (< time *min-time*)
193
(setq default (ceiling default (/ time *min-time*)))
194
(setq time (median-time-internal form function default i nil)))
195
(/ time (float default)))))
197
(defmacro time-form (form &optional (i 5))
198
`(/ (time-form-internal ',form #'(lambda () (simple-repeat ,form)) ,i)
199
,(float *total-simple-iterations*)))
201
(defun compute-speed-of-empty-loop () (time-form nil))
203
(declaim (single-float *speed-of-empty-loop*))
204
(defparameter *speed-of-empty-loop* (compute-speed-of-empty-loop))
206
(format t "~%Empty loops per second: ~40T~8,3E~%"
207
(/ 1.0 *speed-of-empty-loop*))
209
(defmacro operations-per-second (form &optional (i 5))
210
"Return the number of times FORM can evaluate in one second."
211
`(/ 1.0 (- (time-form ,form ,i) *speed-of-empty-loop*)))
213
(defmacro defun-timer (name args &body body)
217
(defmacro bench (pretty-name name)
219
(format t "~%~A: " ,pretty-name) (force-output)
220
(format t "~40T~8,3E" (,name))))
222
;;;****************************************************************************
229
(defun-timer Nmult ()
231
(operations-per-second (* a a))))
235
(operations-per-second (+ a a))))
237
(defun square (x) (* x x))
239
(defun-timer funcall-1 ()
242
(operations-per-second (funcall #'(lambda (a) (* a a)) x))))
246
(defun-timer funcall-2 ()
249
(operations-per-second (funcall f x))))
251
(defun-timer funcall-3 ()
253
(operations-per-second (f1 x))))
255
(defun-timer funcall-4 ()
257
(operations-per-second (funcall #'square x))))
259
(defun-timer funcall-5 ()
262
(let ((g #'(lambda (x)
263
(operations-per-second (funcall f x)))))
266
(defun-timer Nsetf ()
267
(let ((array (make-array 15)))
268
(operations-per-second (setf (aref array 5) t))))
270
(defun-timer Nsymeval () (operations-per-second (eval T)))
272
(defun-timer Repeatuations () (operations-per-second (eval '(* 2.1 2.1))))
274
(defun-timer n-cons () (let ((a 1)) (operations-per-second (cons a a))))
277
(defun-timer nspecial () (operations-per-second (null *object*)))
279
(defun-timer nlexical ()
281
(operations-per-second (null o))))
283
(defun-timer nfree ()
285
(let ((g #'(lambda ()
286
#+genera (declare (sys:downward-function))
287
(operations-per-second (null o)))))
290
(defun-timer nfree2 ()
292
(let ((g #'(lambda ()
293
(let ((f #'(lambda ()
294
#+genera (declare (sys:downward-function))
295
(operations-per-second (null o)))))
299
(defun-timer ncompilations ()
300
(let ((lambda-expression
301
'(lambda (bar) (let ((baz t)) (if baz (cons bar nil))))))
302
(operations-per-second (compile 'bob lambda-expression))))
304
(defun bench-this-lisp ()
305
(bench "(* 2.1 2.1)" nmult)
306
(bench "(+ 2.1 2.1)" nadd)
307
(bench "funcall & (* 2.1 2.1)" funcall-3)
308
(bench "special reference" nspecial)
309
(bench "lexical reference" nlexical)
310
;; (bench "ivar reference" n-ivar-ref)
311
(bench "(setf (aref array 5) t)" nsetf)
312
(bench "(funcall lexical-f x)" funcall-2)
313
(bench "(f x)" funcall-3)
314
;; (Bench "(eval t)" nsymeval)
315
;; (bench "(eval '(* 2.1 2.1))" repeatuations)
316
;; (bench "(cons 1 2)" n-cons)
317
;; (bench "compile simple function" ncompilations)
323
;;;**************************************************************
328
(scl:defflavor bar (a b) ()
329
:initable-instance-variables
330
:writable-instance-variables)
332
(scl:defflavor frob (c) (bar)
333
:initable-instance-variables
334
:writable-instance-variables)
336
(scl:defmethod (hop bar) ()
339
(scl:defmethod (set-hop bar) ()
342
(scl:defmethod (nohop bar) ()
346
(let ((i (scl:make-instance 'bar :a 0 :b 0)))
349
(scl:defmethod (ivar-ref bar) ()
350
(operations-per-second b))
353
(defun-timer Ninstances ()
354
(operations-per-second (flavor:make-instance 'bar)))
356
(defun-timer n-svref ()
357
(let ((instance (flavor:make-instance 'bar :a 1)))
358
(operations-per-second (scl:symbol-value-in-instance instance 'a))))
359
(defun-timer n-hop ()
360
(let ((instance (flavor:make-instance 'bar :a 1)))
361
(operations-per-second (hop instance))))
363
(let ((instance (flavor:make-instance 'bar :a 1)))
364
(operations-per-second (nohop instance))))
365
(defun-timer n-set-hop ()
366
(let ((instance (flavor:make-instance 'bar :a 1)))
367
(operations-per-second (set-hop instance))))
368
(defun-timer n-type-of ()
369
(let ((instance (flavor:make-instance 'bar)))
370
(operations-per-second (flavor::%instance-flavor instance))))
372
(defun-timer n-bar-b ()
373
(let ((instance (flavor:make-instance 'bar :a 0 :b 0)))
374
(operations-per-second (bar-b instance))))
376
(defun-timer n-frob-bar-b ()
377
(let ((instance (flavor:make-instance 'frob :a 0 :b 0)))
378
(operations-per-second (bar-b instance))))
380
(defun bench-flavors ()
381
(bench "flavor:make-instance (2 slots)" ninstances)
382
(bench "flavor:symbol-value-in-instance" n-svref)
383
(bench "1 method, 1 dispatch" n-gf)
384
(bench "slot symbol in method (access)" n-hop)
385
(bench "slot symbol in method (modify)" n-hop)
386
(bench "slot accessor bar" n-bar-b)
387
(bench "slot accessor frob" n-frob-bar-b)
388
(bench "instance-flavor" n-type-of))
392
;;;**************************************************************
395
;;; (evolved from Ken Anderson's tests of Symbolics CLOS)
398
(let ((*default-pathname-defaults* pcl::*pcl-directory*))
399
(load "bench-precompile"))
401
(defmethod strange ((x t)) t) ; default method
402
(defmethod area ((x number)) 'green) ; builtin class
406
((x :initform 0 :accessor x :initarg :x)
407
(y :initform 0 :accessor y :initarg :y)))
409
(defmethod color ((thing point)) 'red)
410
(defmethod address ((thing point)) 'boston)
411
(defmethod area ((thing point)) 0)
412
(defmethod move-to ((p1 point) (p2 point)) 0)
414
(defmethod x-offset ((thing point))
415
(with-slots (x y) thing x))
417
(defmethod set-x-offset ((thing point) new-x)
418
(with-slots (x y) thing (setq x new-x)))
422
((width :initform 10 :accessor width :initarg :width)
423
(height :initform 10 :accessor height :initarg :height)))
425
(defmethod area ((thing box)) 0)
426
(defmethod move-to ((box box) (point point)) 0)
427
(defmethod address :around ((thing box)) (call-next-method))
429
(defvar p (make-instance 'point))
430
(defvar b (make-instance 'box))
432
(defun-timer n-strange () (operations-per-second (strange 5)))
433
(defun-timer n-accesses ()
434
(operations-per-second (x p)))
435
(defun-timer n-color ()
436
(operations-per-second (color p)))
437
(defun-timer n-call-next-method ()
439
(operations-per-second (address p))))
440
(defun-timer n-area-1 ()
441
(operations-per-second (area p)))
442
(defun-timer n-area-2 ()
443
(operations-per-second (area 5)))
444
(defun-timer n-move-1 ()
445
(operations-per-second (move-to p p)))
446
(defun-timer n-move-2 ()
448
(operations-per-second (move-to x y))))
449
(defun-timer n-off ()
450
(operations-per-second (x-offset p)))
451
(defun-timer n-setoff ()
452
(operations-per-second (set-x-offset p 500)))
453
(defun-timer n-slot-value ()
454
(operations-per-second (slot-value p 'x)))
456
(defun-timer n-class-of-1 ()
457
(operations-per-second (class-of p)))
458
#| ; cmucl can't compile this.
459
(defun-timer n-class-of-2 ()
460
(operations-per-second (class-of 5)))
463
(defun-timer n-class-of-2 ()
464
(operations-per-second (class-of nco2)))
466
(defvar *size-of-point* (* *bytes-per-word* 8))
468
(defun-timer n-alloc ()
469
(let ((*estimated-bytes-per-call* *size-of-point*)
470
(c (find-class 'point)))
471
(operations-per-second (allocate-instance c))))
473
(defun-timer n-make ()
474
(let ((*estimated-bytes-per-call* *size-of-point*))
475
(operations-per-second (make-instance 'point))))
477
(defun-timer n-make-initargs ()
478
(let ((*estimated-bytes-per-call* (+ *size-of-point*
479
(* *bytes-per-word* 4))))
480
(operations-per-second (make-instance 'point :x 0 :y 5))))
482
(defun-timer n-make-variable-initargs ()
483
(let ((*estimated-bytes-per-call* (+ *size-of-point*
484
(* *bytes-per-word* 4)))
486
(operations-per-second (make-instance 'point :x x :y y))))
489
(#+pcl pcl::expanding-make-instance-top-level #-pcl progn
491
(defun-timer n-make1 ()
492
(let ((*estimated-bytes-per-call* *size-of-point*))
493
(operations-per-second (make-instance 'point))))
495
(defun-timer n-make-initargs1 ()
496
(let ((*estimated-bytes-per-call* (+ *size-of-point*
497
(* *bytes-per-word* 4))))
498
(operations-per-second (make-instance 'point :x 0 :y 5))))
500
(defun-timer n-make-variable-initargs1 ()
501
(let ((*estimated-bytes-per-call* (+ *size-of-point*
502
(* *bytes-per-word* 4)))
504
(operations-per-second (make-instance 'point :x x :y y))))
509
(defun compile-and-load-file-if-newer (file &rest other-files)
510
#-cmu (declare (ignore other-files))
511
#-cmu (load (compile-file (make-pathname :defaults file :type "lisp")))
512
#+cmu ; uses compile-file-pathname
513
(labels ((type-fwd (file &optional type)
515
(make-pathname :defaults file :type type)
517
(if (probe-file path)
518
(file-write-date path)
521
(max (type-fwd file "lisp")
522
(type-fwd (compile-file-pathname file)))))
524
(dolist (other other-files)
525
(setq other-fwd (max other-fwd (fwd (merge-pathnames other)))))
526
(setq file (merge-pathnames file))
527
(when (< (type-fwd (compile-file-pathname file))
528
(max (type-fwd file "lisp") other-fwd))
533
(let ((*default-pathname-defaults* pcl::*pcl-directory*))
534
(compile-and-load-file-if-newer "bench-precompile" "bench"))
536
#+(and lucid (not pcl))
537
(lcl::precompile-generic-functions)
539
(defun bench-this-clos ()
540
(bench "1 default method" n-strange)
541
(bench "1 dispatch, 1 method" n-color)
542
(bench "1 dispatch, :around + primary" n-call-next-method)
543
(bench "1 dispatch, 3 methods, instance" n-area-1)
544
(bench "1 dispatch, 3 methods, noninstance" n-area-2)
545
(bench "2 dispatch, 2 methods" n-move-1)
546
(bench "slot reader method" n-accesses)
547
(bench "with-slots (1 access)" n-off)
548
(bench "with-slots (1 modify)" n-setoff)
549
(bench "naked slot-value" n-slot-value)
550
(bench "class-of instance" n-class-of-1)
551
(bench "class-of noninstance" n-class-of-2)
552
(bench "allocate-instance (2 slots)" n-alloc)
554
(let ((two-c-i #-pcl "make-instance (2 constant initargs)"
555
#+pcl "make-instance (2 initargs)"))
556
(let ((opt #+(and pcl (not cmu)) ""
557
#+(and pcl cmu) " (opt)"
559
(flet ((c (s) (concatenate 'string s opt)))
560
(bench (c "make-instance (2 slots)") n-make)
561
(bench (c two-c-i) n-make-initargs)
563
(bench (c "make-instance (2 variable initargs)")
564
n-make-variable-initargs)))
566
#+(and pcl (not cmu))
567
(let ((opt " (opt)"))
568
(flet ((c (s) (concatenate 'string s opt)))
569
(bench (c "make-instance (2 slots)") n-make1)
570
(bench (c two-c-i) n-make-initargs1)
572
(bench (c "make-instance (2 variable initargs)")
573
n-make-variable-initargs1)))))
added
removed
pcl/test/bench.lisp
