;;;;

(module micro-benchmark

(;export
  current-benchmark-iterations
  current-benchmark-statistics-set
  (benchmark-measure current-flmicroseconds)
  (benchmark-measure-run list-tabulate)
  benchmark-measure-ips
  (benchmark-run generate-statistics)
  (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 (srfi 1) list-tabulate map!)
  (only micro-stats generate-statistics
    ;#; ;wait for micro-stats validation
    chi-square)
  current-microseconds)

;;;

(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 -> (list-of float)))
;(: benchmark-measure-ips (sexp -> (list-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) -> (list-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 (let ((tmp args)) (if (null? tmp) #f (car tmp)))) )
  obj )

;;;

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

;;

(define-syntax benchmark-measure
  (syntax-rules ()
    ((benchmark-measure ?code ...)
      (let* ((start  (current-flmicroseconds))
             (result (begin ?code ...))
             (stop   (current-flmicroseconds)) )
        (- 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) ) ) ) )

;;

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

(define run-benchmark-ips)
(define iterations-per-100ms)
(let ((+iterations-overhead+ 0.0))

    ;@seconds # of seconds
    ;@warmups # of seconds
    ;
    (set! run-benchmark-ips
      (lambda (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+ (current-flmicroseconds) (secs->μs seconds))))
              (let loop ((timings (list)))
                (if (fp< (current-flmicroseconds) threshold)
                    (let ((before (current-flmicroseconds)))
                      (dotimes (_ per-100ms) (thunk))
                      (let* ((after (current-flmicroseconds))
                             (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
    ;
    (set! iterations-per-100ms
      (lambda (thunk limit)
        (let* ((threshold (fp+ (current-flmicroseconds) (ms->μs limit)))
               (before (current-flmicroseconds)) )
          (let loop ((iterations (the fixnum 0)))
            (let ((after (current-flmicroseconds)))
              (cond ((fp< 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) ) ) ) ) ) ) ) )

    ;overhead is diff of before time & time after some repetitions of no-op
    (let ((before (current-flmicroseconds)))
      (dotimes (_ OVERHEAD-ITERATIONS) #t)
      (set! +iterations-overhead+
            (/ (fp- (current-flmicroseconds) before) OVERHEAD-ITERATIONS)) ) )

) ;module micro-benchmark