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