;;;;

(module micro-benchmark

(;export
  ;
  ITERATIONS-OVERHEAD
  ;syntax re-export
  current-flnanoseconds
  ;
  current-benchmark-iterations
  current-benchmark-statistics-set
  ;
  benchmark-measure
  (benchmark-measure-run vector-tabulate)
  (benchmark-run generate-statistics)
  ;
  benchmark-measure-ips
  (benchmark-ips generate-statistics)
  run-benchmark-ips
  #; ;wait for micro-stats validation
  (with-expected-benchmark generate-statistics chi-square))

(import scheme
  (chicken base)
  (chicken type)
  (chicken syntax)
  (chicken foreign)
  (chicken fixnum)
  (chicken flonum)
  (chicken format)
  (only micro-stats generate-statistics
    ;#; ;wait for micro-stats validation
    chi-square)
  current-nanoseconds)

;;;

(define-type real (or integer float ratnum)) ;not complex

(define-type statistics-alist (or null (list-of (pair symbol *))))

(define-type statistics-set-id (or symbol boolean))

;(: benchmark-measure (sexp -> float))
;(: benchmark-measure-run (sexp -> (vector-of float)))
;(: benchmark-measure-ips (sexp -> (vector-of float)))
;(: benchmark-run (sexp -> (or false statistics-alist)))
;(: benchmark-ips (sexp -> (or false statistics-alist)))

(: current-benchmark-iterations (#!optional fixnum -> fixnum))
(: current-benchmark-statistics-set (#!optional statistics-set-id -> statistics-set-id))
(: run-benchmark-ips (procedure #!optional (or false real) (or false real) -> (vector-of float)))
(: iterations-per-100ms (procedure float -> fixnum float))

;;;

;from miscmacros

;; repeat body n times, w/ countup n bound to v
(define-syntax dotimes
  (syntax-rules ()
    ((dotimes (v n) body ...)
     (dotimes (v n (begin)) body ...))
    ((dotimes (v n f) body ...)
     (let loop ((v 0) (nv n))
       (if (< v nv)
           (begin
             body ...
             (loop (add1 v) nv))
           f)))))

(define-syntax define-parameter
  (syntax-rules ()
    ((define-parameter name value guard)
     (define name (make-parameter value guard)))
    ((define-parameter name value)
     (define name (make-parameter value)))
    ((define-parameter name)
     (define name (make-parameter (void))))))

;from moremacros

(import-for-syntax (only (chicken base) symbol-append))

(define-syntax checked-guard
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'checked-guard frm '(_ symbol symbol . _))
      (let ((_lambda (rnm 'lambda))
            (_let (rnm 'let))
            (_arg (rnm 'arg))
            (?locnam (cadr frm))
            (?typnam (caddr frm))
            (?body (cdddr frm)) )
        (let ((chknam (symbol-append 'check- (strip-syntax ?typnam)))) ;inject
          `(,_lambda (,_arg)
            (,chknam ',?locnam ,_arg)
            (,_let ((obj ,_arg))
              ,@?body
              obj ) ) ) ) ) ) )

(define-syntax define-checked-parameter
  (syntax-rules ()
    ((define-checked-parameter ?name ?init ?typnam ?body0 ...)
      (define-parameter ?name ?init (checked-guard ?name ?typnam ?body0 ...)) ) ) )

;from check-errors

(define (make-bad-argument-type-message #!optional argnam)
  (if (not argnam)
      "bad argument type"
      (format #f "bad `~A' argument type" argnam)) )

(define (make-type-name-tobe-message typnam)
  (format #f "not a ~A" typnam) )

(define (make-error-type-message typnam #!optional argnam)
  (string-append (make-bad-argument-type-message argnam)
                 " - "
                 (make-type-name-tobe-message typnam)) )

#|
(define (error-fixnum loc obj #!optional argnam)
  (##sys#signal-hook #:type-error loc (make-error-type-message "fixnum" argnam) obj) )

;used by current-benchmark-iterations
(define (check-fixnum loc obj . args)
  (unless (fixnum? obj)
    (error-fixnum loc obj (and (not (null? args)) (car args))) )
  obj )
|#

(define (vector-tabulate n func)
  (let ((vec (make-vector n 0)))
    (do ((i 0 (fx+ i 1)))
        ((fx= i n) vec)
      (vector-set! vec i (func i))) ) )

(define (list->vector* ls #!optional (func identity))
  ;ugly, but code reuse
  (vector-tabulate (length ls)
                   (lambda (i)
                     (let ((x (car ls)))
                       (set! ls (cdr ls)) ;yes, i know
                       (func x)))) )

;;;

(define-inline (ns->secs ns) (fp/ ns 1e9))

(define-inline (ms->ns ms) (fp* ms 1e6))

(define-inline (secs->ns secs) (fp* secs 1e9))
(define-inline (secs->ms secs) (fp* secs 1e3))

;;

(define-constant INITIAL-ITERATIONS 100)

(define DEFAULT-IPS-SECONDS 5.0)
(define DEFAULT-IPS-WARMUPS 2.0)

;needs, subtracted, overhead estimate
;converges w/ high iterations (10^9) &
;10^5 is empirically lowest w/ best estimate
;
(define-constant OVERHEAD-ITERATIONS 100000)

;;

(define (benchmark-iterations? obj)
  (and (fixnum? obj) (fx<= 0 obj)) )

(define (error-benchmark-iterations loc obj #!optional argnam)
  (##sys#signal-hook #:type-error loc
    (make-error-type-message "benchmark-iterations" argnam) obj) )

(define (check-benchmark-iterations loc obj #!optional argnam)
  (unless (benchmark-iterations? obj)
    (error-benchmark-iterations loc obj argnam) )
  obj )

(define (statistics-set-id? obj)
  (or (boolean? obj) (eq? obj 'verbose) (eq? obj 'normal)) )

(define (error-statistics-set-id loc obj #!optional argnam)
  (##sys#signal-hook #:type-error loc
    (make-error-type-message "statistics-set-id" argnam) obj) )

(define (check-statistics-set-id loc obj #!optional argnam)
  (unless (statistics-set-id? obj)
    (error-statistics-set-id loc obj argnam) )
  obj )

;;

(define-checked-parameter current-benchmark-iterations INITIAL-ITERATIONS benchmark-iterations)

(define-checked-parameter current-benchmark-statistics-set #f statistics-set-id)

;overhead is diff of before time & time after some repetitions of no-op
(define ITERATIONS-OVERHEAD
        (let ((before (current-flnanoseconds)))
          (dotimes (_ OVERHEAD-ITERATIONS) #t)
          (/ (fp- (current-flnanoseconds) before) OVERHEAD-ITERATIONS)))

;;

(define-syntax benchmark-measure
  (syntax-rules ()
    ((benchmark-measure ?code ...)
      (let ((start (current-flnanoseconds)))
        (begin
          ?code ...
          (- (current-flnanoseconds) start)) ) ) ) )

;; run the given procedure n times and return statistics about the runtime
;; returns an alist with statistics

(define-syntax benchmark-measure-run
  (syntax-rules ()
    ;
    ((benchmark-measure-run (begin ?code ...))
     (benchmark-measure-run () ?code ...) )
    ;
    ((benchmark-measure-run () ?code0 ?code1 ...)
      (benchmark-measure-run ((current-benchmark-iterations)) ?code0 ?code1 ...) )
    ;
    ((benchmark-measure-run (?tabs) ?code0 ?code1 ...)
      (benchmark-measure-run ((current-benchmark-iterations) _ignored) ?code0 ?code1 ...) )
    ;
    ((benchmark-measure-run (#t ?var) ?code0 ?code1 ...)
      (benchmark-measure-run ((current-benchmark-iterations) ?var) ?code0 ?code1 ...) )
    ;
    ((benchmark-measure-run (?tabs ?var) ?code0 ?code1 ...)
      (vector-tabulate ?tabs (lambda (?var) (benchmark-measure ?code0 ?code1 ...))) ) ) )

(define-syntax benchmark-run
  (syntax-rules ()
    ;
    ((benchmark-run () ?code0 ?code1 ...)
      (benchmark-run ((current-benchmark-iterations)) ?code0 ?code1 ...) )
    ;
    ((benchmark-run (?tabs) ?code0 ?code1 ...)
      (benchmark-run (?tabs (current-benchmark-statistics-set)) ?code0 ?code1 ...) )
    ;
    ((benchmark-run (#t ?stat-set) ?code0 ?code1 ...)
      (benchmark-run ((current-benchmark-iterations) ?stat-set) ?code0 ?code1 ...) )
    ;
    ((benchmark-run (?tabs ?stat-set) ?code0 ?code1 ...)
      (benchmark-run (?tabs ?stat-set _ignored) ?code0 ?code1 ...) )
    ;
    ((benchmark-run (#t #t ?var) ?code0 ?code1 ...)
      (benchmark-run ((current-benchmark-iterations) #t ?var) ?code0 ?code1 ...) )
    ;
    ((benchmark-run (#t ?stat-set ?var) ?code0 ?code1 ...)
      (benchmark-run ((current-benchmark-iterations) ?stat-set ?var) ?code0 ?code1 ...) )
    ;
    ((benchmark-run (?tabs #t ?var) ?code0 ?code1 ...)
      (benchmark-run (?tabs (current-benchmark-statistics-set) ?var) ?code0 ?code1 ...) )
    ;
    ((benchmark-run (?tabs ?stat-set ?var) ?code0 ?code1 ...)
      (let ((observed (benchmark-measure-run (?tabs ?var) ?code0 ?code1 ...)))
        (generate-statistics observed ?stat-set) ) )
    ;
    ((benchmark-run ?code)
      (benchmark-run () ?code) )
    ;
    ((benchmark-run ?iters ?code)
      (benchmark-run (?iters) ?code) ) ) )

;; benchmarking that tries to find out how many times your code can run in a given
;; amount of time. Idea from: https://github.com/evanphx/benchmark-ips.
;;
;; The idea is to find out how many iterations we can do in a certain (small) amount
;; of time and then tell how much iterations we can make for a fixed timeframe.
;; This is for cases where you don't want to guess the amount of iterations
;; that are needed to produce values that you can work with.

(define-syntax benchmark-measure-ips
  (syntax-rules ()
    ;
    ((benchmark-measure-ips () ?code0 ?code1 ...)
     (benchmark-measure-ips (#f) ?code0 ?code1 ...) )
    ;
    ((benchmark-measure-ips (?seconds) ?code0 ?code1 ...)
     (benchmark-measure-ips (?seconds #f) ?code0 ?code1 ...) )
    ;
    ((benchmark-measure-ips (?seconds ?warmups) ?code0 ?code1 ...)
      (run-benchmark-ips (lambda () ?code0 ?code1 ...) ?seconds ?warmups) ) ) )

(define-syntax benchmark-ips
  (syntax-rules ()
    ;
    ((benchmark-ips () ?code0 ?code1 ...)
     (benchmark-ips (#f) ?code0 ?code1 ...) )
    ;
    ((benchmark-ips (?seconds) ?code0 ?code1 ...)
     (benchmark-ips (?seconds #f) ?code0 ?code1 ...) )
    ;
    ((benchmark-ips (?seconds ?warmups) ?code0 ?code1 ...)
      (benchmark-ips (?seconds ?warmups (current-benchmark-statistics-set)) ?code0 ?code1 ...) )
    ;
    ((benchmark-ips (?seconds ?warmups ?stat-set) ?code0 ?code1 ...)
      (let ((observed (benchmark-measure-ips (?seconds ?warmups) ?code0 ?code1 ...)))
        (generate-statistics observed ?stat-set) ) )
    ;
    ;C4 API
    ((benchmark-ips ?code)
     (benchmark-ips () ?code) )
    ;
    ((benchmark-ips ?secs ?code)
     (benchmark-ips (?secs) ?code) ) ) )

;;

#; ;wait for micro-stats validation
(define-syntax with-expected-benchmark
  (syntax-rules (w/run w/ips)
    ;
    ((with-expected-benchmark w/run ?expected ?code0 ?code1 ...)
      (with-expected-benchmark ?expected (begin (benchmark-measure-run () ?code0 ?code1 ...))) )
    ;
    ((with-expected-benchmark w/ips ?expected ?code0 ?code1 ...)
      (with-expected-benchmark ?expected (begin (benchmark-measure-ips () ?code0 ?code1 ...))) )
    ;
    ((with-expected-benchmark (w/run ?arg ...) ?expected ?code0 ?code1 ...)
      (with-expected-benchmark ?expected (begin (benchmark-measure-run (?arg ...) ?code0 ?code1 ...))) )
    ;
    ((with-expected-benchmark (w/ips ?arg ...) ?expected ?code0 ?code1 ...)
      (with-expected-benchmark ?expected (begin (benchmark-measure-ips (?arg ...) ?code0 ?code1 ...))) )
    ;
    ;incl chi-square w/ generate-statistics result 4 runs
    ((with-expected-benchmark ?expected (begin ?code ...))
      (let* ((expected ?expected)
             (observed (begin ?code ...) )
        (stats (generate-statistics observed (current-benchmark-statistics-set))) )
        `((runs . ,observed) (chi-square . ,(chi-square observed expected)) ,@stats) ) ) ) )

;;

;@seconds # of seconds or #f (see benchmark-measure-ips)
;@warmups # of seconds or #f (see benchmark-measure-ips)
;
(define (run-benchmark-ips thunk #!optional seconds warmups)
  ;order is important
  (let ((seconds (if seconds (exact->inexact seconds) DEFAULT-IPS-SECONDS))
        (warmups (if warmups (exact->inexact warmups) DEFAULT-IPS-WARMUPS)) )
    (let-values (((per-100ms _) (iterations-per-100ms thunk (secs->ms warmups))))
      (let ((threshold (fp+ (current-flnanoseconds) (secs->ns seconds))))
        (let loop ((timings '()))
          (if (fp< (current-flnanoseconds) threshold)
              (let ((before (current-flnanoseconds)))
                (dotimes (_ per-100ms) (thunk))
                (let* ((after (current-flnanoseconds))
                       (overhead (* per-100ms ITERATIONS-OVERHEAD))
                       (total-time (fp- (fp- after before) overhead)) )
                  (loop (cons total-time timings)) ) )
              (list->vector* timings (lambda (t) (/ per-100ms (ns->secs t)))) ) ) ) ) ) )

;@thunk benchmark procedure
;@limit in milliseconds
;
(define (iterations-per-100ms thunk limit)
  (let* ((before (current-flnanoseconds))
         (threshold (fp+ before (ms->ns limit))) )
    (let loop ((iters (the fixnum 0)))
      (let ((after (current-flnanoseconds)))
        (cond ((fp< after threshold)
                (thunk)
                (loop (fx+ 1 iters)) )
              (else
                (let* ((overhead (* iters ITERATIONS-OVERHEAD))
                       (total-time (fp- (fp- after before) overhead))
                       (per-100ms (fp* (/ iters total-time) (ms->ns 100.0))) )
                  (values (fxmax 1 (inexact->exact (fpround per-100ms)))
                          total-time) ) ) ) ) ) ) )

) ;module micro-benchmark