Initial commit.

[collect-bench] / bench.lisp

;;; -*-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)))))