Commit | Line | Data |
---|---|---|
7642fe3b MW |
1 | ;;; -*-lisp-*- |
2 | ||
3 | (defpackage #:bench | |
4 | (:use #:common-lisp)) | |
5 | (in-package #:bench) | |
6 | ||
7 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
8 | (cffi:define-foreign-library benchspt | |
9 | (t (:default "libbenchspt"))) | |
10 | (let ((cffi:*foreign-library-directories* | |
11 | (append (mapcar (lambda (p) | |
12 | (make-pathname :name nil :type nil :version nil | |
13 | :defaults p)) | |
14 | (asdf:output-files 'asdf:compile-op | |
15 | (asdf:find-component "bench" | |
16 | "benchspt"))) | |
17 | cffi:*foreign-library-directories*))) | |
18 | ;; sorry about that | |
19 | (cffi:use-foreign-library benchspt))) | |
20 | ||
21 | (export '(get-errno strerror)) | |
22 | (cffi:defcfun ("get_errno" :library benchspt) :int) | |
23 | (cffi:defcfun ("strerror" :library benchspt) :string (err :int)) | |
24 | ||
25 | (export '(system-error | |
26 | system-error-message system-error-errno system-error-string)) | |
27 | (define-condition system-error (error) | |
28 | ((message :type string | |
29 | :initarg :message | |
30 | :reader system-error-message) | |
31 | (errno :type fixnum | |
32 | :initarg :errno | |
33 | :initform (get-errno) | |
34 | :reader system-error-errno))) | |
35 | (defgeneric system-error-string (error) | |
36 | (:method ((error system-error)) (strerror (system-error-errno error)))) | |
37 | (defun system-error (message &optional (errno (get-errno))) | |
38 | (error 'system-error :message message :errno errno)) | |
39 | (defmethod print-object ((error system-error) stream) | |
40 | (format stream "~A: ~A~%" | |
41 | (system-error-message error) | |
42 | (system-error-string error))) | |
43 | ||
44 | (export '(open-cycle-counter close-cycle-counter)) | |
45 | (cffi:defcfun (%open-cycle-counter "open_cycle_counter" :library benchspt) | |
46 | :pointer) | |
47 | (defun open-cycle-counter (&key fail-softly) | |
48 | (let ((counter (%open-cycle-counter))) | |
49 | (cond ((not (cffi:null-pointer-p counter)) counter) | |
50 | ((not fail-softly) (system-error "Failed to open cycle counter")) | |
51 | (t nil)))) | |
52 | (cffi:defcfun (close-cycle-counter "close_cycle_counter" :library benchspt) | |
53 | :void | |
54 | (cy :pointer)) | |
55 | ||
56 | (export '(with-cycle-counter* with-cycle-counter)) | |
57 | (defun with-cycle-counter* (thunk &key fail-softly) | |
58 | (let ((counter (open-cycle-counter :fail-softly fail-softly))) | |
59 | (unwind-protect (funcall thunk counter) | |
60 | (close-cycle-counter counter)))) | |
61 | (defmacro with-cycle-counter | |
62 | ((counter &rest keys &key fail-softly) &body body) | |
63 | (declare (ignore fail-softly)) | |
64 | `(with-cycle-counter* (lambda (,counter) ,@body) ,@keys)) | |
65 | ||
66 | (export 'cycles) | |
67 | (cffi:defcfun (%cycles "cycles" :library benchspt) :int | |
68 | (cy :pointer) (count (:pointer :uint64))) | |
69 | (defun cycles (counter) | |
70 | (cffi:with-foreign-object (count :uint64) | |
71 | (unless (zerop (%cycles counter count)) | |
72 | (system-error "Failed to read cycle counter")) | |
73 | (cffi:mem-ref count :uint64))) | |
74 | ||
75 | (export 'cycles-) | |
76 | (defun cycles- (a b) | |
77 | (mod (- a b) #.(ash 1 64))) | |
78 | ||
79 | (export '(thread-clock thread-clock-as-float)) | |
80 | (cffi:defcstruct (clock :class clock-struct) | |
81 | (sec :int64) | |
82 | (nsec :uint32)) | |
83 | (defmethod cffi:translate-from-foreign (clock (type clock-struct)) | |
84 | (cffi:with-foreign-slots ((sec nsec) clock (:struct clock)) | |
85 | (+ (* 1000000000 sec) nsec))) | |
86 | (cffi:defcfun (%thread-clock "thread_clock" :library benchspt) :int | |
87 | (clk (:pointer (:struct clock)))) | |
88 | (defun thread-clock () | |
89 | (cffi:with-foreign-object (clk '(:struct clock)) | |
90 | (unless (zerop (%thread-clock clk)) | |
91 | (error "Failed to read thread clock: ~A" (strerror (get-errno)))) | |
92 | (cffi:mem-ref clk '(:struct clock)))) | |
93 | (defun thread-clock-as-float (&optional (clock (thread-clock))) | |
94 | (* clock 1.0d-9)) | |
95 | ||
96 | (export '(measure* measure)) | |
97 | (declaim (inline measure*)) | |
98 | (defun measure* (func &key reps (per-rep 1)) | |
99 | (with-cycle-counter (cc :fail-softly t) | |
100 | (flet ((run (reps) | |
101 | #+sbcl (sb-ext:gc :full t) | |
102 | #+ccl (ccl:gc) | |
103 | #+(or clisp ecl) (ext:gc t) | |
104 | #+cmu (ext:gc :full t :verbose nil) | |
105 | ;;#+abcl (ext:gc) -- very slow! | |
106 | (let ((t0 (thread-clock)) | |
107 | (c0 (and cc (cycles cc)))) | |
108 | (funcall func reps) | |
109 | (let ((c1 (and cc (cycles cc))) | |
110 | (t1 (thread-clock))) | |
111 | (values (and cc (cycles- c1 c0)) | |
112 | (thread-clock-as-float (- t1 t0))))))) | |
113 | (multiple-value-bind (cy clk) | |
114 | (cond (reps | |
115 | (run reps)) | |
116 | (t | |
117 | (setf reps 1) | |
118 | (loop (multiple-value-bind (cy clk) (run reps) | |
119 | (when (> clk 0.71d0) (return (values cy clk))) | |
120 | (setf reps (floor reps clk)))))) | |
121 | (let ((all (float (* reps per-rep) 1.0d0))) | |
122 | (values (and cc (/ cy all)) (/ clk all))))))) | |
123 | ||
124 | (defmacro measure | |
125 | (form | |
126 | &key (reps nil repsp) (per-rep nil per-rep-p) | |
127 | (optimize '((speed 3) (space 0) (debug 0) (safety 0)))) | |
128 | (let ((i (gensym "I")) | |
129 | (n (gensym "N")) | |
130 | (hunoz (gensym "HUNOZ-"))) | |
131 | `(measure* (lambda (,n) | |
132 | (declare (type (unsigned-byte 32) ,n) | |
133 | ,@(and optimize `((optimize ,@optimize))) | |
134 | #+sbcl (sb-ext:muffle-conditions style-warning)) | |
135 | (dotimes (,i ,n) | |
136 | (let ((,hunoz ,form)) | |
137 | (declare (ignore ,hunoz))))) | |
138 | ,@(and repsp `(:reps ,reps)) | |
139 | ,@(and per-rep-p `(:per-rep ,per-rep))))) |