;;;;

(module micro-benchmark

(;export
  current-benchmark-iterations
  current-benchmark-statistics-set
  (benchmark-measure *realtime-microsecs)
  (benchmark-measure-run list-tabulate)
  benchmark-measure-ips
  (benchmark-run generate-statistics)
  (benchmark-ips generate-statistics)
  ;#; ;wait for micro-stats validation
  (with-expected-benchmark generate-statistics chi-square)
  run-benchmark-ips)

(import scheme
  (chicken base)
  (chicken type)
  (chicken syntax)
  (chicken foreign)
  (chicken fixnum)
  (chicken flonum)
  (only (srfi 1) list-tabulate map!)
  (only micro-stats generate-statistics
    ;#; ;wait for micro-stats validation
    chi-square))

(cond-expand
  (macosx
    (include "macosx") )
  ((or mingw32 cygwin)
    (include "windows") )
  (unix ;(or netbsd openbsd freebsd linux)
    (include "unix") )
  (else
    (error "unsupported platform") ) )

;;;

;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 ((?locnam (cadr frm))
            (?typnam (caddr frm))
            (?body (cdddr frm))
            (_lambda (rnm 'lambda)) )
        `(,_lambda (obj)
          (,(symbol-append 'check- (strip-syntax ?typnam)) ',?locnam obj)
          ,@?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 (check-fixnum loc obj . args)
  (unless (fixnum? obj)
    (error-fixnum loc obj (let ((tmp args)) (if (null? tmp) #f (car tmp)))) )
  obj )

(define (error-fixnum loc obj #!optional argnam)
  (import (only (chicken string) conc))
  (##sys#signal-hook #:type-error loc
    (string-append
      (if (not argnam) "bad argument" (conc "bad `" argnam "' argument"))
      " type - not " "an " "fixnum")
    obj) )

(define (check-statistics-set-id loc obj . args)
  (unless (statistics-set-id? obj)
    (error-fixnum loc obj (let ((tmp args)) (if (null? tmp) #f (car tmp)))) )
  obj )

(define (error-statistics-set-id loc obj #!optional argnam)
  (import (only (chicken string) conc))
  (##sys#signal-hook #:type-error loc
    (string-append
      (if (not argnam) "bad argument" (conc "bad `" argnam "' argument"))
      " type - not " "an " "statistics-set-id")
    obj) )

;;;

(define-type real (or integer float ratnum))

(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 -> (list-of float)))
;(: benchmark-measure-ips (sexp -> (list-of float)))
;(: benchmark-run (sexp -> (or boolean statistics-alist)))
;(: benchmark-ips (sexp -> (or boolean 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) -> (list-of float)))
(: iterations-per-100ms (procedure float -> fixnum float))

;;;

(define (secs->ms secs) (fp* secs 1000.0))
(define (secs->μs secs) (fp* secs 1000000.0))

(define (μs->ms μs) (fp/ μs 1000.0))
(define (μs->secs μs) (fp/ μs 1000000.0))

(define (ms->μs ms) (fp* ms 1000.0))

;;

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

(define (check-statistics-set-id loc obj . args)
  (unless (statistics-set-id? obj)
    (error-fixnum loc obj (let ((tmp args)) (if (null? tmp) #f (car tmp)))) )
  obj )

(define (error-statistics-set-id loc obj #!optional argnam)
  (import (only (chicken string) conc))
  (##sys#signal-hook #:type-error loc
    (string-append
      (if (not argnam) "bad argument" (conc "bad `" argnam "' argument"))
      " type - not " "an " "statistics-set-id")
    obj) )

;;

(define-constant INITIAL-ITERATIONS 100)

(define-constant DEFAULT-SECONDS 5)
(define-constant DEFAULT-WARMUPS 2)

;;

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

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

;;

(cond-expand
  (reliable-time
    (define *realtime-microsecs realtime-microsecs) )
  (else
    (define (*realtime-microsecs)
      (let ((μs (realtime-microsecs)))
        (when (negative? μs) (warning "cannot retrieve time reliably"))
        μs ) ) ) )

(define-syntax benchmark-measure
  (syntax-rules ()
    ((benchmark-measure ?code ...)
      (let* ((start  (*realtime-microsecs))
             (result (begin ?code ...))
             (stop   (*realtime-microsecs)) )
        (- stop 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 ...)
      (list-tabulate ?tabs (lambda _ (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 ...)
      (let ((observed (benchmark-measure-run (?tabs) ?code0 ?code1 ...)))
        (generate-statistics observed ?stat-set) ) )
    ;
    ;C4 API
    ((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) ) ) ) )

;;

;any overhead
(define *iterations-overhead* 0.0)
;calc any overhead
(define-constant OVERHEAD-ITERATIONS 10000000)
(let ((before (*realtime-microsecs)))
  (dotimes (_ OVERHEAD-ITERATIONS) (void))
  (set! *iterations-overhead* (/ OVERHEAD-ITERATIONS (fp- (*realtime-microsecs) before))) )

;@seconds # of seconds
;@warmups # of seconds
;
(define (run-benchmark-ips thunk #!optional seconds warmups)
  ;order is important
  (let ((seconds (exact->inexact (or seconds DEFAULT-SECONDS)))
        (warmups (exact->inexact (or warmups DEFAULT-WARMUPS))) )
    (let-values (((per-100ms _) (iterations-per-100ms thunk (secs->ms warmups))))
      (let ((threshold (fp+ (*realtime-microsecs) (secs->μs seconds))))
        (let loop ((timings (list)))
          (if (< (*realtime-microsecs) threshold)
            (let ((before (*realtime-microsecs)))
              (dotimes (_ per-100ms) (thunk))
              (let* ((after (*realtime-microsecs))
                     (overhead (* per-100ms *iterations-overhead*))
                     (total-time (fp- (fp- after before) overhead)) )
                (loop (cons total-time timings)) ) )
            (map! (lambda (t) (/ per-100ms (μs->secs t))) timings) ) ) ) ) ) )

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

) ;module micro-benchmark