chiark - git - mdw - collect-bench/blob - bench.lisp

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