diff --git a/equal-benchmark.scm b/equal-benchmark.scm new file mode 100644 index 00000000..37e9fbea --- /dev/null +++ b/equal-benchmark.scm @@ -0,0 +1,144 @@ + +(import (scheme base) + (scheme read) + (scheme write) + (scheme time)) + +; Returns a list with n elements, all equal to x. + +(define (make-test-list1 n x) + (if (zero? n) + '() + (cons x (make-test-list1 (- n 1) x)))) + +; Returns a list of n lists, each consisting of n x's. +; The n elements of the outer list are actually the same list. + +(define (make-test-tree1 n) + (if (zero? n) + '() + (make-test-list1 n (make-test-tree1 (- n 1))))) + + + +; Calls the thunk n times. + +(define (iterate n thunk) + (cond ((= n 1) + (thunk)) + ((> n 1) + (thunk) + (iterate (- n 1) thunk)) + (else #f))) + + +; DAG with much sharing. +; 10 is a good parameter for n. + +(define (equality-benchmark1 n) + (let ((x (make-test-tree1 n)) + (y (make-test-tree1 n))) + +(write 1) (newline) +(write (make-test-tree1 1)) (newline) +(write 2) (newline) +(write (make-test-tree1 2)) (newline) +(write 3) (newline) +(write (make-test-tree1 3)) (newline) + (write x) + (newline) + (equal? x y))) + ;(iterate n (hide n (lambda () (equal? x y)))))) + + +(define (equality-benchmarks n0 n1 n2 n3 n4 n5) + (and + (equality-benchmark1 n1) + )) + +(define (main) + (let* ((input0 100) + (input1 1) ;100) + (input2 8) + (input3 1000) + (input4 2000) + (input5 5000) + (output #t) + (s5 (number->string input5)) + (s4 (number->string input4)) + (s3 (number->string input3)) + (s2 (number->string input2)) + (s1 (number->string input1)) + (s0 (number->string input0)) + (name "equal")) + (run-r7rs-benchmark + (string-append name ":" s0 ":" s1 ":" s2 ":" s3 ":" s4 ":" s5) + 1 + (lambda () + (equality-benchmarks (hide input0 input0) + (hide input0 input1) + (hide input0 input2) + (hide input0 input3) + (hide input0 input4) + (hide input0 input5))) + (lambda (result) (eq? result #t))))) + +;;; The following code is appended to all benchmarks. + +;;; Given an integer and an object, returns the object +;;; without making it too easy for compilers to tell +;;; the object will be returned. + +(define (hide r x) + (call-with-values + (lambda () + (values (vector values (lambda (x) x)) + (if (< r 100) 0 1))) + (lambda (v i) + ((vector-ref v i) x)))) + +;;; Given the name of a benchmark, +;;; the number of times it should be executed, +;;; a thunk that runs the benchmark once, +;;; and a unary predicate that is true of the +;;; correct results the thunk may return, +;;; runs the benchmark for the number of specified iterations. + +(define (run-r7rs-benchmark name count thunk ok?) + + ;; Rounds to thousandths. + (define (rounded x) + (/ (round (* 1000 x)) 1000)) + + (display "Running ") + (display name) + (newline) + (flush-output-port) + (let* ((j/s (jiffies-per-second)) + (t0 (current-second)) + (j0 (current-jiffy))) + (let loop ((i 0) + (result (if #f #f))) + (cond ((< i count) + (loop (+ i 1) (thunk))) + ((ok? result) + (let* ((j1 (current-jiffy)) + (t1 (current-second)) + (jifs (- j1 j0)) + (secs (inexact (/ jifs j/s))) + (secs2 (rounded (- t1 t0)))) + (display "Elapsed time: ") + (write secs) + (display " seconds (") + (write secs2) + (display ") for ") + (display name) + (newline)) + result) + (else + (display "ERROR: returned incorrect result: ") + (write result) + (newline) + result))))) + +(main)