+;;; -*-lisp-*-
+
+(defpackage #:bench
+ (:use #:common-lisp))
+(in-package #:bench)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (cffi:define-foreign-library benchspt
+ (t (:default "libbenchspt")))
+ (let ((cffi:*foreign-library-directories*
+ (append (mapcar (lambda (p)
+ (make-pathname :name nil :type nil :version nil
+ :defaults p))
+ (asdf:output-files 'asdf:compile-op
+ (asdf:find-component "bench"
+ "benchspt")))
+ cffi:*foreign-library-directories*)))
+ ;; sorry about that
+ (cffi:use-foreign-library benchspt)))
+
+(export '(get-errno strerror))
+(cffi:defcfun ("get_errno" :library benchspt) :int)
+(cffi:defcfun ("strerror" :library benchspt) :string (err :int))
+
+(export '(system-error
+ system-error-message system-error-errno system-error-string))
+(define-condition system-error (error)
+ ((message :type string
+ :initarg :message
+ :reader system-error-message)
+ (errno :type fixnum
+ :initarg :errno
+ :initform (get-errno)
+ :reader system-error-errno)))
+(defgeneric system-error-string (error)
+ (:method ((error system-error)) (strerror (system-error-errno error))))
+(defun system-error (message &optional (errno (get-errno)))
+ (error 'system-error :message message :errno errno))
+(defmethod print-object ((error system-error) stream)
+ (format stream "~A: ~A~%"
+ (system-error-message error)
+ (system-error-string error)))
+
+(export '(open-cycle-counter close-cycle-counter))
+(cffi:defcfun (%open-cycle-counter "open_cycle_counter" :library benchspt)
+ :pointer)
+(defun open-cycle-counter (&key fail-softly)
+ (let ((counter (%open-cycle-counter)))
+ (cond ((not (cffi:null-pointer-p counter)) counter)
+ ((not fail-softly) (system-error "Failed to open cycle counter"))
+ (t nil))))
+(cffi:defcfun (close-cycle-counter "close_cycle_counter" :library benchspt)
+ :void
+ (cy :pointer))
+
+(export '(with-cycle-counter* with-cycle-counter))
+(defun with-cycle-counter* (thunk &key fail-softly)
+ (let ((counter (open-cycle-counter :fail-softly fail-softly)))
+ (unwind-protect (funcall thunk counter)
+ (close-cycle-counter counter))))
+(defmacro with-cycle-counter
+ ((counter &rest keys &key fail-softly) &body body)
+ (declare (ignore fail-softly))
+ `(with-cycle-counter* (lambda (,counter) ,@body) ,@keys))
+
+(export 'cycles)
+(cffi:defcfun (%cycles "cycles" :library benchspt) :int
+ (cy :pointer) (count (:pointer :uint64)))
+(defun cycles (counter)
+ (cffi:with-foreign-object (count :uint64)
+ (unless (zerop (%cycles counter count))
+ (system-error "Failed to read cycle counter"))
+ (cffi:mem-ref count :uint64)))
+
+(export 'cycles-)
+(defun cycles- (a b)
+ (mod (- a b) #.(ash 1 64)))
+
+(export '(thread-clock thread-clock-as-float))
+(cffi:defcstruct (clock :class clock-struct)
+ (sec :int64)
+ (nsec :uint32))
+(defmethod cffi:translate-from-foreign (clock (type clock-struct))
+ (cffi:with-foreign-slots ((sec nsec) clock (:struct clock))
+ (+ (* 1000000000 sec) nsec)))
+(cffi:defcfun (%thread-clock "thread_clock" :library benchspt) :int
+ (clk (:pointer (:struct clock))))
+(defun thread-clock ()
+ (cffi:with-foreign-object (clk '(:struct clock))
+ (unless (zerop (%thread-clock clk))
+ (error "Failed to read thread clock: ~A" (strerror (get-errno))))
+ (cffi:mem-ref clk '(:struct clock))))
+(defun thread-clock-as-float (&optional (clock (thread-clock)))
+ (* clock 1.0d-9))
+
+(export '(measure* measure))
+(declaim (inline measure*))
+(defun measure* (func &key reps (per-rep 1))
+ (with-cycle-counter (cc :fail-softly t)
+ (flet ((run (reps)
+ #+sbcl (sb-ext:gc :full t)
+ #+ccl (ccl:gc)
+ #+(or clisp ecl) (ext:gc t)
+ #+cmu (ext:gc :full t :verbose nil)
+ ;;#+abcl (ext:gc) -- very slow!
+ (let ((t0 (thread-clock))
+ (c0 (and cc (cycles cc))))
+ (funcall func reps)
+ (let ((c1 (and cc (cycles cc)))
+ (t1 (thread-clock)))
+ (values (and cc (cycles- c1 c0))
+ (thread-clock-as-float (- t1 t0)))))))
+ (multiple-value-bind (cy clk)
+ (cond (reps
+ (run reps))
+ (t
+ (setf reps 1)
+ (loop (multiple-value-bind (cy clk) (run reps)
+ (when (> clk 0.71d0) (return (values cy clk)))
+ (setf reps (floor reps clk))))))
+ (let ((all (float (* reps per-rep) 1.0d0)))
+ (values (and cc (/ cy all)) (/ clk all)))))))
+
+(defmacro measure
+ (form
+ &key (reps nil repsp) (per-rep nil per-rep-p)
+ (optimize '((speed 3) (space 0) (debug 0) (safety 0))))
+ (let ((i (gensym "I"))
+ (n (gensym "N"))
+ (hunoz (gensym "HUNOZ-")))
+ `(measure* (lambda (,n)
+ (declare (type (unsigned-byte 32) ,n)
+ ,@(and optimize `((optimize ,@optimize)))
+ #+sbcl (sb-ext:muffle-conditions style-warning))
+ (dotimes (,i ,n)
+ (let ((,hunoz ,form))
+ (declare (ignore ,hunoz)))))
+ ,@(and repsp `(:reps ,reps))
+ ,@(and per-rep-p `(:per-rep ,per-rep)))))