163 lines
4.6 KiB
Scheme
163 lines
4.6 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; Copyright 2007 William D Clinger.
|
|
;
|
|
; Permission to copy this software, in whole or in part, to use this
|
|
; software for any lawful purpose, and to redistribute this software
|
|
; is granted subject to the restriction that all copies made of this
|
|
; software must include this copyright notice in full.
|
|
;
|
|
; I also request that you send me a copy of any improvements that you
|
|
; make to this software so that they may be incorporated within it to
|
|
; the benefit of the Scheme community.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; This benchmark tests the R6RS equal? predicate on some fairly
|
|
; large structures of various shapes.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(import (scheme base)
|
|
(scheme read)
|
|
(scheme write))
|
|
|
|
; 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)))))
|
|
|
|
; Returns a list of n elements, as returned by the thunk.
|
|
|
|
(define (make-test-list2 n thunk)
|
|
(if (zero? n)
|
|
'()
|
|
(cons (thunk) (make-test-list2 (- n 1) thunk))))
|
|
|
|
; Returns a balanced tree of height n, with the branching factor
|
|
; at each level equal to the height of the tree at that level.
|
|
; The subtrees do not share structure.
|
|
|
|
(define (make-test-tree2 n)
|
|
(if (zero? n)
|
|
'()
|
|
(make-test-list2 n (lambda () (make-test-tree2 (- n 1))))))
|
|
|
|
; Returns an extremely unbalanced tree of height n.
|
|
|
|
(define (make-test-tree5 n)
|
|
(if (zero? n)
|
|
'()
|
|
(cons (make-test-tree5 (- n 1))
|
|
'a)))
|
|
|
|
; Calls the thunk n times.
|
|
|
|
(define (iterate n thunk)
|
|
(cond ((= n 1)
|
|
(thunk))
|
|
((> n 1)
|
|
(thunk)
|
|
(iterate (- n 1) thunk))
|
|
(else #f)))
|
|
|
|
; A simple circular list is a worst case for R5RS equal?.
|
|
|
|
(define (equality-benchmark0 n)
|
|
(let ((x (vector->list (make-vector n 'a))))
|
|
(set-cdr! (list-tail x (- n 1)) x)
|
|
(iterate n (hide n (lambda () (equal? x (cdr x)))))))
|
|
|
|
; 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)))
|
|
(iterate n (hide n (lambda () (equal? x y))))))
|
|
|
|
; Tree with no sharing.
|
|
; 8 is a good parameter for n.
|
|
|
|
(define (equality-benchmark2 n)
|
|
(let ((x (make-test-tree2 n))
|
|
(y (make-test-tree2 n)))
|
|
(iterate n (hide n (lambda () (equal? x y))))))
|
|
|
|
; Flat vectors.
|
|
; 1000 might be a good parameter for n.
|
|
|
|
(define (equality-benchmark3 n)
|
|
(let* ((x (make-vector n 'a))
|
|
(y (make-vector n 'a)))
|
|
(iterate n (hide n (lambda () (equal? x y))))))
|
|
|
|
; Shallow lists.
|
|
; 300 might be a good parameter for n.
|
|
|
|
(define (equality-benchmark4 n)
|
|
(let* ((x (vector->list (make-vector n (make-test-tree2 3))))
|
|
(y (vector->list (make-vector n (make-test-tree2 3)))))
|
|
(iterate n (hide n (lambda () (equal? x y))))))
|
|
|
|
; No sharing, no proper lists,
|
|
; and deep following car chains instead of cdr.
|
|
|
|
(define (equality-benchmark5 n . rest)
|
|
(let* ((x (make-test-tree5 n))
|
|
(y (make-test-tree5 n))
|
|
(iterations (if (null? rest) n (car rest))))
|
|
(iterate iterations (hide n (lambda () (equal? x y))))))
|
|
|
|
; A shorter form of the benchmark above.
|
|
|
|
(define (equality-benchmark5short n)
|
|
(equality-benchmark5 n 100))
|
|
|
|
(define (equality-benchmarks n0 n1 n2 n3 n4 n5)
|
|
(and (equality-benchmark0 n0)
|
|
(equality-benchmark1 n1)
|
|
(equality-benchmark2 n2)
|
|
(equality-benchmark3 n3)
|
|
(equality-benchmark4 n4)
|
|
(equality-benchmark5 n5)))
|
|
|
|
(define (main)
|
|
(let* ((input0 (read))
|
|
(input1 (read))
|
|
(input2 (read))
|
|
(input3 (read))
|
|
(input4 (read))
|
|
(input5 (read))
|
|
(output (read))
|
|
(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)))))
|
|
|
|
(include "src/common.sch")
|