;;;; (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) (let ( (seconds (or seconds DEFAULT-SECONDS)) (warmups (or warmups DEFAULT-WARMUPS)) ) (let-values ( ((per-100ms _) (iterations-per-100ms thunk (secs->ms (exact->inexact warmups)))) ((threshold) (fp+ (*realtime-microsecs) (secs->μs (exact->inexact 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