conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Added many benchmarks. 

added:
  benchmarks/new/r6rs-benchmarks/BUGS
  benchmarks/new/r6rs-benchmarks/array1.ss
  benchmarks/new/r6rs-benchmarks/bib
  benchmarks/new/r6rs-benchmarks/boyer.ss
  benchmarks/new/r6rs-benchmarks/browse.ss
  benchmarks/new/r6rs-benchmarks/cat.ss
  benchmarks/new/r6rs-benchmarks/conform.ss
  benchmarks/new/r6rs-benchmarks/cpstak.ss
  benchmarks/new/r6rs-benchmarks/ctak.ss
  benchmarks/new/r6rs-benchmarks/dderiv.ss
  benchmarks/new/r6rs-benchmarks/deriv.ss
  benchmarks/new/r6rs-benchmarks/destruc.ss
  benchmarks/new/r6rs-benchmarks/diviter.ss
  benchmarks/new/r6rs-benchmarks/divrec.ss
  benchmarks/new/r6rs-benchmarks/dynamic.src.ss
  benchmarks/new/r6rs-benchmarks/dynamic.ss
  benchmarks/new/r6rs-benchmarks/earley.ss
  benchmarks/new/r6rs-benchmarks/fibc.ss
  benchmarks/new/r6rs-benchmarks/fibfp.ss
  benchmarks/new/r6rs-benchmarks/gcbench.ss
  benchmarks/new/r6rs-benchmarks/gcold.ss
  benchmarks/new/r6rs-benchmarks/graphs.ss
  benchmarks/new/r6rs-benchmarks/lattice.ss
  benchmarks/new/r6rs-benchmarks/matrix.ss
  benchmarks/new/r6rs-benchmarks/maze.ss
  benchmarks/new/r6rs-benchmarks/mazefun.ss
  benchmarks/new/r6rs-benchmarks/mbrot.ss
  benchmarks/new/r6rs-benchmarks/nboyer.ss
  benchmarks/new/r6rs-benchmarks/nqueens.ss
  benchmarks/new/r6rs-benchmarks/ntakl.ss
  benchmarks/new/r6rs-benchmarks/paraffins.ss
  benchmarks/new/r6rs-benchmarks/parsing-test.sch
  benchmarks/new/r6rs-benchmarks/parsing.ss
  benchmarks/new/r6rs-benchmarks/perm9.ss
  benchmarks/new/r6rs-benchmarks/peval.ss
  benchmarks/new/r6rs-benchmarks/pi.ss
  benchmarks/new/r6rs-benchmarks/pnpoly.ss
  benchmarks/new/r6rs-benchmarks/ray.ss
  benchmarks/new/r6rs-benchmarks/todo-src/
  benchmarks/new/r6rs-benchmarks/todo-src/README.flonum-benchmarks
  benchmarks/new/r6rs-benchmarks/todo-src/compiler.scm
  benchmarks/new/r6rs-benchmarks/todo-src/fft.scm
  benchmarks/new/r6rs-benchmarks/todo-src/fpsum.scm
  benchmarks/new/r6rs-benchmarks/todo-src/nbody.scm
  benchmarks/new/r6rs-benchmarks/todo-src/nucleic.scm
  benchmarks/new/r6rs-benchmarks/todo-src/primes.scm
  benchmarks/new/r6rs-benchmarks/todo-src/puzzle.scm
  benchmarks/new/r6rs-benchmarks/todo-src/quicksort.scm
  benchmarks/new/r6rs-benchmarks/todo-src/rn100
  benchmarks/new/r6rs-benchmarks/todo-src/sboyer.scm
  benchmarks/new/r6rs-benchmarks/todo-src/scheme.scm
  benchmarks/new/r6rs-benchmarks/todo-src/simplex.scm
  benchmarks/new/r6rs-benchmarks/todo-src/slatex.scm
  benchmarks/new/r6rs-benchmarks/todo-src/slatex.sty
  benchmarks/new/r6rs-benchmarks/todo-src/smlboyer.scm
  benchmarks/new/r6rs-benchmarks/todo-src/string.scm
  benchmarks/new/r6rs-benchmarks/todo-src/succeed.scm
  benchmarks/new/r6rs-benchmarks/todo-src/sum.scm
  benchmarks/new/r6rs-benchmarks/todo-src/sum1.scm
  benchmarks/new/r6rs-benchmarks/todo-src/sumfp.scm
  benchmarks/new/r6rs-benchmarks/todo-src/sumloop.scm
  benchmarks/new/r6rs-benchmarks/todo-src/tail.scm
  benchmarks/new/r6rs-benchmarks/todo-src/tak.scm
  benchmarks/new/r6rs-benchmarks/todo-src/takl.scm
  benchmarks/new/r6rs-benchmarks/todo-src/temp.scm
  benchmarks/new/r6rs-benchmarks/todo-src/temp2.scm
  benchmarks/new/r6rs-benchmarks/todo-src/test.scm
  benchmarks/new/r6rs-benchmarks/todo-src/test.tex
  benchmarks/new/r6rs-benchmarks/todo-src/tfib.scm
  benchmarks/new/r6rs-benchmarks/todo-src/trav1.scm
  benchmarks/new/r6rs-benchmarks/todo-src/trav2.scm
  benchmarks/new/r6rs-benchmarks/todo-src/triangl.scm
  benchmarks/new/r6rs-benchmarks/todo-src/wc.scm
modified:
  benchmarks/new/r6rs-benchmarks.ss
  benchmarks/results.Larceny-r6rs
  benchmarks/src/ntakl.scm
This commit is contained in:
Abdulaziz Ghuloum 2007-06-13 14:17:57 +03:00
parent 48c80cbd9c
commit b00de8325b
75 changed files with 175333 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
benchmarks/new/r6rs-benchmarks.ss
View File

@ -1,9 +1,60 @@
(library (r6rs-benchmarks)
(export run-benchmark
(export run-benchmark fatal-error include-source
ack-iters
fib-iters)
array1-iters
boyer-iters
browse-iters
cat-iters
conform-iters
cpstak-iters
ctak-iters
dderiv-iters
deriv-iters
destruc-iters
diviter-iters
divrec-iters
dynamic-iters
earley-iters
fib-iters
fibc-iters
fibfp-iters
gcbench-iters
gcold-iters
graphs-iters
lattice-iters
matrix-iters
mazefun-iters
mbrot-iters
nboyer-iters
nqueens-iters
takl-iters
paraffins-iters
parsing-iters
perm9-iters
pnpoly-iters
peval-iters
pi-iters)
(import (ikarus))
(define-syntax include-source
(lambda (x)
(syntax-case x ()
[(ctxt name)
(cons #'begin
(with-input-from-file
(format "r6rs-benchmarks/~a" (syntax->datum #'name))
(lambda ()
(let f ()
(let ([x (read)])
(cond
[(eof-object? x) '()]
[else
(cons (datum->syntax #'ctxt x) (f))]))))))])))
(define (fatal-error . args)
(error 'fatal-error "~a"
(apply (lambda (x) (format "~a" x)) args)))
(define (run-bench count run)
(unless (= count 0)

11
benchmarks/new/r6rs-benchmarks/BUGS Normal file
View File

@ -0,0 +1,11 @@
* conform needs char-downcase.
* maze needs bitwise-and
* ray needs call-with-output-file/truncate.
* ctak crashes with a bus error.
* fibc crashes with a segfault.
* fibfp does not terminate
* mbrot too slow
* ntakl kinda slow
* pnpoly kinda slow

36
benchmarks/new/r6rs-benchmarks/array1.ss Normal file
View File

@ -0,0 +1,36 @@
;;; ARRAY1 -- One of the Kernighan and Van Wyk benchmarks.
(library (r6rs-benchmarks array1)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (create-x n)
(define result (make-vector n))
(do ((i 0 (+ i 1)))
((>= i n) result)
(vector-set! result i i)))
(define (create-y x)
(let* ((n (vector-length x))
(result (make-vector n)))
(do ((i (- n 1) (- i 1)))
((< i 0) result)
(vector-set! result i (vector-ref x i)))))
(define (my-try n)
(vector-length (create-y (create-x n))))
(define (go n)
(let loop ((repeat 100)
(result '()))
(if (> repeat 0)
(loop (- repeat 1) (my-try n))
result)))
(define (main . args)
(run-benchmark
"array1"
array1-iters
(lambda (result) (equal? result 200000))
(lambda (n) (lambda () (go n)))
200000)))

31102
benchmarks/new/r6rs-benchmarks/bib Normal file
View File

File diff suppressed because it is too large Load Diff

575
benchmarks/new/r6rs-benchmarks/boyer.ss Normal file
View File

@ -0,0 +1,575 @@
;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Fairly CONS intensive.
(library (r6rs-benchmarks boyer)
(export main)
(import (r6rs)
(r6rs mutable-pairs)
(r6rs-benchmarks))
(define (lookup key table)
(let loop ((x table))
(if (null? x)
#f
(let ((pair (car x)))
(if (eq? (car pair) key)
pair
(loop (cdr x)))))))
(define properties '())
(define (get key1 key2)
(let ((x (lookup key1 properties)))
(if x
(let ((y (lookup key2 (cdr x))))
(if y
(cdr y)
#f))
#f)))
(define (put key1 key2 val)
(let ((x (lookup key1 properties)))
(if x
(let ((y (lookup key2 (cdr x))))
(if y
(set-cdr! y val)
(set-cdr! x (cons (cons key2 val) (cdr x)))))
(set! properties
(cons (list key1 (cons key2 val)) properties)))))
(define unify-subst '())
(define (add-lemma term)
(cond ((and (pair? term)
(eq? (car term)
(quote equal))
(pair? (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons term (get (car (cadr term)) (quote lemmas)))))
(else (fatal-error "ADD-LEMMA did not like term: " term))))
(define (add-lemma-lst lst)
(cond ((null? lst)
#t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(cond ((assq term alist) => cdr)
(else term)))
(else (cons (car term)
(apply-subst-lst alist (cdr term))))))
(define (apply-subst-lst alist lst)
(cond ((null? lst)
'())
(else (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(define (falsep x lst)
(or (equal? x (quote (f)))
(member x lst)))
(define (one-way-unify term1 term2)
(begin (set! unify-subst '())
(one-way-unify1 term1 term2)))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(cond ((assq term2 unify-subst) =>
(lambda (x) (equal? term1 (cdr x))))
(else (set! unify-subst (cons (cons term2 term1)
unify-subst))
#t)))
((not (pair? term1))
#f)
((eq? (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(else #f)))
(define (one-way-unify1-lst lst1 lst2)
(cond ((null? lst1)
#t)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else #f)))
(define (rewrite term)
(cond ((not (pair? term))
term)
(else (rewrite-with-lemmas (cons (car term)
(rewrite-args (cdr term)))
(get (car term)
(quote lemmas))))))
(define (rewrite-args lst)
(cond ((null? lst)
'())
(else (cons (rewrite (car lst))
(rewrite-args (cdr lst))))))
(define (rewrite-with-lemmas term lst)
(cond ((or (not lst) (null? lst))
term)
((one-way-unify term (cadr (car lst)))
(rewrite (apply-subst unify-subst (caddr (car lst)))))
(else (rewrite-with-lemmas term (cdr lst)))))
(define (setup)
(add-lemma-lst
(quote ((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(equal (fix x)
(fix y)))
(equal (greaterp x y)
(lessp y x))
(equal (lesseqp x y)
(not (lessp y x)))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (_1- x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x)))
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (_1- x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))
(f)))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (fix x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (plus (plus x y)
z)
(plus x (plus y z)))
(equal (equal (plus a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (difference x x)
(zero))
(equal (equal (plus a b)
(plus a c))
(equal (fix b)
(fix c)))
(equal (equal (zero)
(difference x y))
(not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (append x y))
a)
(plus (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(fix (meaning x a)))
(equal (append (append x y)
z)
(append x (append y z)))
(equal (reverse (append a b))
(append (reverse b)
(reverse a)))
(equal (times x (plus y z))
(plus (times x y)
(times x z)))
(equal (times (times x y)
z)
(times x (times y z)))
(equal (equal (times x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (append x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(append (flatten x)
y))
(equal (member x (append a b))
(or (member x a)
(member x b)))
(equal (member x (reverse y))
(member x y))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c))
(and (member a b)
(member a c)))
(equal (nth (zero)
i)
(zero))
(equal (exp i (plus j k))
(times (exp i j)
(exp i k)))
(equal (exp i (times j k))
(exp (exp i j)
k))
(equal (reverse-loop x y)
(append (reverse x)
y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x)
(count-list z y)))
(equal (equal (append a b)
(append a c))
(equal b c))
(equal (plus (remainder x y)
(times y (quotient x y)))
(fix x))
(equal (power-eval (big-plus1 l i base)
base)
(plus (power-eval l base)
i))
(equal (power-eval (big-plus x y i base)
base)
(plus i (plus (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (lessp (remainder x y)
y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (lessp (quotient i j)
i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (lessp (remainder x y)
x)
(and (not (zerop y))
(not (zerop x))
(not (lessp x y))))
(equal (power-eval (power-rep i base)
base)
(fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (append a b)
i)
(append (nth a i)
(nth b (difference i (length a)))))
(equal (difference (plus x y)
x)
(fix y))
(equal (difference (plus y x)
x)
(fix y))
(equal (difference (plus x y)
(plus x z))
(difference y z))
(equal (times x (difference c w))
(difference (times c x)
(times w x)))
(equal (remainder (times x z)
z)
(zero))
(equal (difference (plus b (plus a c))
a)
(plus b c))
(equal (difference (add1 (plus y z))
z)
(add1 y))
(equal (lessp (plus x y)
(plus x z))
(lessp y z))
(equal (lessp (times x z)
(times y z))
(and (not (zerop z))
(lessp x y)))
(equal (lessp y (plus x y))
(not (zerop x)))
(equal (gcd (times x z)
(times y z))
(times z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y)
1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (append x y))
(times (times-list x)
(times-list y)))
(equal (prime-list (append x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (times w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqpr x y)
(not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (times y x)
y)
(zero))
(equal (equal (times a b)
1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (_1- a)
(zero))
(equal (_1- b)
(zero))))
(equal (lessp (length (delete x l))
(length l))
(member x l))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length (cons x1
(cons x2
(cons x3 (cons x4
(cons x5
(cons x6 x7)))))))
(plus 6 (length x7)))
(equal (difference (add1 (add1 x))
2)
(fix x))
(equal (quotient (plus x (plus x y))
2)
(plus x (quotient y 2)))
(equal (sigma (zero)
i)
(quotient (times i (add1 i))
2))
(equal (plus x (add1 y))
(if (numberp y)
(add1 (plus x y))
(add1 x)))
(equal (equal (difference x y)
(difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y)
(not (lessp y x))
(equal (fix x)
(fix z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y)
(difference (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (times x (add1 y))
(if (numberp y)
(plus x (times x y))
(fix x)))
(equal (nth (nil)
i)
(if (zerop i)
(nil)
(zero)))
(equal (last (append a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a))
b)
b)))
(equal (equal (lessp x y)
z)
(if (lessp x y)
(equal t z)
(equal f z)))
(equal (assignment x (append a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (quotient (times y x)
y)
(if (zerop y)
(zero)
(fix x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem)))))))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
#t)
((falsep x false-lst)
#f)
((not (pair? x))
#f)
((eq? (car x)
(quote if))
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(else (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(else #f)))
(define (tautp x)
(tautologyp (rewrite x)
'() '()))
(define (test alist term)
(tautp
(apply-subst alist term)))
(define (trans-of-implies n)
(list (quote implies)
(trans-of-implies1 n)
(list (quote implies)
0 n)))
(define (trans-of-implies1 n)
(cond ((equal? n 1)
(list (quote implies)
0 1))
(else (list (quote and)
(list (quote implies)
(- n 1)
n)
(trans-of-implies1 (- n 1))))))
(define (truep x lst)
(or (equal? x (quote (t)))
(member x lst)))
(define (main . args)
(run-benchmark
"boyer"
boyer-iters
(lambda (result) (equal? result #t))
(lambda (alist term) (lambda () (test alist term)))
(quote ((x f (plus (plus a b)
(plus c (zero))))
(y f (times (times a b)
(plus c d)))
(z f (reverse (append (append a b)
(nil))))
(u equal (plus a b)
(difference x y))
(w lessp (remainder a b)
(member a (length b)))))
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))))
(setup))

198
benchmarks/new/r6rs-benchmarks/browse.ss Normal file
View File

@ -0,0 +1,198 @@
;;; BROWSE -- Benchmark to create and browse through
;;; an AI-like data base of units.
(library (r6rs-benchmarks browse)
(export main)
(import (r6rs)
(r6rs mutable-pairs)
(r6rs-benchmarks))
(define (lookup key table)
(let loop ((x table))
(if (null? x)
#f
(let ((pair (car x)))
(if (eq? (car pair) key)
pair
(loop (cdr x)))))))
(define properties '())
(define (get key1 key2)
(let ((x (lookup key1 properties)))
(if x
(let ((y (lookup key2 (cdr x))))
(if y
(cdr y)
#f))
#f)))
(define (put key1 key2 val)
(let ((x (lookup key1 properties)))
(if x
(let ((y (lookup key2 (cdr x))))
(if y
(set-cdr! y val)
(set-cdr! x (cons (cons key2 val) (cdr x)))))
(set! properties
(cons (list key1 (cons key2 val)) properties)))))
(define *current-gensym* 0)
(define (generate-symbol)
(set! *current-gensym* (+ *current-gensym* 1))
(string->symbol (number->string *current-gensym*)))
(define (append-to-tail! x y)
(if (null? x)
y
(do ((a x b)
(b (cdr x) (cdr b)))
((null? b)
(set-cdr! a y)
x))))
(define (tree-copy x)
(if (not (pair? x))
x
(cons (tree-copy (car x))
(tree-copy (cdr x)))))
;;; n is # of symbols
;;; m is maximum amount of stuff on the plist
;;; npats is the number of basic patterns on the unit
;;; ipats is the instantiated copies of the patterns
(define *rand* 21)
(define (init n m npats ipats)
(let ((ipats (tree-copy ipats)))
(do ((p ipats (cdr p)))
((null? (cdr p)) (set-cdr! p ipats)))
(do ((n n (- n 1))
(i m (cond ((zero? i) m)
(else (- i 1))))
(name (generate-symbol) (generate-symbol))
(a '()))
((= n 0) a)
(set! a (cons name a))
(do ((i i (- i 1)))
((zero? i))
(put name (generate-symbol) #f))
(put name
'pattern
(do ((i npats (- i 1))
(ipats ipats (cdr ipats))
(a '()))
((zero? i) a)
(set! a (cons (car ipats) a))))
(do ((j (- m i) (- j 1)))
((zero? j))
(put name (generate-symbol) #f)))))
(define (browse-random)
(set! *rand* (remainder (* *rand* 17) 251))
*rand*)
(define (randomize l)
(do ((a '()))
((null? l) a)
(let ((n (remainder (browse-random) (length l))))
(cond ((zero? n)
(set! a (cons (car l) a))
(set! l (cdr l))
l)
(else
(do ((n n (- n 1))
(x l (cdr x)))
((= n 1)
(set! a (cons (cadr x) a))
(set-cdr! x (cddr x))
x)))))))
(define (my-match pat dat alist)
(cond ((null? pat)
(null? dat))
((null? dat) '())
((or (eq? (car pat) '?)
(eq? (car pat)
(car dat)))
(my-match (cdr pat) (cdr dat) alist))
((eq? (car pat) '*)
(or (my-match (cdr pat) dat alist)
(my-match (cdr pat) (cdr dat) alist)
(my-match pat (cdr dat) alist)))
(else (cond ((not (pair? (car pat)))
(cond ((eq? (string-ref (symbol->string (car pat)) 0)
#\?)
(let ((val (assq (car pat) alist)))
(cond (val (my-match (cons (cdr val)
(cdr pat))
dat alist))
(else (my-match (cdr pat)
(cdr dat)
(cons (cons (car pat)
(car dat))
alist))))))
((eq? (string-ref (symbol->string (car pat)) 0)
#\*)
(let ((val (assq (car pat) alist)))
(cond (val (my-match (append (cdr val)
(cdr pat))
dat alist))
(else
(do ((l '()
(append-to-tail!
l
(cons (if (null? d)
'()
(car d))
'())))
(e (cons '() dat) (cdr e))
(d dat (if (null? d) '() (cdr d))))
((or (null? e)
(my-match (cdr pat)
d
(cons
(cons (car pat) l)
alist)))
(if (null? e) #f #t)))))))
(else #f))) ;;;; fix suggested by Manuel Serrano (cond did not have an else clause); this changes the run time quite a bit
(else (and
(pair? (car dat))
(my-match (car pat)
(car dat) alist)
(my-match (cdr pat)
(cdr dat) alist)))))))
(define database
(randomize
(init 100 10 4 '((a a a b b b b a a a a a b b a a a)
(a a b b b b a a
(a a)(b b))
(a a a b (b a) b a b a)))))
(define (browse pats)
(investigate
database
pats))
(define (investigate units pats)
(do ((units units (cdr units)))
((null? units))
(do ((pats pats (cdr pats)))
((null? pats))
(do ((p (get (car units) 'pattern)
(cdr p)))
((null? p))
(my-match (car pats) (car p) '())))))
(define (main . args)
(run-benchmark
"browse"
browse-iters
(lambda (result) #t)
(lambda (pats) (lambda () (browse pats)))
'((*a ?b *b ?b a *a a *b *a)
(*a *b *b *a (*a) (*b))
(? ? * (b a) * ? ?)))))

29
benchmarks/new/r6rs-benchmarks/cat.ss Normal file
View File

@ -0,0 +1,29 @@
;;; CAT -- One of the Kernighan and Van Wyk benchmarks.
(library (r6rs-benchmarks cat)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define inport #f)
(define outport #f)
(define (catport port)
(let ((x (read-char port)))
(if (eof-object? x)
(close-output-port outport)
(begin
(write-char x outport)
(catport port)))))
(define (go)
(set! inport (open-input-file "r6rs-benchmarks/bib"))
(set! outport (open-output-file "foo"))
(catport inport)
(close-input-port inport))
(define (main . args)
(run-benchmark
"cat"
cat-iters
(lambda (result) #t)
(lambda () (lambda () (go))))))

498
benchmarks/new/r6rs-benchmarks/conform.ss Normal file
View File

@ -0,0 +1,498 @@
;;; CONFORM -- Type checker, written by Jim Miller.
(library (r6rs-benchmarks conform)
(export main)
(import (r6rs)
(r6rs mutable-pairs)
(r6rs-benchmarks))
;;; Functional and unstable
(define (sort-list obj pred)
(define (loop l)
(if (and (pair? l) (pair? (cdr l)))
(split-list l '() '())
l))
(define (split-list l one two)
(if (pair? l)
(split-list (cdr l) two (cons (car l) one))
(merge (loop one) (loop two))))
(define (merge one two)
(cond ((null? one) two)
((pred (car two) (car one))
(cons (car two)
(merge (cdr two) one)))
(else
(cons (car one)
(merge (cdr one) two)))))
(loop obj))
;; SET OPERATIONS
; (representation as lists with distinct elements)
(define (adjoin element set)
(if (memq element set) set (cons element set)))
(define (eliminate element set)
(cond ((null? set) set)
((eq? element (car set)) (cdr set))
(else (cons (car set) (eliminate element (cdr set))))))
(define (intersect list1 list2)
(let loop ((l list1))
(cond ((null? l) '())
((memq (car l) list2) (cons (car l) (loop (cdr l))))
(else (loop (cdr l))))))
(define (union list1 list2)
(if (null? list1)
list2
(union (cdr list1)
(adjoin (car list1) list2))))
;; GRAPH NODES
(define make-internal-node vector)
(define (internal-node-name node) (vector-ref node 0))
(define (internal-node-green-edges node) (vector-ref node 1))
(define (internal-node-red-edges node) (vector-ref node 2))
(define (internal-node-blue-edges node) (vector-ref node 3))
(define (set-internal-node-name! node name) (vector-set! node 0 name))
(define (set-internal-node-green-edges! node edges) (vector-set! node 1 edges))
(define (set-internal-node-red-edges! node edges) (vector-set! node 2 edges))
(define (set-internal-node-blue-edges! node edges) (vector-set! node 3 edges))
(define (make-node name . blue-edges) ; User's constructor
(let ((name (if (symbol? name) (symbol->string name) name))
(blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges))))
(make-internal-node name '() '() blue-edges)))
(define (copy-node node)
(make-internal-node (name node) '() '() (blue-edges node)))
; Selectors
(define name internal-node-name)
(define (make-edge-getter selector)
(lambda (node)
(if (or (none-node? node) (any-node? node))
(fatal-error "Can't get edges from the ANY or NONE nodes")
(selector node))))
(define red-edges (make-edge-getter internal-node-red-edges))
(define green-edges (make-edge-getter internal-node-green-edges))
(define blue-edges (make-edge-getter internal-node-blue-edges))
; Mutators
(define (make-edge-setter mutator!)
(lambda (node value)
(cond ((any-node? node) (fatal-error "Can't set edges from the ANY node"))
((none-node? node) 'OK)
(else (mutator! node value)))))
(define set-red-edges! (make-edge-setter set-internal-node-red-edges!))
(define set-green-edges! (make-edge-setter set-internal-node-green-edges!))
(define set-blue-edges! (make-edge-setter set-internal-node-blue-edges!))
;; BLUE EDGES
(define make-blue-edge vector)
(define (blue-edge-operation edge) (vector-ref edge 0))
(define (blue-edge-arg-node edge) (vector-ref edge 1))
(define (blue-edge-res-node edge) (vector-ref edge 2))
(define (set-blue-edge-operation! edge value) (vector-set! edge 0 value))
(define (set-blue-edge-arg-node! edge value) (vector-set! edge 1 value))
(define (set-blue-edge-res-node! edge value) (vector-set! edge 2 value))
; Selectors
(define operation blue-edge-operation)
(define arg-node blue-edge-arg-node)
(define res-node blue-edge-res-node)
; Mutators
(define set-arg-node! set-blue-edge-arg-node!)
(define set-res-node! set-blue-edge-res-node!)
; Higher level operations on blue edges
(define (lookup-op op node)
(let loop ((edges (blue-edges node)))
(cond ((null? edges) '())
((eq? op (operation (car edges))) (car edges))
(else (loop (cdr edges))))))
(define (has-op? op node)
(not (null? (lookup-op op node))))
;; GRAPHS
(define make-internal-graph vector)
(define (internal-graph-nodes graph) (vector-ref graph 0))
(define (internal-graph-already-met graph) (vector-ref graph 1))
(define (internal-graph-already-joined graph) (vector-ref graph 2))
(define (set-internal-graph-nodes! graph nodes) (vector-set! graph 0 nodes))
; Constructor
(define (make-graph . nodes)
(make-internal-graph nodes (make-empty-table) (make-empty-table)))
; Selectors
(define graph-nodes internal-graph-nodes)
(define already-met internal-graph-already-met)
(define already-joined internal-graph-already-joined)
; Higher level functions on graphs
(define (add-graph-nodes! graph nodes)
(set-internal-graph-nodes! graph (cons nodes (graph-nodes graph))))
(define (copy-graph g)
(define (copy-list l) (vector->list (list->vector l)))
(make-internal-graph
(copy-list (graph-nodes g))
(already-met g)
(already-joined g)))
(define (clean-graph g)
(define (clean-node node)
(if (not (or (any-node? node) (none-node? node)))
(begin
(set-green-edges! node '())
(set-red-edges! node '()))))
(for-each clean-node (graph-nodes g))
g)
(define (canonicalize-graph graph classes)
(define (fix node)
(define (fix-set object selector mutator)
(mutator object
(map (lambda (node)
(find-canonical-representative node classes))
(selector object))))
(if (not (or (none-node? node) (any-node? node)))
(begin
(fix-set node green-edges set-green-edges!)
(fix-set node red-edges set-red-edges!)
(for-each
(lambda (blue-edge)
(set-arg-node! blue-edge
(find-canonical-representative (arg-node blue-edge) classes))
(set-res-node! blue-edge
(find-canonical-representative (res-node blue-edge) classes)))
(blue-edges node))))
node)
(define (fix-table table)
(define (canonical? node) (eq? node (find-canonical-representative node classes)))
(define (filter-and-fix predicate-fn update-fn list)
(let loop ((list list))
(cond ((null? list) '())
((predicate-fn (car list))
(cons (update-fn (car list)) (loop (cdr list))))
(else (loop (cdr list))))))
(define (fix-line line)
(filter-and-fix
(lambda (entry) (canonical? (car entry)))
(lambda (entry) (cons (car entry)
(find-canonical-representative (cdr entry) classes)))
line))
(if (null? table)
'()
(cons (car table)
(filter-and-fix
(lambda (entry) (canonical? (car entry)))
(lambda (entry) (cons (car entry) (fix-line (cdr entry))))
(cdr table)))))
(make-internal-graph
(map (lambda (class) (fix (car class))) classes)
(fix-table (already-met graph))
(fix-table (already-joined graph))))
;; USEFUL NODES
(define none-node (make-node 'none #t))
(define (none-node? node) (eq? node none-node))
(define any-node (make-node 'any '()))
(define (any-node? node) (eq? node any-node))
;; COLORED EDGE TESTS
(define (green-edge? from-node to-node)
(cond ((any-node? from-node) #f)
((none-node? from-node) #t)
((memq to-node (green-edges from-node)) #t)
(else #f)))
(define (red-edge? from-node to-node)
(cond ((any-node? from-node) #f)
((none-node? from-node) #t)
((memq to-node (red-edges from-node)) #t)
(else #f)))
;; SIGNATURE
; Return signature (i.e. <arg, res>) given an operation and a node
(define sig
(let ((none-comma-any (cons none-node any-node)))
(lambda (op node) ; Returns (arg, res)
(let ((the-edge (lookup-op op node)))
(if (not (null? the-edge))
(cons (arg-node the-edge) (res-node the-edge))
none-comma-any)))))
; Selectors from signature
(define (arg pair) (car pair))
(define (res pair) (cdr pair))
;; CONFORMITY
(define (conforms? t1 t2)
(define nodes-with-red-edges-out '())
(define (add-red-edge! from-node to-node)
(set-red-edges! from-node (adjoin to-node (red-edges from-node)))
(set! nodes-with-red-edges-out
(adjoin from-node nodes-with-red-edges-out)))
(define (greenify-red-edges! from-node)
(set-green-edges! from-node
(append (red-edges from-node) (green-edges from-node)))
(set-red-edges! from-node '()))
(define (delete-red-edges! from-node)
(set-red-edges! from-node '()))
(define (does-conform t1 t2)
(cond ((or (none-node? t1) (any-node? t2)) #t)
((or (any-node? t1) (none-node? t2)) #f)
((green-edge? t1 t2) #t)
((red-edge? t1 t2) #t)
(else
(add-red-edge! t1 t2)
(let loop ((blues (blue-edges t2)))
(if (null? blues)
#t
(let* ((current-edge (car blues))
(phi (operation current-edge)))
(and (has-op? phi t1)
(does-conform
(res (sig phi t1))
(res (sig phi t2)))
(does-conform
(arg (sig phi t2))
(arg (sig phi t1)))
(loop (cdr blues)))))))))
(let ((result (does-conform t1 t2)))
(for-each (if result greenify-red-edges! delete-red-edges!)
nodes-with-red-edges-out)
result))
(define (equivalent? a b)
(and (conforms? a b) (conforms? b a)))
;; EQUIVALENCE CLASSIFICATION
; Given a list of nodes, return a list of equivalence classes
(define (classify nodes)
(let node-loop ((classes '())
(nodes nodes))
(if (null? nodes)
(map (lambda (class)
(sort-list class
(lambda (node1 node2)
(< (string-length (name node1))
(string-length (name node2))))))
classes)
(let ((this-node (car nodes)))
(define (add-node classes)
(cond ((null? classes) (list (list this-node)))
((equivalent? this-node (caar classes))
(cons (cons this-node (car classes))
(cdr classes)))
(else (cons (car classes)
(add-node (cdr classes))))))
(node-loop (add-node classes)
(cdr nodes))))))
; Given a node N and a classified set of nodes,
; find the canonical member corresponding to N
(define (find-canonical-representative element classification)
(let loop ((classes classification))
(cond ((null? classes) (fatal-error "Can't classify" element))
((memq element (car classes)) (car (car classes)))
(else (loop (cdr classes))))))
; Reduce a graph by taking only one member of each equivalence
; class and canonicalizing all outbound pointers
(define (reduce graph)
(let ((classes (classify (graph-nodes graph))))
(canonicalize-graph graph classes)))
;; TWO DIMENSIONAL TABLES
(define (make-empty-table) (list 'TABLE))
(define (lookup table x y)
(let ((one (assq x (cdr table))))
(if one
(let ((two (assq y (cdr one))))
(if two (cdr two) #f))
#f)))
(define (insert! table x y value)
(define (make-singleton-table x y)
(list (cons x y)))
(let ((one (assq x (cdr table))))
(if one
(set-cdr! one (cons (cons y value) (cdr one)))
(set-cdr! table (cons (cons x (make-singleton-table y value))
(cdr table))))))
;; MEET/JOIN
; These update the graph when computing the node for node1*node2
(define (blue-edge-operate arg-fn res-fn graph op sig1 sig2)
(make-blue-edge op
(arg-fn graph (arg sig1) (arg sig2))
(res-fn graph (res sig1) (res sig2))))
(define (meet graph node1 node2)
(cond ((eq? node1 node2) node1)
((or (any-node? node1) (any-node? node2)) any-node) ; canonicalize
((none-node? node1) node2)
((none-node? node2) node1)
((lookup (already-met graph) node1 node2)) ; return it if found
((conforms? node1 node2) node2)
((conforms? node2 node1) node1)
(else
(let ((result
(make-node (string-append "(" (name node1) " ^ " (name node2) ")"))))
(add-graph-nodes! graph result)
(insert! (already-met graph) node1 node2 result)
(set-blue-edges! result
(map
(lambda (op)
(blue-edge-operate join meet graph op (sig op node1) (sig op node2)))
(intersect (map operation (blue-edges node1))
(map operation (blue-edges node2)))))
result))))
(define (join graph node1 node2)
(cond ((eq? node1 node2) node1)
((any-node? node1) node2)
((any-node? node2) node1)
((or (none-node? node1) (none-node? node2)) none-node) ; canonicalize
((lookup (already-joined graph) node1 node2)) ; return it if found
((conforms? node1 node2) node1)
((conforms? node2 node1) node2)
(else
(let ((result
(make-node (string-append "(" (name node1) " v " (name node2) ")"))))
(add-graph-nodes! graph result)
(insert! (already-joined graph) node1 node2 result)
(set-blue-edges! result
(map
(lambda (op)
(blue-edge-operate meet join graph op (sig op node1) (sig op node2)))
(union (map operation (blue-edges node1))
(map operation (blue-edges node2)))))
result))))
;; MAKE A LATTICE FROM A GRAPH
(define (make-lattice g print?)
(define (step g)
(let* ((copy (copy-graph g))
(nodes (graph-nodes copy)))
(for-each (lambda (first)
(for-each (lambda (second)
(meet copy first second) (join copy first second))
nodes))
nodes)
copy))
(define (loop g count)
(if print? (display count))
(let ((lattice (step g)))
(if print? (begin (display " -> ") (display (length (graph-nodes lattice)))))
(let* ((new-g (reduce lattice))
(new-count (length (graph-nodes new-g))))
(if (= new-count count)
(begin
(if print? (newline))
new-g)
(begin
(if print? (begin (display " -> ") (display new-count) (newline)))
(loop new-g new-count))))))
(let ((graph
(apply make-graph
(adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))
(loop graph (length (graph-nodes graph)))))
;; DEBUG and TEST
(define a '())
(define b '())
(define c '())
(define d '())
(define (setup)
(set! a (make-node 'a))
(set! b (make-node 'b))
(set-blue-edges! a (list (make-blue-edge 'phi any-node b)))
(set-blue-edges! b (list (make-blue-edge 'phi any-node a)
(make-blue-edge 'theta any-node b)))
(set! c (make-node "c"))
(set! d (make-node "d"))
(set-blue-edges! c (list (make-blue-edge 'theta any-node b)))
(set-blue-edges! d (list (make-blue-edge 'phi any-node c)
(make-blue-edge 'theta any-node d)))
'(made a b c d))
(define (test)
(setup)
(map name
(graph-nodes (make-lattice (make-graph a b c d any-node none-node) #f))))
(define (main . args)
(run-benchmark
"conform"
conform-iters
(lambda (result)
(equal? (map (lambda (s)
(list->string (map char-downcase (string->list s))))
result)
'("(((b v d) ^ a) v c)"
"(c ^ d)"
"(b v (a ^ d))"
"((a v d) ^ b)"
"(b v d)"
"(b ^ (a v c))"
"(a v (c ^ d))"
"((b v d) ^ a)"
"(c v (a v d))"
"(a v c)"
"(d v (b ^ (a v c)))"
"(d ^ (a v c))"
"((a ^ d) v c)"
"((a ^ b) v d)"
"(((a v d) ^ b) v (a ^ d))"
"(b ^ d)"
"(b v (a v d))"
"(a ^ c)"
"(b ^ (c v d))"
"(a ^ b)"
"(a v b)"
"((a ^ d) ^ b)"
"(a ^ d)"
"(a v d)"
"d"
"(c v d)"
"a"
"b"
"c"
"any"
"none")))
(lambda () (lambda () (test))))))

37
benchmarks/new/r6rs-benchmarks/cpstak.ss Normal file
View File

@ -0,0 +1,37 @@
;;; CPSTAK -- A continuation-passing version of the TAK benchmark.
;;; A good test of first class procedures and tail recursion.
(library (r6rs-benchmarks cpstak)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (cpstak x y z)
(define (tak x y z k)
(if (not (< y x))
(k z)
(tak (- x 1)
y
z
(lambda (v1)
(tak (- y 1)
z
x
(lambda (v2)
(tak (- z 1)
x
y
(lambda (v3)
(tak v1 v2 v3 k)))))))))
(tak x y z (lambda (a) a)))
(define (main . args)
(run-benchmark
"cpstak"
cpstak-iters
(lambda (result) (equal? result 7))
(lambda (x y z) (lambda () (cpstak x y z)))
18
12
6)))

33
benchmarks/new/r6rs-benchmarks/ctak.ss Normal file
View File

@ -0,0 +1,33 @@
;;; CTAK -- A version of the TAK procedure that uses continuations.
(library (r6rs-benchmarks ctak)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (ctak x y z)
(call-with-current-continuation
(lambda (k) (ctak-aux k x y z))))
(define (ctak-aux k x y z)
(if (not (< y x))
(k z)
(call-with-current-continuation
(lambda (k)
(ctak-aux
k
(call-with-current-continuation
(lambda (k) (ctak-aux k (- x 1) y z)))
(call-with-current-continuation
(lambda (k) (ctak-aux k (- y 1) z x)))
(call-with-current-continuation
(lambda (k) (ctak-aux k (- z 1) x y))))))))
(define (main . args)
(run-benchmark
"ctak"
ctak-iters
(lambda (result) (equal? result 7))
(lambda (x y z) (lambda () (ctak x y z)))
18
12
6)))

92
benchmarks/new/r6rs-benchmarks/dderiv.ss Normal file
View File

@ -0,0 +1,92 @@
;;; DDERIV -- Table-driven symbolic derivation.
;;; Returns the wrong answer for quotients.
;;; Fortunately these aren't used in the benchmark.
(library (r6rs-benchmarks dderiv)
(export main)
(import (r6rs) (r6rs mutable-pairs) (r6rs-benchmarks))
(define (lookup key table)
(let loop ((x table))
(if (null? x)
#f
(let ((pair (car x)))
(if (eq? (car pair) key)
pair
(loop (cdr x)))))))
(define properties '())
(define (get key1 key2)
(let ((x (lookup key1 properties)))
(if x
(let ((y (lookup key2 (cdr x))))
(if y
(cdr y)
#f))
#f)))
(define (put key1 key2 val)
(let ((x (lookup key1 properties)))
(if x
(let ((y (lookup key2 (cdr x))))
(if y
(set-cdr! y val)
(set-cdr! x (cons (cons key2 val) (cdr x)))))
(set! properties
(cons (list key1 (cons key2 val)) properties)))))
(define (my+dderiv a)
(cons '+
(map dderiv (cdr a))))
(define (my-dderiv a)
(cons '-
(map dderiv (cdr a))))
(define (*dderiv a)
(list '*
a
(cons '+
(map (lambda (a) (list '/ (dderiv a) a)) (cdr a)))))
(define (/dderiv a)
(list '-
(list '/
(dderiv (cadr a))
(caddr a))
(list '/
(cadr a)
(list '*
(caddr a)
(caddr a)
(dderiv (caddr a))))))
(define (dderiv a)
(if (not (pair? a))
(if (eq? a 'x) 1 0)
(let ((f (get (car a) 'dderiv)))
(if f
(f a)
(fatal-error "No derivation method available")))))
(define (main . args)
(run-benchmark
"dderiv"
dderiv-iters
(lambda (result)
(equal? result
'(+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x)))
(* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x)))
(* (* b x) (+ (/ 0 b) (/ 1 x)))
0)))
(lambda (a) (lambda () (dderiv a)))
'(+ (* 3 x x) (* a x x) (* b x) 5)))
(put '+ 'dderiv my+dderiv)
(put '- 'dderiv my-dderiv)
(put '* 'dderiv *dderiv)
(put '/ 'dderiv /dderiv))

49
benchmarks/new/r6rs-benchmarks/deriv.ss Normal file
View File

@ -0,0 +1,49 @@
;;; DERIV -- Symbolic derivation.
(library (r6rs-benchmarks deriv)
(export main)
(import (r6rs) (r6rs-benchmarks))
;;; Returns the wrong answer for quotients.
;;; Fortunately these aren't used in the benchmark.
(define (deriv a)
(cond ((not (pair? a))
(if (eq? a 'x) 1 0))
((eq? (car a) '+)
(cons '+
(map deriv (cdr a))))
((eq? (car a) '-)
(cons '-
(map deriv (cdr a))))
((eq? (car a) '*)
(list '*
a
(cons '+
(map (lambda (a) (list '/ (deriv a) a)) (cdr a)))))
((eq? (car a) '/)
(list '-
(list '/
(deriv (cadr a))
(caddr a))
(list '/
(cadr a)
(list '*
(caddr a)
(caddr a)
(deriv (caddr a))))))
(else
(fatal-error "No derivation method available"))))
(define (main . args)
(run-benchmark
"deriv"
deriv-iters
(lambda (result)
(equal? result
'(+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x)))
(* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x)))
(* (* b x) (+ (/ 0 b) (/ 1 x)))
0)))
(lambda (a) (lambda () (deriv a)))
'(+ (* 3 x x) (* a x x) (* b x) 5))))

69
benchmarks/new/r6rs-benchmarks/destruc.ss Normal file
View File

@ -0,0 +1,69 @@
;;; DESTRUC -- Destructive operation benchmark.
(library (r6rs-benchmarks destruc)
(export main)
(import (r6rs)
(r6rs mutable-pairs)
(r6rs-benchmarks))
(define (append-to-tail! x y)
(if (null? x)
y
(let loop ((a x) (b (cdr x)))
(if (null? b)
(begin
(set-cdr! a y)
x)
(loop b (cdr b))))))
(define (destructive n m)
(let ((l (do ((i 10 (- i 1)) (a '() (cons '() a)))
((= i 0) a))))
(do ((i n (- i 1)))
((= i 0) l)
(cond ((null? (car l))
(do ((l l (cdr l)))
((null? l))
(if (null? (car l)) (set-car! l (cons '() '())))
(append-to-tail! (car l)
(do ((j m (- j 1)) (a '() (cons '() a)))
((= j 0) a)))))
(else
(do ((l1 l (cdr l1)) (l2 (cdr l) (cdr l2)))
((null? l2))
(set-cdr! (do ((j (quotient (length (car l2)) 2) (- j 1))
(a (car l2) (cdr a)))
((zero? j) a)
(set-car! a i))
(let ((n (quotient (length (car l1)) 2)))
(cond ((= n 0)
(set-car! l1 '())
(car l1))
(else
(do ((j n (- j 1)) (a (car l1) (cdr a)))
((= j 1)
(let ((x (cdr a)))
(set-cdr! a '())
x))
(set-car! a i))))))))))))
(define (main . args)
(run-benchmark
"destruc"
destruc-iters
(lambda (result)
(equal? result
'((1 1 2)
(1 1 1)
(1 1 1 2)
(1 1 1 1)
(1 1 1 1 2)
(1 1 1 1 2)
(1 1 1 1 2)
(1 1 1 1 2)
(1 1 1 1 2)
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 3))))
(lambda (n m) (lambda () (destructive n m)))
600
50)))

31
benchmarks/new/r6rs-benchmarks/diviter.ss Normal file
View File

@ -0,0 +1,31 @@
;;; DIVITER -- Benchmark which divides by 2 using lists of n ()'s.
(library (r6rs-benchmarks diviter)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (create-n n)
(do ((n n (- n 1))
(a '() (cons '() a)))
((= n 0) a)))
(define *ll* (create-n 200))
(define (iterative-div2 l)
(do ((l l (cddr l))
(a '() (cons (car l) a)))
((null? l) a)))
(define (main . args)
(run-benchmark
"diviter"
diviter-iters
(lambda (result)
(equal? result
'(() () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () ())))
(lambda (l) (lambda () (iterative-div2 l)))
*ll*)))

30
benchmarks/new/r6rs-benchmarks/divrec.ss Normal file
View File

@ -0,0 +1,30 @@
;;; DIVREC -- Benchmark which divides by 2 using lists of n ()'s.
(library (r6rs-benchmarks divrec)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (create-n n)
(do ((n n (- n 1))
(a '() (cons '() a)))
((= n 0) a)))
(define *ll* (create-n 200))
(define (recursive-div2 l)
(cond ((null? l) '())
(else (cons (car l) (recursive-div2 (cddr l))))))
(define (main . args)
(run-benchmark
"divrec"
divrec-iters
(lambda (result)
(equal? result
'(() () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () ())))
(lambda (l) (lambda () (recursive-div2 l)))
*ll*)))

2320
benchmarks/new/r6rs-benchmarks/dynamic.src.ss Normal file
View File

File diff suppressed because it is too large Load Diff

5
benchmarks/new/r6rs-benchmarks/dynamic.ss Normal file
View File

@ -0,0 +1,5 @@
(library (r6rs-benchmarks dynamic)
(export main)
(import (r6rs) (r6rs mutable-pairs) (r6rs-benchmarks))
(include-source "dynamic.src.ss"))

655
benchmarks/new/r6rs-benchmarks/earley.ss Normal file
View File

@ -0,0 +1,655 @@
;;; EARLEY -- Earley's parser, written by Marc Feeley.
; (make-parser grammar lexer) is used to create a parser from the grammar
; description `grammar' and the lexer function `lexer'.
;
; A grammar is a list of definitions. Each definition defines a non-terminal
; by a set of rules. Thus a definition has the form: (nt rule1 rule2...).
; A given non-terminal can only be defined once. The first non-terminal
; defined is the grammar's goal. Each rule is a possibly empty list of
; non-terminals. Thus a rule has the form: (nt1 nt2...). A non-terminal
; can be any scheme value. Note that all grammar symbols are treated as
; non-terminals. This is fine though because the lexer will be outputing
; non-terminals.
;
; The lexer defines what a token is and the mapping between tokens and
; the grammar's non-terminals. It is a function of one argument, the input,
; that returns the list of tokens corresponding to the input. Each token is
; represented by a list. The first element is some `user-defined' information
; associated with the token and the rest represents the token's class(es) (as a
; list of non-terminals that this token corresponds to).
;
; The result of `make-parser' is a function that parses the single input it
; is given into the grammar's goal. The result is a `parse' which can be
; manipulated with the procedures: `parse->parsed?', `parse->trees'
; and `parse->nb-trees' (see below).
;
; Let's assume that we want a parser for the grammar
;
; S -> x = E
; E -> E + E | V
; V -> V y |
;
; and that the input to the parser is a string of characters. Also, assume we
; would like to map the characters `x', `y', `+' and `=' into the corresponding
; non-terminals in the grammar. Such a parser could be created with
;
; (make-parser
; '(
; (s (x = e))
; (e (e + e) (v))
; (v (v y) ())
; )
; (lambda (str)
; (map (lambda (char)
; (list char ; user-info = the character itself
; (case char
; ((#\x) 'x)
; ((#\y) 'y)
; ((#\+) '+)
; ((#\=) '=)
; (else (fatal-error "lexer error")))))
; (string->list str)))
; )
;
; An alternative definition (that does not check for lexical errors) is
;
; (make-parser
; '(
; (s (#\x #\= e))
; (e (e #\+ e) (v))
; (v (v #\y) ())
; )
; (lambda (str) (map (lambda (char) (list char char)) (string->list str)))
; )
;
; To help with the rest of the discussion, here are a few definitions:
;
; An input pointer (for an input of `n' tokens) is a value between 0 and `n'.
; It indicates a point between two input tokens (0 = beginning, `n' = end).
; For example, if `n' = 4, there are 5 input pointers:
;
; input token1 token2 token3 token4
; input pointers 0 1 2 3 4
;
; A configuration indicates the extent to which a given rule is parsed (this
; is the common `dot notation'). For simplicity, a configuration is
; represented as an integer, with successive configurations in the same
; rule associated with successive integers. It is assumed that the grammar
; has been extended with rules to aid scanning. These rules are of the
; form `nt ->', and there is one such rule for every non-terminal. Note
; that these rules are special because they only apply when the corresponding
; non-terminal is returned by the lexer.
;
; A configuration set is a configuration grouped with the set of input pointers
; representing where the head non-terminal of the configuration was predicted.
;
; Here are the rules and configurations for the grammar given above:
;
; S -> . \
; 0 |
; x -> . |
; 1 |
; = -> . |
; 2 |
; E -> . |
; 3 > special rules (for scanning)
; + -> . |
; 4 |
; V -> . |
; 5 |
; y -> . |
; 6 /
; S -> . x . = . E .
; 7 8 9 10
; E -> . E . + . E .
; 11 12 13 14
; E -> . V .
; 15 16
; V -> . V . y .
; 17 18 19
; V -> .
; 20
;
; Starters of the non-terminal `nt' are configurations that are leftmost
; in a non-special rule for `nt'. Enders of the non-terminal `nt' are
; configurations that are rightmost in any rule for `nt'. Predictors of the
; non-terminal `nt' are configurations that are directly to the left of `nt'
; in any rule.
;
; For the grammar given above,
;
; Starters of V = (17 20)
; Enders of V = (5 19 20)
; Predictors of V = (15 17)
(library (r6rs-benchmarks earley)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (make-parser grammar lexer)
(define (non-terminals grammar) ; return vector of non-terminals in grammar
(define (add-nt nt nts)
(if (member nt nts) nts (cons nt nts))) ; use equal? for equality tests
(let def-loop ((defs grammar) (nts '()))
(if (pair? defs)
(let* ((def (car defs))
(head (car def)))
(let rule-loop ((rules (cdr def))
(nts (add-nt head nts)))
(if (pair? rules)
(let ((rule (car rules)))
(let loop ((l rule) (nts nts))
(if (pair? l)
(let ((nt (car l)))
(loop (cdr l) (add-nt nt nts)))
(rule-loop (cdr rules) nts))))
(def-loop (cdr defs) nts))))
(list->vector (reverse nts))))) ; goal non-terminal must be at index 0
(define (ind nt nts) ; return index of non-terminal `nt' in `nts'
(let loop ((i (- (vector-length nts) 1)))
(if (>= i 0)
(if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
#f)))
(define (nb-configurations grammar) ; return nb of configurations in grammar
(let def-loop ((defs grammar) (nb-confs 0))
(if (pair? defs)
(let ((def (car defs)))
(let rule-loop ((rules (cdr def)) (nb-confs nb-confs))
(if (pair? rules)
(let ((rule (car rules)))
(let loop ((l rule) (nb-confs nb-confs))
(if (pair? l)
(loop (cdr l) (+ nb-confs 1))
(rule-loop (cdr rules) (+ nb-confs 1)))))
(def-loop (cdr defs) nb-confs))))
nb-confs)))
; First, associate a numeric identifier to every non-terminal in the
; grammar (with the goal non-terminal associated with 0).
;
; So, for the grammar given above we get:
;
; s -> 0 x -> 1 = -> 4 e ->3 + -> 4 v -> 5 y -> 6
(let* ((nts (non-terminals grammar)) ; id map = list of non-terms
(nb-nts (vector-length nts)) ; the number of non-terms
(nb-confs (+ (nb-configurations grammar) nb-nts)) ; the nb of confs
(starters (make-vector nb-nts '())) ; starters for every non-term
(enders (make-vector nb-nts '())) ; enders for every non-term
(predictors (make-vector nb-nts '())) ; predictors for every non-term
(steps (make-vector nb-confs #f)) ; what to do in a given conf
(names (make-vector nb-confs #f))) ; name of rules
(define (setup-tables grammar nts starters enders predictors steps names)
(define (add-conf conf nt nts class)
(let ((i (ind nt nts)))
(vector-set! class i (cons conf (vector-ref class i)))))
(let ((nb-nts (vector-length nts)))
(let nt-loop ((i (- nb-nts 1)))
(if (>= i 0)
(begin
(vector-set! steps i (- i nb-nts))
(vector-set! names i (list (vector-ref nts i) 0))
(vector-set! enders i (list i))
(nt-loop (- i 1)))))
(let def-loop ((defs grammar) (conf (vector-length nts)))
(if (pair? defs)
(let* ((def (car defs))
(head (car def)))
(let rule-loop ((rules (cdr def)) (conf conf) (rule-num 1))
(if (pair? rules)
(let ((rule (car rules)))
(vector-set! names conf (list head rule-num))
(add-conf conf head nts starters)
(let loop ((l rule) (conf conf))
(if (pair? l)
(let ((nt (car l)))
(vector-set! steps conf (ind nt nts))
(add-conf conf nt nts predictors)
(loop (cdr l) (+ conf 1)))
(begin
(vector-set! steps conf (- (ind head nts) nb-nts))
(add-conf conf head nts enders)
(rule-loop (cdr rules) (+ conf 1) (+ rule-num 1))))))
(def-loop (cdr defs) conf))))))))
; Now, for each non-terminal, compute the starters, enders and predictors and
; the names and steps tables.
(setup-tables grammar nts starters enders predictors steps names)
; Build the parser description
(let ((parser-descr (vector lexer
nts
starters
enders
predictors
steps
names)))
(lambda (input)
(define (ind nt nts) ; return index of non-terminal `nt' in `nts'
(let loop ((i (- (vector-length nts) 1)))
(if (>= i 0)
(if (equal? (vector-ref nts i) nt) i (loop (- i 1)))
#f)))
(define (comp-tok tok nts) ; transform token to parsing format
(let loop ((l1 (cdr tok)) (l2 '()))
(if (pair? l1)
(let ((i (ind (car l1) nts)))
(if i
(loop (cdr l1) (cons i l2))
(loop (cdr l1) l2)))
(cons (car tok) (reverse l2)))))
(define (input->tokens input lexer nts)
(list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input))))
(define (make-states nb-toks nb-confs)
(let ((states (make-vector (+ nb-toks 1) #f)))
(let loop ((i nb-toks))
(if (>= i 0)
(let ((v (make-vector (+ nb-confs 1) #f)))
(vector-set! v 0 -1)
(vector-set! states i v)
(loop (- i 1)))
states))))
(define (conf-set-get state conf)
(vector-ref state (+ conf 1)))
(define (conf-set-get* state state-num conf)
(let ((conf-set (conf-set-get state conf)))
(if conf-set
conf-set
(let ((conf-set (make-vector (+ state-num 6) #f)))
(vector-set! conf-set 1 -3) ; old elems tail (points to head)
(vector-set! conf-set 2 -1) ; old elems head
(vector-set! conf-set 3 -1) ; new elems tail (points to head)
(vector-set! conf-set 4 -1) ; new elems head
(vector-set! state (+ conf 1) conf-set)
conf-set))))
(define (conf-set-merge-new! conf-set)
(vector-set! conf-set
(+ (vector-ref conf-set 1) 5)
(vector-ref conf-set 4))
(vector-set! conf-set 1 (vector-ref conf-set 3))
(vector-set! conf-set 3 -1)
(vector-set! conf-set 4 -1))
(define (conf-set-head conf-set)
(vector-ref conf-set 2))
(define (conf-set-next conf-set i)
(vector-ref conf-set (+ i 5)))
(define (conf-set-member? state conf i)
(let ((conf-set (vector-ref state (+ conf 1))))
(if conf-set
(conf-set-next conf-set i)
#f)))
(define (conf-set-adjoin state conf-set conf i)
(let ((tail (vector-ref conf-set 3))) ; put new element at tail
(vector-set! conf-set (+ i 5) -1)
(vector-set! conf-set (+ tail 5) i)
(vector-set! conf-set 3 i)
(if (< tail 0)
(begin
(vector-set! conf-set 0 (vector-ref state 0))
(vector-set! state 0 conf)))))
(define (conf-set-adjoin* states state-num l i)
(let ((state (vector-ref states state-num)))
(let loop ((l1 l))
(if (pair? l1)
(let* ((conf (car l1))
(conf-set (conf-set-get* state state-num conf)))
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (cdr l1)))
(loop (cdr l1))))))))
(define (conf-set-adjoin** states states* state-num conf i)
(let ((state (vector-ref states state-num)))
(if (conf-set-member? state conf i)
(let* ((state* (vector-ref states* state-num))
(conf-set* (conf-set-get* state* state-num conf)))
(if (not (conf-set-next conf-set* i))
(conf-set-adjoin state* conf-set* conf i))
#t)
#f)))
(define (conf-set-union state conf-set conf other-set)
(let loop ((i (conf-set-head other-set)))
(if (>= i 0)
(if (not (conf-set-next conf-set i))
(begin
(conf-set-adjoin state conf-set conf i)
(loop (conf-set-next other-set i)))
(loop (conf-set-next other-set i))))))
(define (forw states state-num starters enders predictors steps nts)
(define (predict state state-num conf-set conf nt starters enders)
; add configurations which start the non-terminal `nt' to the
; right of the dot
(let loop1 ((l (vector-ref starters nt)))
(if (pair? l)
(let* ((starter (car l))
(starter-set (conf-set-get* state state-num starter)))
(if (not (conf-set-next starter-set state-num))
(begin
(conf-set-adjoin state starter-set starter state-num)
(loop1 (cdr l)))
(loop1 (cdr l))))))
; check for possible completion of the non-terminal `nt' to the
; right of the dot
(let loop2 ((l (vector-ref enders nt)))
(if (pair? l)
(let ((ender (car l)))
(if (conf-set-member? state ender state-num)
(let* ((next (+ conf 1))
(next-set (conf-set-get* state state-num next)))
(conf-set-union state next-set next conf-set)
(loop2 (cdr l)))
(loop2 (cdr l)))))))
(define (reduce states state state-num conf-set head preds)
; a non-terminal is now completed so check for reductions that
; are now possible at the configurations `preds'
(let loop1 ((l preds))
(if (pair? l)
(let ((pred (car l)))
(let loop2 ((i head))
(if (>= i 0)
(let ((pred-set (conf-set-get (vector-ref states i) pred)))
(if pred-set
(let* ((next (+ pred 1))
(next-set (conf-set-get* state state-num next)))
(conf-set-union state next-set next pred-set)))
(loop2 (conf-set-next conf-set i)))
(loop1 (cdr l))))))))
(let ((state (vector-ref states state-num))
(nb-nts (vector-length nts)))
(let loop ()
(let ((conf (vector-ref state 0)))
(if (>= conf 0)
(let* ((step (vector-ref steps conf))
(conf-set (vector-ref state (+ conf 1)))
(head (vector-ref conf-set 4)))
(vector-set! state 0 (vector-ref conf-set 0))
(conf-set-merge-new! conf-set)
(if (>= step 0)
(predict state state-num conf-set conf step starters enders)
(let ((preds (vector-ref predictors (+ step nb-nts))))
(reduce states state state-num conf-set head preds)))
(loop)))))))
(define (forward starters enders predictors steps nts toks)
(let* ((nb-toks (vector-length toks))
(nb-confs (vector-length steps))
(states (make-states nb-toks nb-confs))
(goal-starters (vector-ref starters 0)))
(conf-set-adjoin* states 0 goal-starters 0) ; predict goal
(forw states 0 starters enders predictors steps nts)
(let loop ((i 0))
(if (< i nb-toks)
(let ((tok-nts (cdr (vector-ref toks i))))
(conf-set-adjoin* states (+ i 1) tok-nts i) ; scan token
(forw states (+ i 1) starters enders predictors steps nts)
(loop (+ i 1)))))
states))
(define (produce conf i j enders steps toks states states* nb-nts)
(let ((prev (- conf 1)))
(if (and (>= conf nb-nts) (>= (vector-ref steps prev) 0))
(let loop1 ((l (vector-ref enders (vector-ref steps prev))))
(if (pair? l)
(let* ((ender (car l))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)))
(if (>= k 0)
(begin
(and (>= k i)
(conf-set-adjoin** states states* k prev i)
(conf-set-adjoin** states states* j ender k))
(loop2 (conf-set-next ender-set k)))
(loop1 (cdr l))))
(loop1 (cdr l)))))))))
(define (back states states* state-num enders steps nb-nts toks)
(let ((state* (vector-ref states* state-num)))
(let loop1 ()
(let ((conf (vector-ref state* 0)))
(if (>= conf 0)
(let* ((conf-set (vector-ref state* (+ conf 1)))
(head (vector-ref conf-set 4)))
(vector-set! state* 0 (vector-ref conf-set 0))
(conf-set-merge-new! conf-set)
(let loop2 ((i head))
(if (>= i 0)
(begin
(produce conf i state-num enders steps
toks states states* nb-nts)
(loop2 (conf-set-next conf-set i)))
(loop1)))))))))
(define (backward states enders steps nts toks)
(let* ((nb-toks (vector-length toks))
(nb-confs (vector-length steps))
(nb-nts (vector-length nts))
(states* (make-states nb-toks nb-confs))
(goal-enders (vector-ref enders 0)))
(let loop1 ((l goal-enders))
(if (pair? l)
(let ((conf (car l)))
(conf-set-adjoin** states states* nb-toks conf 0)
(loop1 (cdr l)))))
(let loop2 ((i nb-toks))
(if (>= i 0)
(begin
(back states states* i enders steps nb-nts toks)
(loop2 (- i 1)))))
states*))
(define (parsed? nt i j nts enders states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
#t
(loop (cdr l))))
#f)))
#f)))
(define (deriv-trees conf i j enders steps names toks states nb-nts)
(let ((name (vector-ref names conf)))
(if name ; `conf' is at the start of a rule (either special or not)
(if (< conf nb-nts)
(list (list name (car (vector-ref toks i))))
(list (list name)))
(let ((prev (- conf 1)))
(let loop1 ((l1 (vector-ref enders (vector-ref steps prev)))
(l2 '()))
(if (pair? l1)
(let* ((ender (car l1))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)) (l2 l2))
(if (>= k 0)
(if (and (>= k i)
(conf-set-member? (vector-ref states k)
prev i))
(let ((prev-trees
(deriv-trees prev i k enders steps names
toks states nb-nts))
(ender-trees
(deriv-trees ender k j enders steps names
toks states nb-nts)))
(let loop3 ((l3 ender-trees) (l2 l2))
(if (pair? l3)
(let ((ender-tree (list (car l3))))
(let loop4 ((l4 prev-trees) (l2 l2))
(if (pair? l4)
(loop4 (cdr l4)
(cons (append (car l4)
ender-tree)
l2))
(loop3 (cdr l3) l2))))
(loop2 (conf-set-next ender-set k) l2))))
(loop2 (conf-set-next ender-set k) l2))
(loop1 (cdr l1) l2)))
(loop1 (cdr l1) l2)))
l2))))))
(define (deriv-trees* nt i j nts enders steps names toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)) (trees '()))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
(loop (cdr l)
(append (deriv-trees conf i j enders steps names
toks states nb-nts)
trees))
(loop (cdr l) trees)))
trees)))
#f)))
(define (nb-deriv-trees conf i j enders steps toks states nb-nts)
(let ((prev (- conf 1)))
(if (or (< conf nb-nts) (< (vector-ref steps prev) 0))
1
(let loop1 ((l (vector-ref enders (vector-ref steps prev)))
(n 0))
(if (pair? l)
(let* ((ender (car l))
(ender-set (conf-set-get (vector-ref states j)
ender)))
(if ender-set
(let loop2 ((k (conf-set-head ender-set)) (n n))
(if (>= k 0)
(if (and (>= k i)
(conf-set-member? (vector-ref states k)
prev i))
(let ((nb-prev-trees
(nb-deriv-trees prev i k enders steps
toks states nb-nts))
(nb-ender-trees
(nb-deriv-trees ender k j enders steps
toks states nb-nts)))
(loop2 (conf-set-next ender-set k)
(+ n (* nb-prev-trees nb-ender-trees))))
(loop2 (conf-set-next ender-set k) n))
(loop1 (cdr l) n)))
(loop1 (cdr l) n)))
n)))))
(define (nb-deriv-trees* nt i j nts enders steps toks states)
(let ((nt* (ind nt nts)))
(if nt*
(let ((nb-nts (vector-length nts)))
(let loop ((l (vector-ref enders nt*)) (nb-trees 0))
(if (pair? l)
(let ((conf (car l)))
(if (conf-set-member? (vector-ref states j) conf i)
(loop (cdr l)
(+ (nb-deriv-trees conf i j enders steps
toks states nb-nts)
nb-trees))
(loop (cdr l) nb-trees)))
nb-trees)))
#f)))
(let* ((lexer (vector-ref parser-descr 0))
(nts (vector-ref parser-descr 1))
(starters (vector-ref parser-descr 2))
(enders (vector-ref parser-descr 3))
(predictors (vector-ref parser-descr 4))
(steps (vector-ref parser-descr 5))
(names (vector-ref parser-descr 6))
(toks (input->tokens input lexer nts)))
(vector nts
starters
enders
predictors
steps
names
toks
(backward (forward starters enders predictors steps nts toks)
enders steps nts toks)
parsed?
deriv-trees*
nb-deriv-trees*))))))
(define (parse->parsed? parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(states (vector-ref parse 7))
(parsed? (vector-ref parse 8)))
(parsed? nt i j nts enders states)))
(define (parse->trees parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(steps (vector-ref parse 4))
(names (vector-ref parse 5))
(toks (vector-ref parse 6))
(states (vector-ref parse 7))
(deriv-trees* (vector-ref parse 9)))
(deriv-trees* nt i j nts enders steps names toks states)))
(define (parse->nb-trees parse nt i j)
(let* ((nts (vector-ref parse 0))
(enders (vector-ref parse 2))
(steps (vector-ref parse 4))
(toks (vector-ref parse 6))
(states (vector-ref parse 7))
(nb-deriv-trees* (vector-ref parse 10)))
(nb-deriv-trees* nt i j nts enders steps toks states)))
(define (test)
(let ((p (make-parser '( (s (a) (s s)) )
(lambda (l) (map (lambda (x) (list x x)) l)))))
(let ((x (p '(a a a a a a a a a))))
(length (parse->trees x 's 0 9)))))
(define (main . args)
(run-benchmark
"earley"
earley-iters
(lambda (result) (equal? result 1430))
(lambda () (lambda () (test))))))

33
benchmarks/new/r6rs-benchmarks/fibc.ss Normal file
View File

@ -0,0 +1,33 @@
;;; FIBC -- FIB using first-class continuations, written by Kent Dybvig
(library (r6rs-benchmarks fibc)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (_1+ n) (+ n 1))
(define (_1- n) (- n 1))
;;; fib with peano arithmetic (using numbers) with call/cc
(define (addc x y k)
(if (zero? y)
(k x)
(addc (_1+ x) (_1- y) k)))
(define (fibc x c)
(if (zero? x)
(c 0)
(if (zero? (_1- x))
(c 1)
(addc (call-with-current-continuation (lambda (c) (fibc (_1- x) c)))
(call-with-current-continuation (lambda (c) (fibc (_1- (_1- x)) c)))
c))))
(define (main)
(run-benchmark
"fibc"
fibc-iters
(lambda (result) (equal? result 2584))
(lambda (x c) (lambda () (fibc x c)))
18
(lambda (n) n))))

22
benchmarks/new/r6rs-benchmarks/fibfp.ss Normal file
View File

@ -0,0 +1,22 @@
;;; FIBFP -- Computes fib(35) using floating point
(library (r6rs-benchmarks fibfp)
(export main)
(import (r6rs)
(r6rs arithmetic flonums)
(r6rs-benchmarks))
(define (fibfp n)
(if (fl<? n 2.)
n
(fl+ (fibfp (fl- n 1.))
(fibfp (fl- n 2.)))))
(define (main . args)
(run-benchmark
"fibfp"
fibfp-iters
(lambda (result) (equal? result 9227465.))
(lambda (n) (lambda () (fibfp n)))
35.)))

193
benchmarks/new/r6rs-benchmarks/gcbench.ss Normal file
View File

@ -0,0 +1,193 @@
; This is adapted from a benchmark written by John Ellis and Pete Kovac
; of Post Communications.
; It was modified by Hans Boehm of Silicon Graphics.
; It was translated into Scheme by William D Clinger of Northeastern Univ;
; the Scheme version uses (RUN-BENCHMARK <string> <thunk>)
; Last modified 30 May 1997.
;
; This is no substitute for real applications. No actual application
; is likely to behave in exactly this way. However, this benchmark was
; designed to be more representative of real applications than other
; Java GC benchmarks of which we are aware.
; It attempts to model those properties of allocation requests that
; are important to current GC techniques.
; It is designed to be used either to obtain a single overall performance
; number, or to give a more detailed estimate of how collector
; performance varies with object lifetimes. It prints the time
; required to allocate and collect balanced binary trees of various
; sizes. Smaller trees result in shorter object lifetimes. Each cycle
; allocates roughly the same amount of memory.
; Two data structures are kept around during the entire process, so
; that the measured performance is representative of applications
; that maintain some live in-memory data. One of these is a tree
; containing many pointers. The other is a large array containing
; double precision floating point numbers. Both should be of comparable
; size.
;
; The results are only really meaningful together with a specification
; of how much memory was used. It is possible to trade memory for
; better time performance. This benchmark should be run in a 32 MB
; heap, though we don't currently know how to enforce that uniformly.
; In the Java version, this routine prints the heap size and the amount
; of free memory. There is no portable way to do this in Scheme; each
; implementation needs its own version.
(library (r6rs-benchmarks gcbench)
(export main)
(import (r6rs) (r6rs arithmetic flonums) (r6rs-benchmarks))
(define (run-benchmark2 name thunk)
(display name)
(newline)
(thunk))
(define (PrintDiagnostics)
(display " Total memory available= ???????? bytes")
(display " Free memory= ???????? bytes")
(newline))
(define (gcbench kStretchTreeDepth)
; Nodes used by a tree of a given size
(define (TreeSize i)
(- (expt 2 (+ i 1)) 1))
; Number of iterations to use for a given tree depth
(define (NumIters i)
(quotient (* 2 (TreeSize kStretchTreeDepth))
(TreeSize i)))
; Parameters are determined by kStretchTreeDepth.
; In Boehm's version the parameters were fixed as follows:
; public static final int kStretchTreeDepth = 18; // about 16Mb
; public static final int kLongLivedTreeDepth = 16; // about 4Mb
; public static final int kArraySize = 500000; // about 4Mb
; public static final int kMinTreeDepth = 4;
; public static final int kMaxTreeDepth = 16;
; In Larceny the storage numbers above would be 12 Mby, 3 Mby, 6 Mby.
(let* ((kLongLivedTreeDepth (- kStretchTreeDepth 2))
(kArraySize (* 4 (TreeSize kLongLivedTreeDepth)))
(kMinTreeDepth 4)
(kMaxTreeDepth kLongLivedTreeDepth))
; Elements 3 and 4 of the allocated vectors are useless.
(let* ((make-empty-node (lambda () (make-vector 4 0)))
(make-node
(lambda (l r)
(let ((v (make-empty-node)))
(vector-set! v 0 l)
(vector-set! v 1 r)
v)))
(node.left (lambda (node) (vector-ref node 0)))
(node.right (lambda (node) (vector-ref node 1)))
(node.left-set! (lambda (node x) (vector-set! node 0 x)))
(node.right-set! (lambda (node x) (vector-set! node 1 x))))
; Build tree top down, assigning to older objects.
(define (Populate iDepth thisNode)
(if (<= iDepth 0)
#f
(let ((iDepth (- iDepth 1)))
(node.left-set! thisNode (make-empty-node))
(node.right-set! thisNode (make-empty-node))
(Populate iDepth (node.left thisNode))
(Populate iDepth (node.right thisNode)))))
; Build tree bottom-up
(define (MakeTree iDepth)
(if (<= iDepth 0)
(make-empty-node)
(make-node (MakeTree (- iDepth 1))
(MakeTree (- iDepth 1)))))
(define (TimeConstruction depth)
(let ((iNumIters (NumIters depth)))
(display (string-append "Creating "
(number->string iNumIters)
" trees of depth "
(number->string depth)))
(newline)
(run-benchmark2
"GCBench: Top down construction"
(lambda ()
(do ((i 0 (+ i 1)))
((>= i iNumIters))
(Populate depth (make-empty-node)))))
(run-benchmark2
"GCBench: Bottom up construction"
(lambda ()
(do ((i 0 (+ i 1)))
((>= i iNumIters))
(MakeTree depth))))))
(define (main)
(display "Garbage Collector Test")
(newline)
(display (string-append
" Stretching memory with a binary tree of depth "
(number->string kStretchTreeDepth)))
(newline)
(PrintDiagnostics)
(run-benchmark2
"GCBench: Main"
(lambda ()
; Stretch the memory space quickly
(MakeTree kStretchTreeDepth)
; Create a long lived object
(display (string-append
" Creating a long-lived binary tree of depth "
(number->string kLongLivedTreeDepth)))
(newline)
(let ((longLivedTree (make-empty-node)))
(Populate kLongLivedTreeDepth longLivedTree)
; Create long-lived array, filling half of it
(display (string-append
" Creating a long-lived array of "
(number->string kArraySize)
" inexact reals"))
(newline)
(let ((array (make-vector kArraySize 0.0)))
(do ((i 0 (+ i 1)))
((>= i (quotient kArraySize 2)))
(vector-set! array i (/ 1.0 (exact->inexact (+ i 1)))))
(PrintDiagnostics)
(do ((d kMinTreeDepth (+ d 2)))
((> d kMaxTreeDepth))
(TimeConstruction d))
(if (or (eq? longLivedTree '())
(let ((n (min 1000
(- (quotient (vector-length array)
2)
1))))
(not (fl=? (vector-ref array n)
(/ 1.0 (exact->inexact (+ n 1)))))))
(begin (display "Failed") (newline)))
; fake reference to LongLivedTree
; and array
; to keep them from being optimized away
))))
(PrintDiagnostics))
(main))))
(define (main . rest)
(let ((k (if (null? rest) 18 (car rest))))
(display "The garbage collector should touch about ")
(display (expt 2 (- k 13)))
(display " megabytes of heap storage.")
(newline)
(display "The use of more or less memory will skew the results.")
(newline)
(run-benchmark
(string-append "GCBench" (number->string k))
gcbench-iters
(lambda (result) #t)
(lambda (k) (lambda () (gcbench k)))
k))))

388
benchmarks/new/r6rs-benchmarks/gcold.ss Normal file
View File

@ -0,0 +1,388 @@
;
; GCOld.sch x.x 00/08/03
; translated from GCOld.java 2.0a 00/08/23
;
; Copyright 2000 Sun Microsystems, Inc. All rights reserved.
;
;
; Should be good enough for this benchmark.
(library (r6rs-benchmarks gcold)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (newRandom)
(letrec ((random14
(lambda (n)
(set! x (remainder (+ (* a x) c) m))
(remainder (quotient x 8) n)))
(a 701)
(x 1)
(c 743483)
(m 524288)
(loop
(lambda (q r n)
(if (zero? q)
(remainder r n)
(loop (quotient q 16384)
(+ (* 16384 r) (random14 16384))
n)))))
(lambda (n)
(if (and (exact? n) (integer? n) (< n 16384))
(random14 n)
(loop n (random14 16384) n)))))
; A TreeNode is a record with three fields: left, right, val.
; The left and right fields contain a TreeNode or 0, and the
; val field will contain the integer height of the tree.
(define-syntax newTreeNode
(syntax-rules ()
((newTreeNode left right val)
(vector left right val))
((newTreeNode)
(vector 0 0 0))))
(define-syntax TreeNode.left
(syntax-rules ()
((TreeNode.left node)
(vector-ref node 0))))
(define-syntax TreeNode.right
(syntax-rules ()
((TreeNode.right node)
(vector-ref node 1))))
(define-syntax TreeNode.val
(syntax-rules ()
((TreeNode.val node)
(vector-ref node 2))))
(define-syntax setf
(syntax-rules (TreeNode.left TreeNode.right TreeNode.val)
((setf (TreeNode.left node) x)
(vector-set! node 0 x))
((setf (TreeNode.right node) x)
(vector-set! node 1 x))
((setf (TreeNode.val node) x)
(vector-set! node 2 x))))
; Args:
; live-data-size: in megabytes.
; work: units of mutator non-allocation work per byte allocated,
; (in unspecified units. This will affect the promotion rate
; printed at the end of the run: more mutator work per step implies
; fewer steps per second implies fewer bytes promoted per second.)
; short/long ratio: ratio of short-lived bytes allocated to long-lived
; bytes allocated.
; pointer mutation rate: number of pointer mutations per step.
; steps: number of steps to do.
;
(define (GCOld size workUnits promoteRate ptrMutRate steps)
(define (println . args)
(for-each display args)
(newline))
; Rounds an inexact real to two decimal places.
(define (round2 x)
(/ (round (* 100.0 x)) 100.0))
; Returns the height of the given tree.
(define (height t)
(if (eqv? t 0)
0
(+ 1 (max (height (TreeNode.left t))
(height (TreeNode.right t))))))
; Returns the length of the shortest path in the given tree.
(define (shortestPath t)
(if (eqv? t 0)
0
(+ 1 (min (shortestPath (TreeNode.left t))
(shortestPath (TreeNode.right t))))))
; Returns the number of nodes in a balanced tree of the given height.
(define (heightToNodes h)
(- (expt 2 h) 1))
; Returns the height of the largest balanced tree
; that has no more than the given number of nodes.
(define (nodesToHeight nodes)
(do ((h 1 (+ h 1))
(n 1 (+ n n)))
((> (+ n n -1) nodes)
(- h 1))))
(let* (
; Constants.
(null 0) ; Java's null
(pathBits 65536) ; to generate 16 random bits
(MEG 1000000)
(INSIGNIFICANT 999) ; this many bytes don't matter
(bytes/word 4)
(bytes/node 20) ; bytes per tree node in typical JVM
(words/dead 100) ; size of young garbage objects
; Returns the number of bytes in a balanced tree of the given height.
(heightToBytes
(lambda (h)
(* bytes/node (heightToNodes h))))
; Returns the height of the largest balanced tree
; that occupies no more than the given number of bytes.
(bytesToHeight
(lambda (bytes)
(nodesToHeight (/ bytes bytes/node))))
(treeHeight 14)
(treeSize (heightToBytes treeHeight))
(msg1 "Usage: java GCOld <size> <work> <ratio> <mutation> <steps>")
(msg2 " where <size> is the live storage in megabytes")
(msg3 " <work> is the mutator work per step (arbitrary units)")
(msg4 " <ratio> is the ratio of short-lived to long-lived allocation")
(msg5 " <mutation> is the mutations per step")
(msg6 " <steps> is the number of steps")
; Counters (and global variables that discourage optimization).
(youngBytes 0)
(nodes 0)
(actuallyMut 0)
(mutatorSum 0)
(aexport '#())
; Global variables.
(trees '#())
(where 0)
(rnd (newRandom))
)
; Returns a newly allocated balanced binary tree of height h.
(define (makeTree h)
(if (zero? h)
null
(let ((res (newTreeNode)))
(set! nodes (+ nodes 1))
(setf (TreeNode.left res) (makeTree (- h 1)))
(setf (TreeNode.right res) (makeTree (- h 1)))
(setf (TreeNode.val res) h)
res)))
; Allocates approximately size megabytes of trees and stores
; them into a global array.
(define (init)
; Each tree will be about a megabyte.
(let ((ntrees (quotient (* size MEG) treeSize)))
(set! trees (make-vector ntrees null))
(println "Allocating " ntrees " trees.")
(println " (" (* ntrees treeSize) " bytes)")
(do ((i 0 (+ i 1)))
((>= i ntrees))
(vector-set! trees i (makeTree treeHeight))
(doYoungGenAlloc (* promoteRate ntrees treeSize) words/dead))
(println " (" nodes " nodes)")))
; Confirms that all trees are balanced and have the correct height.
(define (checkTrees)
(let ((ntrees (vector-length trees)))
(do ((i 0 (+ i 1)))
((>= i ntrees))
(let* ((t (vector-ref trees i))
(h1 (height t))
(h2 (shortestPath t)))
(if (or (not (= h1 treeHeight))
(not (= h2 treeHeight)))
(println "*****BUG: " h1 " " h2))))))
; Called only by replaceTree (below) and by itself.
(define (replaceTreeWork full partial dir)
(let ((canGoLeft (and (not (eq? (TreeNode.left full) null))
(> (TreeNode.val (TreeNode.left full))
(TreeNode.val partial))))
(canGoRight (and (not (eq? (TreeNode.right full) null))
(> (TreeNode.val (TreeNode.right full))
(TreeNode.val partial)))))
(cond ((and canGoLeft canGoRight)
(if dir
(replaceTreeWork (TreeNode.left full)
partial
(not dir))
(replaceTreeWork (TreeNode.right full)
partial
(not dir))))
((and (not canGoLeft) (not canGoRight))
(if dir
(setf (TreeNode.left full) partial)
(setf (TreeNode.right full) partial)))
((not canGoLeft)
(setf (TreeNode.left full) partial))
(else
(setf (TreeNode.right full) partial)))))
; Given a balanced tree full and a smaller balanced tree partial,
; replaces an appropriate subtree of full by partial, taking care
; to preserve the shape of the full tree.
(define (replaceTree full partial)
(let ((dir (zero? (modulo (TreeNode.val partial) 2))))
(set! actuallyMut (+ actuallyMut 1))
(replaceTreeWork full partial dir)))
; Allocates approximately n bytes of long-lived storage,
; replacing oldest existing long-lived storage.
(define (oldGenAlloc n)
(let ((full (quotient n treeSize))
(partial (modulo n treeSize)))
;(println "In oldGenAlloc, doing "
; full
; " full trees and one partial tree of size "
; partial)
(do ((i 0 (+ i 1)))
((>= i full))
(vector-set! trees where (makeTree treeHeight))
(set! where
(modulo (+ where 1) (vector-length trees))))
(let loop ((partial partial))
(if (> partial INSIGNIFICANT)
(let* ((h (bytesToHeight partial))
(newTree (makeTree h)))
(replaceTree (vector-ref trees where) newTree)
(set! where
(modulo (+ where 1) (vector-length trees)))
(loop (- partial (heightToBytes h))))))))
; Interchanges two randomly selected subtrees (of same size and depth).
(define (oldGenSwapSubtrees)
; Randomly pick:
; * two tree indices
; * A depth
; * A path to that depth.
(let* ((index1 (rnd (vector-length trees)))
(index2 (rnd (vector-length trees)))
(depth (rnd treeHeight))
(path (rnd pathBits))
(tn1 (vector-ref trees index1))
(tn2 (vector-ref trees index2)))
(do ((i 0 (+ i 1)))
((>= i depth))
(if (even? path)
(begin (set! tn1 (TreeNode.left tn1))
(set! tn2 (TreeNode.left tn2)))
(begin (set! tn1 (TreeNode.right tn1))
(set! tn2 (TreeNode.right tn2))))
(set! path (quotient path 2)))
(if (even? path)
(let ((tmp (TreeNode.left tn1)))
(setf (TreeNode.left tn1) (TreeNode.left tn2))
(setf (TreeNode.left tn2) tmp))
(let ((tmp (TreeNode.right tn1)))
(setf (TreeNode.right tn1) (TreeNode.right tn2))
(setf (TreeNode.right tn2) tmp)))
(set! actuallyMut (+ actuallyMut 2))))
; Update "n" old-generation pointers.
(define (oldGenMut n)
(do ((i 0 (+ i 1)))
((>= i (quotient n 2)))
(oldGenSwapSubtrees)))
; Does the amount of mutator work appropriate for n bytes of young-gen
; garbage allocation.
(define (doMutWork n)
(let ((limit (quotient (* workUnits n) 10)))
(do ((k 0 (+ k 1))
(sum 0 (+ sum 1)))
((>= k limit)
; We don't want dead code elimination to eliminate this loop.
(set! mutatorSum (+ mutatorSum sum))))))
; Allocate n bytes of young-gen garbage, in units of "nwords"
; words.
(define (doYoungGenAlloc n nwords)
(let ((nbytes (* nwords bytes/word)))
(do ((allocated 0 (+ allocated nbytes)))
((>= allocated n)
(set! youngBytes (+ youngBytes allocated)))
(set! aexport (make-vector nwords 0)))))
; Allocate "n" bytes of young-gen data; and do the
; corresponding amount of old-gen allocation and pointer
; mutation.
; oldGenAlloc may perform some mutations, so this code
; takes those mutations into account.
(define (doStep n)
(let ((mutations actuallyMut))
(doYoungGenAlloc n words/dead)
(doMutWork n)
; Now do old-gen allocation
(oldGenAlloc (quotient n promoteRate))
(oldGenMut (max 0 (- (+ mutations ptrMutRate) actuallyMut)))))
(println size " megabytes")
(println workUnits " work units per step.")
(println "promotion ratio is 1:" promoteRate)
(println "pointer mutation rate is " ptrMutRate)
(println steps " steps")
(init)
(checkTrees)
(set! youngBytes 0)
(set! nodes 0)
(println "Initialization complete...")
(run-benchmark "GCOld"
1
(lambda (result) #t)
(lambda ()
(lambda ()
(do ((step 0 (+ step 1)))
((>= step steps))
(doStep MEG)))))
(checkTrees)
(println "Allocated " steps " Mb of young gen garbage")
(println " (actually allocated "
(round2 (/ youngBytes MEG))
" megabytes)")
(println "Promoted " (round2 (/ steps promoteRate)) " Mb")
(println " (actually promoted "
(round2 (/ (* nodes bytes/node) MEG))
" megabytes)")
(if (not (zero? ptrMutRate))
(println "Mutated " actuallyMut " pointers"))
; This output serves mainly to discourage optimization.
(+ mutatorSum (vector-length aexport))))
(define (main . args)
(GCOld 25 0 10 10 gcold-iters)))

607
benchmarks/new/r6rs-benchmarks/graphs.ss Normal file
View File

@ -0,0 +1,607 @@
;;; GRAPHS -- Obtained from Andrew Wright.
(library (r6rs-benchmarks graphs)
(export main)
(import (r6rs) (r6rs-benchmarks))
;;; ==== util.ss ====
; Fold over list elements, associating to the left.
(define fold
(lambda (lst folder state)
; (assert (list? lst)
; lst)
; (assert (procedure? folder)
; folder)
(do ((lst lst
(cdr lst))
(state state
(folder (car lst)
state)))
((null? lst)
state))))
; Given the size of a vector and a procedure which
; sends indicies to desired vector elements, create
; and return the vector.
(define proc->vector
(lambda (size f)
; (assert (and (integer? size)
; (exact? size)
; (>= size 0))
; size)
; (assert (procedure? f)
; f)
(if (zero? size)
(vector)
(let ((x (make-vector size (f 0))))
(let loop ((i 1))
(if (< i size)
(begin
(vector-set! x i (f i))
(loop (+ i 1)))))
x))))
(define vector-fold
(lambda (vec folder state)
; (assert (vector? vec)
; vec)
; (assert (procedure? folder)
; folder)
(let ((len
(vector-length vec)))
(do ((i 0
(+ i 1))
(state state
(folder (vector-ref vec i)
state)))
((= i len)
state)))))
(define vector-map
(lambda (vec proc)
(proc->vector (vector-length vec)
(lambda (i)
(proc (vector-ref vec i))))))
; Given limit, return the list 0, 1, ..., limit-1.
(define giota
(lambda (limit)
; (assert (and (integer? limit)
; (exact? limit)
; (>= limit 0))
; limit)
(let _-*-
((limit
limit)
(res
'()))
(if (zero? limit)
res
(let ((limit
(- limit 1)))
(_-*- limit
(cons limit res)))))))
; Fold over the integers [0, limit).
(define gnatural-fold
(lambda (limit folder state)
; (assert (and (integer? limit)
; (exact? limit)
; (>= limit 0))
; limit)
; (assert (procedure? folder)
; folder)
(do ((i 0
(+ i 1))
(state state
(folder i state)))
((= i limit)
state))))
; Iterate over the integers [0, limit).
(define gnatural-for-each
(lambda (limit proc!)
; (assert (and (integer? limit)
; (exact? limit)
; (>= limit 0))
; limit)
; (assert (procedure? proc!)
; proc!)
(do ((i 0
(+ i 1)))
((= i limit))
(proc! i))))
(define natural-for-all?
(lambda (limit ok?)
; (assert (and (integer? limit)
; (exact? limit)
; (>= limit 0))
; limit)
; (assert (procedure? ok?)
; ok?)
(let _-*-
((i 0))
(or (= i limit)
(and (ok? i)
(_-*- (+ i 1)))))))
(define natural-there-exists?
(lambda (limit ok?)
; (assert (and (integer? limit)
; (exact? limit)
; (>= limit 0))
; limit)
; (assert (procedure? ok?)
; ok?)
(let _-*-
((i 0))
(and (not (= i limit))
(or (ok? i)
(_-*- (+ i 1)))))))
(define there-exists?
(lambda (lst ok?)
; (assert (list? lst)
; lst)
; (assert (procedure? ok?)
; ok?)
(let _-*-
((lst lst))
(and (not (null? lst))
(or (ok? (car lst))
(_-*- (cdr lst)))))))
;;; ==== ptfold.ss ====
; Fold over the tree of permutations of a universe.
; Each branch (from the root) is a permutation of universe.
; Each node at depth d corresponds to all permutations which pick the
; elements spelled out on the branch from the root to that node as
; the first d elements.
; Their are two components to the state:
; The b-state is only a function of the branch from the root.
; The t-state is a function of all nodes seen so far.
; At each node, b-folder is called via
; (b-folder elem b-state t-state deeper accross)
; where elem is the next element of the universe picked.
; If b-folder can determine the result of the total tree fold at this stage,
; it should simply return the result.
; If b-folder can determine the result of folding over the sub-tree
; rooted at the resulting node, it should call accross via
; (accross new-t-state)
; where new-t-state is that result.
; Otherwise, b-folder should call deeper via
; (deeper new-b-state new-t-state)
; where new-b-state is the b-state for the new node and new-t-state is
; the new folded t-state.
; At the leaves of the tree, t-folder is called via
; (t-folder b-state t-state accross)
; If t-folder can determine the result of the total tree fold at this stage,
; it should simply return that result.
; If not, it should call accross via
; (accross new-t-state)
; Note, fold-over-perm-tree always calls b-folder in depth-first order.
; I.e., when b-folder is called at depth d, the branch leading to that
; node is the most recent calls to b-folder at all the depths less than d.
; This is a gross efficiency hack so that b-folder can use mutation to
; keep the current branch.
(define fold-over-perm-tree
(lambda (universe b-folder b-state t-folder t-state)
; (assert (list? universe)
; universe)
; (assert (procedure? b-folder)
; b-folder)
; (assert (procedure? t-folder)
; t-folder)
(let _-*-
((universe
universe)
(b-state
b-state)
(t-state
t-state)
(accross
(lambda (final-t-state)
final-t-state)))
(if (null? universe)
(t-folder b-state t-state accross)
(let _-**-
((in
universe)
(out
'())
(t-state
t-state))
(let* ((first
(car in))
(rest
(cdr in))
(accross
(if (null? rest)
accross
(lambda (new-t-state)
(_-**- rest
(cons first out)
new-t-state)))))
(b-folder first
b-state
t-state
(lambda (new-b-state new-t-state)
(_-*- (fold out cons rest)
new-b-state
new-t-state
accross))
accross)))))))
;;; ==== minimal.ss ====
; A directed graph is stored as a connection matrix (vector-of-vectors)
; where the first index is the `from' vertex and the second is the `to'
; vertex. Each entry is a bool indicating if the edge exists.
; The diagonal of the matrix is never examined.
; Make-minimal? returns a procedure which tests if a labelling
; of the verticies is such that the matrix is minimal.
; If it is, then the procedure returns the result of folding over
; the elements of the automoriphism group. If not, it returns #f.
; The folding is done by calling folder via
; (folder perm state accross)
; If the folder wants to continue, it should call accross via
; (accross new-state)
; If it just wants the entire minimal? procedure to return something,
; it should return that.
; The ordering used is lexicographic (with #t > #f) and entries
; are examined in the following order:
; 1->0, 0->1
;
; 2->0, 0->2
; 2->1, 1->2
;
; 3->0, 0->3
; 3->1, 1->3
; 3->2, 2->3
; ...
(define make-minimal?
(lambda (max-size)
; (assert (and (integer? max-size)
; (exact? max-size)
; (>= max-size 0))
; max-size)
(let ((iotas
(proc->vector (+ max-size 1)
giota))
(perm
(make-vector max-size 0)))
(lambda (size graph folder state)
; (assert (and (integer? size)
; (exact? size)
; (<= 0 size max-size))
; size
; max-size)
; (assert (vector? graph)
; graph)
; (assert (procedure? folder)
; folder)
(fold-over-perm-tree (vector-ref iotas size)
(lambda (perm-x x state deeper accross)
(case (cmp-next-vertex graph perm x perm-x)
((less)
#f)
((equal)
(vector-set! perm x perm-x)
(deeper (+ x 1)
state))
((more)
(accross state))
(else
; (assert #f)
(fatal-error "???"))))
0
(lambda (leaf-depth state accross)
; (assert (eqv? leaf-depth size)
; leaf-depth
; size)
(folder perm state accross))
state)))))
; Given a graph, a partial permutation vector, the next input and the next
; output, return 'less, 'equal or 'more depending on the lexicographic
; comparison between the permuted and un-permuted graph.
(define cmp-next-vertex
(lambda (graph perm x perm-x)
(let ((from-x
(vector-ref graph x))
(from-perm-x
(vector-ref graph perm-x)))
(let _-*-
((y
0))
(if (= x y)
'equal
(let ((x->y?
(vector-ref from-x y))
(perm-y
(vector-ref perm y)))
(cond ((eq? x->y?
(vector-ref from-perm-x perm-y))
(let ((y->x?
(vector-ref (vector-ref graph y)
x)))
(cond ((eq? y->x?
(vector-ref (vector-ref graph perm-y)
perm-x))
(_-*- (+ y 1)))
(y->x?
'less)
(else
'more))))
(x->y?
'less)
(else
'more))))))))
;;; ==== rdg.ss ====
; Fold over rooted directed graphs with bounded out-degree.
; Size is the number of verticies (including the root). Max-out is the
; maximum out-degree for any vertex. Folder is called via
; (folder edges state)
; where edges is a list of length size. The ith element of the list is
; a list of the verticies j for which there is an edge from i to j.
; The last vertex is the root.
(define fold-over-rdg
(lambda (size max-out folder state)
; (assert (and (exact? size)
; (integer? size)
; (> size 0))
; size)
; (assert (and (exact? max-out)
; (integer? max-out)
; (>= max-out 0))
; max-out)
; (assert (procedure? folder)
; folder)
(let* ((root
(- size 1))
(edge?
(proc->vector size
(lambda (from)
(make-vector size #f))))
(edges
(make-vector size '()))
(out-degrees
(make-vector size 0))
(minimal-folder
(make-minimal? root))
(non-root-minimal?
(let ((cont
(lambda (perm state accross)
; (assert (eq? state #t)
; state)
(accross #t))))
(lambda (size)
(minimal-folder size
edge?
cont
#t))))
(root-minimal?
(let ((cont
(lambda (perm state accross)
; (assert (eq? state #t)
; state)
(case (cmp-next-vertex edge? perm root root)
((less)
#f)
((equal more)
(accross #t))
(else
; (assert #f)
(fatal-error "???"))))))
(lambda ()
(minimal-folder root
edge?
cont
#t)))))
(let _-*-
((vertex
0)
(state
state))
(cond ((not (non-root-minimal? vertex))
state)
((= vertex root)
; (assert
; (begin
; (gnatural-for-each root
; (lambda (v)
; (assert (= (vector-ref out-degrees v)
; (length (vector-ref edges v)))
; v
; (vector-ref out-degrees v)
; (vector-ref edges v))))
; #t))
(let ((reach?
(make-reach? root edges))
(from-root
(vector-ref edge? root)))
(let _-*-
((v
0)
(outs
0)
(efr
'())
(efrr
'())
(state
state))
(cond ((not (or (= v root)
(= outs max-out)))
(vector-set! from-root v #t)
(let ((state
(_-*- (+ v 1)
(+ outs 1)
(cons v efr)
(cons (vector-ref reach? v)
efrr)
state)))
(vector-set! from-root v #f)
(_-*- (+ v 1)
outs
efr
efrr
state)))
((and (natural-for-all? root
(lambda (v)
(there-exists? efrr
(lambda (r)
(vector-ref r v)))))
(root-minimal?))
(vector-set! edges root efr)
(folder
(proc->vector size
(lambda (i)
(vector-ref edges i)))
state))
(else
state)))))
(else
(let ((from-vertex
(vector-ref edge? vertex)))
(let _-**-
((sv
0)
(outs
0)
(state
state))
(if (= sv vertex)
(begin
(vector-set! out-degrees vertex outs)
(_-*- (+ vertex 1)
state))
(let* ((state
; no sv->vertex, no vertex->sv
(_-**- (+ sv 1)
outs
state))
(from-sv
(vector-ref edge? sv))
(sv-out
(vector-ref out-degrees sv))
(state
(if (= sv-out max-out)
state
(begin
(vector-set! edges
sv
(cons vertex
(vector-ref edges sv)))
(vector-set! from-sv vertex #t)
(vector-set! out-degrees sv (+ sv-out 1))
(let* ((state
; sv->vertex, no vertex->sv
(_-**- (+ sv 1)
outs
state))
(state
(if (= outs max-out)
state
(begin
(vector-set! from-vertex sv #t)
(vector-set! edges
vertex
(cons sv
(vector-ref edges vertex)))
(let ((state
; sv->vertex, vertex->sv
(_-**- (+ sv 1)
(+ outs 1)
state)))
(vector-set! edges
vertex
(cdr (vector-ref edges vertex)))
(vector-set! from-vertex sv #f)
state)))))
(vector-set! out-degrees sv sv-out)
(vector-set! from-sv vertex #f)
(vector-set! edges
sv
(cdr (vector-ref edges sv)))
state)))))
(if (= outs max-out)
state
(begin
(vector-set! edges
vertex
(cons sv
(vector-ref edges vertex)))
(vector-set! from-vertex sv #t)
(let ((state
; no sv->vertex, vertex->sv
(_-**- (+ sv 1)
(+ outs 1)
state)))
(vector-set! from-vertex sv #f)
(vector-set! edges
vertex
(cdr (vector-ref edges vertex)))
state)))))))))))))
; Given a vector which maps vertex to out-going-edge list,
; return a vector which gives reachability.
(define make-reach?
(lambda (size vertex->out)
(let ((res
(proc->vector size
(lambda (v)
(let ((from-v
(make-vector size #f)))
(vector-set! from-v v #t)
(for-each
(lambda (x)
(vector-set! from-v x #t))
(vector-ref vertex->out v))
from-v)))))
(gnatural-for-each size
(lambda (m)
(let ((from-m
(vector-ref res m)))
(gnatural-for-each size
(lambda (f)
(let ((from-f
(vector-ref res f)))
(if (vector-ref from-f m)
(gnatural-for-each size
(lambda (t)
(if (vector-ref from-m t)
(vector-set! from-f t #t)))))))))))
res)))
;;; ==== test input ====
; Produces all directed graphs with N verticies, distinguished root,
; and out-degree bounded by 2, upto isomorphism.
(define (run n)
(fold-over-rdg n
2
cons
'()))
(define (main)
(run-benchmark
"graphs"
graphs-iters
(lambda (result) (equal? (length result) 596))
(lambda (n) (lambda () (run n)))
5)))

224
benchmarks/new/r6rs-benchmarks/lattice.ss Normal file
View File

@ -0,0 +1,224 @@
;;; LATTICE -- Obtained from Andrew Wright.
(library (r6rs-benchmarks lattice)
(export main)
(import (r6rs) (r6rs mutable-pairs) (r6rs-benchmarks))
; Given a comparison routine that returns one of
; less
; more
; equal
; uncomparable
; return a new comparison routine that applies to sequences.
(define lexico
(lambda (base)
(define lex-fixed
(lambda (fixed lhs rhs)
(define check
(lambda (lhs rhs)
(if (null? lhs)
fixed
(let ((probe
(base (car lhs)
(car rhs))))
(if (or (eq? probe 'equal)
(eq? probe fixed))
(check (cdr lhs)
(cdr rhs))
'uncomparable)))))
(check lhs rhs)))
(define lex-first
(lambda (lhs rhs)
(if (null? lhs)
'equal
(let ((probe
(base (car lhs)
(car rhs))))
(case probe
((less more)
(lex-fixed probe
(cdr lhs)
(cdr rhs)))
((equal)
(lex-first (cdr lhs)
(cdr rhs)))
((uncomparable)
'uncomparable))))))
lex-first))
(define (make-lattice elem-list cmp-func)
(cons elem-list cmp-func))
(define lattice->elements car)
(define lattice->cmp cdr)
; Select elements of a list which pass some test.
(define zulu-select
(lambda (test lst)
(define select-a
(lambda (ac lst)
(if (null? lst)
(reverse! ac)
(select-a
(let ((head (car lst)))
(if (test head)
(cons head ac)
ac))
(cdr lst)))))
(select-a '() lst)))
(define reverse!
(letrec ((rotate
(lambda (fo fum)
(let ((next (cdr fo)))
(set-cdr! fo fum)
(if (null? next)
fo
(rotate next fo))))))
(lambda (lst)
(if (null? lst)
'()
(rotate lst '())))))
; Select elements of a list which pass some test and map a function
; over the result. Note, only efficiency prevents this from being the
; composition of select and map.
(define select-map
(lambda (test func lst)
(define select-a
(lambda (ac lst)
(if (null? lst)
(reverse! ac)
(select-a
(let ((head (car lst)))
(if (test head)
(cons (func head)
ac)
ac))
(cdr lst)))))
(select-a '() lst)))
; This version of map-and tail-recurses on the last test.
(define map-and
(lambda (proc lst)
(if (null? lst)
#t
(letrec ((drudge
(lambda (lst)
(let ((rest (cdr lst)))
(if (null? rest)
(proc (car lst))
(and (proc (car lst))
(drudge rest)))))))
(drudge lst)))))
(define (maps-1 source target pas new)
(let ((scmp (lattice->cmp source))
(tcmp (lattice->cmp target)))
(let ((less
(select-map
(lambda (p)
(eq? 'less
(scmp (car p) new)))
cdr
pas))
(more
(select-map
(lambda (p)
(eq? 'more
(scmp (car p) new)))
cdr
pas)))
(zulu-select
(lambda (t)
(and
(map-and
(lambda (t2)
(memq (tcmp t2 t) '(less equal)))
less)
(map-and
(lambda (t2)
(memq (tcmp t2 t) '(more equal)))
more)))
(lattice->elements target)))))
(define (maps-rest source target pas rest to-1 to-collect)
(if (null? rest)
(to-1 pas)
(let ((next (car rest))
(rest (cdr rest)))
(to-collect
(map
(lambda (x)
(maps-rest source target
(cons
(cons next x)
pas)
rest
to-1
to-collect))
(maps-1 source target pas next))))))
(define (maps source target)
(make-lattice
(maps-rest source
target
'()
(lattice->elements source)
(lambda (x) (list (map cdr x)))
(lambda (x) (apply append x)))
(lexico (lattice->cmp target))))
(define (count-maps source target)
(maps-rest source
target
'()
(lattice->elements source)
(lambda (x) 1)
sum))
(define (sum lst)
(if (null? lst)
0
(+ (car lst) (sum (cdr lst)))))
(define (run)
(let* ((l2
(make-lattice '(low high)
(lambda (lhs rhs)
(case lhs
((low)
(case rhs
((low)
'equal)
((high)
'less)
(else
(fatal-error 'make-lattice "base" rhs))))
((high)
(case rhs
((low)
'more)
((high)
'equal)
(else
(fatal-error 'make-lattice "base" rhs))))
(else
(fatal-error 'make-lattice "base" lhs))))))
(l3 (maps l2 l2))
(l4 (maps l3 l3)))
(count-maps l2 l2)
(count-maps l3 l3)
(count-maps l2 l3)
(count-maps l3 l2)
(count-maps l4 l4)))
(define (main)
(run-benchmark
"lattice"
lattice-iters
(lambda (result) (equal? result 120549))
(lambda () (lambda () (run))))))

769
benchmarks/new/r6rs-benchmarks/matrix.ss Normal file
View File

@ -0,0 +1,769 @@
;;; MATRIX -- Obtained from Andrew Wright.
(library (r6rs-benchmarks matrix)
(export main)
(import (r6rs) (r6rs mutable-pairs) (r6rs-benchmarks))
; Chez-Scheme compatibility stuff:
(define (chez-box x) (cons x '()))
(define (chez-unbox x) (car x))
(define (chez-set-box! x y) (set-car! x y))
; Test that a matrix with entries in {+1, -1} is maximal among the matricies
; obtainable by
; re-ordering the rows
; re-ordering the columns
; negating any subset of the columns
; negating any subset of the rows
; Where we compare two matricies by lexicographically comparing the first row,
; then the next to last, etc., and we compare a row by lexicographically
; comparing the first entry, the second entry, etc., and we compare two
; entries by +1 > -1.
; Note, this scheme obeys the useful fact that if (append mat1 mat2) is
; maximal, then so is mat1. Thus, we can build up maximal matricies
; row by row.
;
; Once you have chosen the row re-ordering so that you know which row goes
; last, the set of columns to negate is fixed (since the last row must be
; all +1's).
;
; Note, the column ordering is really totally determined as follows:
; all columns for which the second row is +1 must come before all
; columns for which the second row is -1.
; among columns for which the second row is +1, all columns for which
; the third row is +1 come before those for which the third is
; -1, and similarly for columns in which the second row is -1.
; etc
; Thus, each succeeding row sorts columns withing refinings equivalence
; classes.
;
; Maximal? assumes that mat has atleast one row, and that the first row
; is all +1's.
(define maximal?
(lambda (mat)
(let pick-first-row
((first-row-perm
(gen-perms mat)))
(if first-row-perm
(and (zunda first-row-perm mat)
(pick-first-row (first-row-perm 'brother)))
#t))))
(define zunda
(lambda (first-row-perm mat)
(let* ((first-row
(first-row-perm 'now))
(number-of-cols
(length first-row))
(make-row->func
(lambda (if-equal if-different)
(lambda (row)
(let ((vec
(make-vector number-of-cols)))
(do ((i 0 (+ i 1))
(first first-row
(cdr first))
(row row
(cdr row)))
((= i number-of-cols))
(vector-set! vec
i
(if (= (car first) (car row))
if-equal
if-different)))
(lambda (i)
(vector-ref vec i))))))
(mat
(cdr mat)))
(zebra (first-row-perm 'child)
(make-row->func 1 -1)
(make-row->func -1 1)
mat
number-of-cols))))
(define zebra
(lambda (row-perm row->func+ row->func- mat number-of-cols)
(let _-*-
((row-perm
row-perm)
(mat
mat)
(partitions
(list (miota number-of-cols))))
(or (not row-perm)
(and
(zulu (car mat)
(row->func+ (row-perm 'now))
partitions
(lambda (new-partitions)
(_-*- (row-perm 'child)
(cdr mat)
new-partitions)))
(zulu (car mat)
(row->func- (row-perm 'now))
partitions
(lambda (new-partitions)
(_-*- (row-perm 'child)
(cdr mat)
new-partitions)))
(let ((new-row-perm
(row-perm 'brother)))
(or (not new-row-perm)
(_-*- new-row-perm
mat
partitions))))))))
(define zulu
(let ((cons-if-not-null
(lambda (lhs rhs)
(if (null? lhs)
rhs
(cons lhs rhs)))))
(lambda (old-row new-row-func partitions equal-cont)
(let _-*-
((p-in
partitions)
(old-row
old-row)
(rev-p-out
'()))
(let _-split-
((partition
(car p-in))
(old-row
old-row)
(plus
'())
(minus
'()))
(if (null? partition)
(let _-minus-
((old-row
old-row)
(m
minus))
(if (null? m)
(let ((rev-p-out
(cons-if-not-null
minus
(cons-if-not-null
plus
rev-p-out)))
(p-in
(cdr p-in)))
(if (null? p-in)
(equal-cont (reverse rev-p-out))
(_-*- p-in old-row rev-p-out)))
(or (= 1 (car old-row))
(_-minus- (cdr old-row)
(cdr m)))))
(let ((next
(car partition)))
(case (new-row-func next)
((1)
(and (= 1 (car old-row))
(_-split- (cdr partition)
(cdr old-row)
(cons next plus)
minus)))
((-1)
(_-split- (cdr partition)
old-row
plus
(cons next minus)))))))))))
(define all?
(lambda (ok? lst)
(let _-*-
((lst
lst))
(or (null? lst)
(and (ok? (car lst))
(_-*- (cdr lst)))))))
(define gen-perms
(lambda (objects)
(let _-*-
((zulu-future
objects)
(past
'()))
(if (null? zulu-future)
#f
(lambda (msg)
(case msg
((now)
(car zulu-future))
((brother)
(_-*- (cdr zulu-future)
(cons (car zulu-future)
past)))
((child)
(gen-perms
(fold past cons (cdr zulu-future))))
((puke)
(cons (car zulu-future)
(fold past cons (cdr zulu-future))))
(else
(fatal-error 'gen-perms "Bad msg: ~a" msg))))))))
(define fold
(lambda (lst folder state)
(let _-*-
((lst
lst)
(state
state))
(if (null? lst)
state
(_-*- (cdr lst)
(folder (car lst)
state))))))
(define miota
(lambda (len)
(let _-*-
((i 0))
(if (= i len)
'()
(cons i
(_-*- (+ i 1)))))))
(define proc->vector
(lambda (size proc)
(let ((res
(make-vector size)))
(do ((i 0
(+ i 1)))
((= i size))
(vector-set! res
i
(proc i)))
res)))
; Given a prime number P, return a procedure which, given a `maker' procedure,
; calls it on the operations for the field Z/PZ.
(define make-modular
(lambda (modulus)
(let* ((reduce
(lambda (x)
(modulo x modulus)))
(coef-zero?
(lambda (x)
(zero? (reduce x))))
(coef-+
(lambda (x y)
(reduce (+ x y))))
(coef-negate
(lambda (x)
(reduce (- x))))
(coef-*
(lambda (x y)
(reduce (* x y))))
(coef-recip
(let ((inverses
(proc->vector (- modulus 1)
(lambda (i)
(extended-gcd (+ i 1)
modulus
(lambda (gcd inverse ignore)
inverse))))))
; Coef-recip.
(lambda (x)
(let ((x
(reduce x)))
(vector-ref inverses (- x 1)))))))
(lambda (maker)
(maker 0 ; coef-zero
1 ; coef-one
coef-zero?
coef-+
coef-negate
coef-*
coef-recip)))))
; Extended Euclidean algorithm.
; (extended-gcd a b cont) computes the gcd of a and b, and expresses it
; as a linear combination of a and b. It returns calling cont via
; (cont gcd a-coef b-coef)
; where gcd is the GCD and is equal to a-coef * a + b-coef * b.
(define extended-gcd
(let ((n->sgn/abs
(lambda (x cont)
(if (>= x 0)
(cont 1 x)
(cons -1 (- x))))))
(lambda (a b cont)
(n->sgn/abs a
(lambda (p-a p)
(n->sgn/abs b
(lambda (q-b q)
(let _-*-
((p
p)
(p-a
p-a)
(p-b
0)
(q
q)
(q-a
0)
(q-b
q-b))
(if (zero? q)
(cont p p-a p-b)
(let ((mult
(quotient p q)))
(_-*- q
q-a
q-b
(- p (* mult q))
(- p-a (* mult q-a))
(- p-b (* mult q-b)))))))))))))
; Given elements and operations on the base field, return a procedure which
; computes the row-reduced version of a matrix over that field. The result
; is a list of rows where the first non-zero entry in each row is a 1 (in
; the coefficient field) and occurs to the right of all the leading non-zero
; entries of previous rows. In particular, the number of rows is the rank
; of the original matrix, and they have the same row-space.
; The items related to the base field which are needed are:
; coef-zero additive identity
; coef-one multiplicative identity
; coef-zero? test for additive identity
; coef-+ addition (two args)
; coef-negate additive inverse
; coef-* multiplication (two args)
; coef-recip multiplicative inverse
; Note, matricies are stored as lists of rows (i.e., lists of lists).
(define make-row-reduce
(lambda (coef-zero coef-one coef-zero? coef-+ coef-negate coef-* coef-recip)
(lambda (mat)
(let _-*-
((mat
mat))
(if (or (null? mat)
(null? (car mat)))
'()
(let _-**-
((in
mat)
(out
'()))
(if (null? in)
(map
(lambda (x)
(cons coef-zero x))
(_-*- out))
(let* ((prow
(car in))
(pivot
(car prow))
(prest
(cdr prow))
(in
(cdr in)))
(if (coef-zero? pivot)
(_-**- in
(cons prest out))
(let ((zap-row
(map
(let ((mult
(coef-recip pivot)))
(lambda (x)
(coef-* mult x)))
prest)))
(cons (cons coef-one zap-row)
(map
(lambda (x)
(cons coef-zero x))
(_-*-
(fold in
(lambda (row mat)
(cons
(let ((first-col
(car row))
(rest-row
(cdr row)))
(if (coef-zero? first-col)
rest-row
(map
(let ((mult
(coef-negate first-col)))
(lambda (f z)
(coef-+ f
(coef-* mult z))))
rest-row
zap-row)))
mat))
out))))))))))))))
; Given elements and operations on the base field, return a procedure which
; when given a matrix and a vector tests to see if the vector is in the
; row-space of the matrix. This returned function is curried.
; The items related to the base field which are needed are:
; coef-zero additive identity
; coef-one multiplicative identity
; coef-zero? test for additive identity
; coef-+ addition (two args)
; coef-negate additive inverse
; coef-* multiplication (two args)
; coef-recip multiplicative inverse
; Note, matricies are stored as lists of rows (i.e., lists of lists).
(define make-in-row-space?
(lambda (coef-zero coef-one coef-zero? coef-+ coef-negate coef-* coef-recip)
(let ((row-reduce
(make-row-reduce coef-zero
coef-one
coef-zero?
coef-+
coef-negate
coef-*
coef-recip)))
(lambda (mat)
(let ((mat
(row-reduce mat)))
(lambda (row)
(let _-*-
((row
row)
(mat
mat))
(if (null? row)
#t
(let ((r-first
(car row))
(r-rest
(cdr row)))
(cond ((coef-zero? r-first)
(_-*- r-rest
(map cdr
(if (or (null? mat)
(coef-zero? (caar mat)))
mat
(cdr mat)))))
((null? mat)
#f)
(else
(let* ((zap-row
(car mat))
(z-first
(car zap-row))
(z-rest
(cdr zap-row))
(mat
(cdr mat)))
(if (coef-zero? z-first)
#f
(_-*-
(map
(let ((mult
(coef-negate r-first)))
(lambda (r z)
(coef-+ r
(coef-* mult z))))
r-rest
z-rest)
(map cdr mat)))))))))))))))
; Given a prime number, return a procedure which takes integer matricies
; and returns their row-reduced form, modulo the prime.
(define make-modular-row-reduce
(lambda (modulus)
((make-modular modulus)
make-row-reduce)))
(define make-modular-in-row-space?
(lambda (modulus)
((make-modular modulus)
make-in-row-space?)))
; Usual utilities.
; Given a bound, find a prime greater than the bound.
(define find-prime
(lambda (bound)
(let* ((primes
(list 2))
(last
(chez-box primes))
(is-next-prime?
(lambda (trial)
(let _-*-
((primes
primes))
(or (null? primes)
(let ((p
(car primes)))
(or (< trial (* p p))
(and (not (zero? (modulo trial p)))
(_-*- (cdr primes))))))))))
(if (> 2 bound)
2
(let _-*-
((trial
3))
(if (is-next-prime? trial)
(let ((entry
(list trial)))
(set-cdr! (chez-unbox last) entry)
(chez-set-box! last entry)
(if (> trial bound)
trial
(_-*- (+ trial 2))))
(_-*- (+ trial 2))))))))
; Given the size of a square matrix consisting only of +1's and -1's,
; return an upper bound on the determinant.
(define det-upper-bound
(lambda (size)
(let ((main-part
(expt size
(quotient size 2))))
(if (even? size)
main-part
(* main-part
(do ((i 0 (+ i 1)))
((>= (* i i) size)
i)))))))
; Fold over all maximal matrices.
(define go
(lambda (number-of-cols inv-size folder state)
(let* ((in-row-space?
(make-modular-in-row-space?
(find-prime
(det-upper-bound inv-size))))
(make-tester
(lambda (mat)
(let ((tests
(let ((old-mat
(cdr mat))
(new-row
(car mat)))
(fold-over-subs-of-size old-mat
(- inv-size 2)
(lambda (sub tests)
(cons
(in-row-space?
(cons new-row sub))
tests))
'()))))
(lambda (row)
(let _-*-
((tests
tests))
(and (not (null? tests))
(or ((car tests) row)
(_-*- (cdr tests)))))))))
(all-rows ; all rows starting with +1 in decreasing order
(fold
(fold-over-rows (- number-of-cols 1)
cons
'())
(lambda (row rows)
(cons (cons 1 row)
rows))
'())))
(let _-*-
((number-of-rows
1)
(rev-mat
(list
(car all-rows)))
(possible-future
(cdr all-rows))
(state
state))
(let ((zulu-future
(remove-in-order
(if (< number-of-rows inv-size)
(in-row-space? rev-mat)
(make-tester rev-mat))
possible-future)))
(if (null? zulu-future)
(folder (reverse rev-mat)
state)
(let _-**-
((zulu-future
zulu-future)
(state
state))
(if (null? zulu-future)
state
(let ((rest-of-future
(cdr zulu-future)))
(_-**- rest-of-future
(let* ((first
(car zulu-future))
(new-rev-mat
(cons first rev-mat)))
(if (maximal? (reverse new-rev-mat))
(_-*- (+ number-of-rows 1)
new-rev-mat
rest-of-future
state)
state))))))))))))
(define go-folder
(lambda (mat bsize.blen.blist)
(let ((bsize
(car bsize.blen.blist))
(size
(length mat)))
(if (< size bsize)
bsize.blen.blist
(let ((blen
(cadr bsize.blen.blist))
(blist
(cddr bsize.blen.blist)))
(if (= size bsize)
(let ((blen
(+ blen 1)))
; (if
; (let _-*-
; ((blen
; blen))
; (or (< blen 10)
; (and (zero? (remainder blen 10))
; (_-*- (quotient blen 10)))))
;
; (begin
; (display blen)
; (display " of size ")
; (display bsize)
; (newline)))
(cons bsize
(cons blen
(cond ((< blen 3000)
(cons mat blist))
((= blen 3000)
(cons "..." blist))
(else
blist)))))
; (begin
; (newline)
; (display "First of size ")
; (display size)
; (display ":")
; (newline)
; (for-each
; (lambda (row)
; (display " ")
; (for-each
; (lambda (e)
; (case e
; ((1)
; (display " 1"))
; ((-1)
; (display " -1"))))
; row)
; (newline))
; mat)
(list size 1 mat)))))))
(define really-go
(lambda (number-of-cols inv-size)
(cddr
(go number-of-cols
inv-size
go-folder
(list -1 -1)))))
(define remove-in-order
(lambda (remove? lst)
(reverse
(fold lst
(lambda (e lst)
(if (remove? e)
lst
(cons e lst)))
'()))))
; The first fold-over-rows is slower than the second one, but folds
; over rows in lexical order (large to small).
(define fold-over-rows
(lambda (number-of-cols folder state)
(if (zero? number-of-cols)
(folder '()
state)
(fold-over-rows (- number-of-cols 1)
(lambda (tail state)
(folder (cons -1 tail)
state))
(fold-over-rows (- number-of-cols 1)
(lambda (tail state)
(folder (cons 1 tail)
state))
state)))))
; Fold over subsets of a given size.
(define fold-over-subs-of-size
(lambda (universe size folder state)
(let ((usize
(length universe)))
(if (< usize size)
state
(let _-*-
((size
size)
(universe
universe)
(folder
folder)
(csize
(- usize size))
(state
state))
(cond ((zero? csize)
(folder universe state))
((zero? size)
(folder '() state))
(else
(let ((first-u
(car universe))
(rest-u
(cdr universe)))
(_-*- size
rest-u
folder
(- csize 1)
(_-*- (- size 1)
rest-u
(lambda (tail state)
(folder (cons first-u tail)
state))
csize
state))))))))))
(define (main)
(run-benchmark
"matrix"
matrix-iters
(lambda (result)
(equal? result
'(((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
(1 1 -1 -1 -1) (1 -1 1 -1 -1) (1 -1 -1 1 1))
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
(1 1 -1 1 -1) (1 -1 1 -1 -1) (1 -1 -1 1 1))
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
(1 1 -1 1 -1) (1 -1 1 -1 1) (1 -1 -1 1 1))
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
(1 1 -1 1 1) (1 -1 1 1 -1) (1 -1 -1 -1 1))
((1 1 1 1 1) (1 1 1 1 -1) (1 1 1 -1 1)
(1 1 -1 1 1) (1 -1 1 1 1) (1 -1 -1 -1 -1)))))
(lambda (number-of-cols inv-size) (lambda () (really-go number-of-cols inv-size)))
5
5)))

732
benchmarks/new/r6rs-benchmarks/maze.ss Normal file
View File

@ -0,0 +1,732 @@
;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers.
;------------------------------------------------------------------------------
; Was file "rand.scm".
; Minimal Standard Random Number Generator
; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version.
; better constants, as proposed by Park.
; By Ozan Yigit
;;; Rehacked by Olin 4/1995.
(library (r6rs-benchmarks maze)
(export main)
(import (r6rs) (r6rs mutable-pairs) (r6rs-benchmarks))
(define (random-state n)
(cons n #f))
(define (rand state)
(let ((seed (car state))
(A 2813) ; 48271
(M 8388607) ; 2147483647
(Q 2787) ; 44488
(R 2699)) ; 3399
(let* ((hi (quotient seed Q))
(lo (modulo seed Q))
(test (- (* A lo) (* R hi)))
(val (if (> test 0) test (+ test M))))
(set-car! state val)
val)))
(define (random-int n state)
(modulo (rand state) n))
; poker test
; seed 1
; cards 0-9 inclusive (random 10)
; five cards per hand
; 10000 hands
;
; Poker Hand Example Probability Calculated
; 5 of a kind (aaaaa) 0.0001 0
; 4 of a kind (aaaab) 0.0045 0.0053
; Full house (aaabb) 0.009 0.0093
; 3 of a kind (aaabc) 0.072 0.0682
; two pairs (aabbc) 0.108 0.1104
; Pair (aabcd) 0.504 0.501
; Bust (abcde) 0.3024 0.3058
; (define (random n)
; (let* ((M 2147483647)
; (slop (modulo M n)))
; (let loop ((r (rand)))
; (if (> r slop)
; (modulo r n)
; (loop (rand))))))
;
; (define (rngtest)
; (display "implementation ")
; (srand 1)
; (let loop ((n 0))
; (if (< n 10000)
; (begin
; (rand)
; (loop (1+ n)))))
; (if (= *seed* 399268537)
; (display "looks correct.")
; (begin
; (display "failed.")
; (newline)
; (display " current seed ") (display *seed*)
; (newline)
; (display " correct seed 399268537")))
; (newline))
;------------------------------------------------------------------------------
; Was file "uf.scm".
;;; Tarjan's amortised union-find data structure.
;;; Copyright (c) 1995 by Olin Shivers.
;;; This data structure implements disjoint sets of elements.
;;; Four operations are supported. The implementation is extremely
;;; fast -- any sequence of N operations can be performed in time
;;; so close to linear it's laughable how close it is. See your
;;; intro data structures book for more. The operations are:
;;;
;;; - (base-set nelts) -> set
;;; Returns a new set, of size NELTS.
;;;
;;; - (set-size s) -> integer
;;; Returns the number of elements in set S.
;;;
;;; - (union! set1 set2)
;;; Unions the two sets -- SET1 and SET2 are now considered the same set
;;; by SET-EQUAL?.
;;;
;;; - (set-equal? set1 set2)
;;; Returns true <==> the two sets are the same.
;;; Representation: a set is a cons cell. Every set has a "representative"
;;; cons cell, reached by chasing cdr links until we find the cons with
;;; cdr = (). Set equality is determined by comparing representatives using
;;; EQ?. A representative's car contains the number of elements in the set.
;;; The speed of the algorithm comes because when we chase links to find
;;; representatives, we collapse links by changing all the cells in the path
;;; we followed to point directly to the representative, so that next time
;;; we walk the cdr-chain, we'll go directly to the representative in one hop.
(define (base-set nelts) (cons nelts '()))
;;; Sets are chained together through cdr links. Last guy in the chain
;;; is the root of the set.
(define (get-set-root s)
(let lp ((r s)) ; Find the last pair
(let ((next (cdr r))) ; in the list. That's
(cond ((pair? next) (lp next)) ; the root r.
(else
(if (not (eq? r s)) ; Now zip down the list again,
(let lp ((x s)) ; changing everyone's cdr to r.
(let ((next (cdr x)))
(cond ((not (eq? r next))
(set-cdr! x r)
(lp next))))))
r))))) ; Then return r.
(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2)))
(define (set-size s) (car (get-set-root s)))
(define (union! s1 s2)
(let* ((r1 (get-set-root s1))
(r2 (get-set-root s2))
(n1 (set-size r1))
(n2 (set-size r2))
(n (+ n1 n2)))
(cond ((> n1 n2)
(set-cdr! r2 r1)
(set-car! r1 n))
(else
(set-cdr! r1 r2)
(set-car! r2 n)))))
;------------------------------------------------------------------------------
; Was file "maze.scm".
;;; Building mazes with union/find disjoint sets.
;;; Copyright (c) 1995 by Olin Shivers.
;;; This is the algorithmic core of the maze constructor.
;;; External dependencies:
;;; - RANDOM-INT
;;; - Union/find code
;;; - bitwise logical functions
; (define-record wall
; owner ; Cell that owns this wall.
; neighbor ; The other cell bordering this wall.
; bit) ; Integer -- a bit identifying this wall in OWNER's cell.
; (define-record cell
; reachable ; Union/find set -- all reachable cells.
; id ; Identifying info (e.g., the coords of the cell).
; (walls -1) ; A bitset telling which walls are still standing.
; (parent #f) ; For DFS spanning tree construction.
; (mark #f)) ; For marking the solution path.
(define (make-wall owner neighbor bit)
(vector 'wall owner neighbor bit))
(define (wall:owner o) (vector-ref o 1))
(define (set-wall:owner o v) (vector-set! o 1 v))
(define (wall:neighbor o) (vector-ref o 2))
(define (set-wall:neighbor o v) (vector-set! o 2 v))
(define (wall:bit o) (vector-ref o 3))
(define (set-wall:bit o v) (vector-set! o 3 v))
(define (make-cell reachable id)
(vector 'cell reachable id -1 #f #f))
(define (cell:reachable o) (vector-ref o 1))
(define (set-cell:reachable o v) (vector-set! o 1 v))
(define (cell:id o) (vector-ref o 2))
(define (set-cell:id o v) (vector-set! o 2 v))
(define (cell:walls o) (vector-ref o 3))
(define (set-cell:walls o v) (vector-set! o 3 v))
(define (cell:parent o) (vector-ref o 4))
(define (set-cell:parent o v) (vector-set! o 4 v))
(define (cell:mark o) (vector-ref o 5))
(define (set-cell:mark o v) (vector-set! o 5 v))
;;; Iterates in reverse order.
(define (vector-for-each proc v)
(let lp ((i (- (vector-length v) 1)))
(cond ((>= i 0)
(proc (vector-ref v i))
(lp (- i 1))))))
;;; Randomly permute a vector.
(define (permute-vec! v random-state)
(let lp ((i (- (vector-length v) 1)))
(cond ((> i 1)
(let ((elt-i (vector-ref v i))
(j (random-int i random-state))) ; j in [0,i)
(vector-set! v i (vector-ref v j))
(vector-set! v j elt-i))
(lp (- i 1)))))
v)
;;; This is the core of the algorithm.
(define (dig-maze walls ncells)
(call-with-current-continuation
(lambda (quit)
(vector-for-each
(lambda (wall) ; For each wall,
(let* ((c1 (wall:owner wall)) ; find the cells on
(set1 (cell:reachable c1))
(c2 (wall:neighbor wall)) ; each side of the wall
(set2 (cell:reachable c2)))
;; If there is no path from c1 to c2, knock down the
;; wall and union the two sets of reachable cells.
;; If the new set of reachable cells is the whole set
;; of cells, quit.
(if (not (set-equal? set1 set2))
(let ((walls (cell:walls c1))
(wall-mask (bitwise-not (wall:bit wall))))
(union! set1 set2)
(set-cell:walls c1 (bitwise-and walls wall-mask))
(if (= (set-size set1) ncells) (quit #f))))))
walls))))
;;; Some simple DFS routines useful for determining path length
;;; through the maze.
;;; Build a DFS tree from ROOT.
;;; (DO-CHILDREN proc maze node) applies PROC to each of NODE's children.
;;; We assume there are no loops in the maze; if this is incorrect, the
;;; algorithm will diverge.
(define (dfs-maze maze root do-children)
(let search ((node root) (parent #f))
(set-cell:parent node parent)
(do-children (lambda (child)
(if (not (eq? child parent))
(search child node)))
maze node)))
;;; Move the root to NEW-ROOT.
(define (reroot-maze new-root)
(let lp ((node new-root) (new-parent #f))
(let ((old-parent (cell:parent node)))
(set-cell:parent node new-parent)
(if old-parent (lp old-parent node)))))
;;; How far from CELL to the root?
(define (path-length cell)
(do ((len 0 (+ len 1))
(node (cell:parent cell) (cell:parent node)))
((not node) len)))
;;; Mark the nodes from NODE back to root. Used to mark the winning path.
(define (mark-path node)
(let lp ((node node))
(set-cell:mark node #t)
(cond ((cell:parent node) => lp))))
;------------------------------------------------------------------------------
; Was file "harr.scm".
;;; Hex arrays
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - define-record
;;; ___ ___ ___
;;; / \ / \ / \
;;; ___/ A \___/ A \___/ A \___
;;; / \ / \ / \ / \
;;; / A \___/ A \___/ A \___/ A \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; / \ / \ / \ / \
;;; / \___/ \___/ \___/ \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; / \ / \ / \ / \
;;; / \___/ \___/ \___/ \
;;; \ / \ / \ / \ /
;;; \___/ \___/ \___/ \___/
;;; Hex arrays are indexed by the (x,y) coord of the center of the hexagonal
;;; element. Hexes are three wide and two high; e.g., to get from the center
;;; of an elt to its {NW, N, NE} neighbors, add {(-3,1), (0,2), (3,1)}
;;; respectively.
;;;
;;; Hex arrays are represented with a matrix, essentially made by shoving the
;;; odd columns down a half-cell so things line up. The mapping is as follows:
;;; Center coord row/column
;;; ------------ ----------
;;; (x, y) -> (y/2, x/3)
;;; (3c, 2r + c&1) <- (r, c)
; (define-record harr
; nrows
; ncols
; elts)
(define (make-harr nrows ncols elts)
(vector 'harr nrows ncols elts))
(define (harr:nrows o) (vector-ref o 1))
(define (set-harr:nrows o v) (vector-set! o 1 v))
(define (harr:ncols o) (vector-ref o 2))
(define (set-harr:ncols o v) (vector-set! o 2 v))
(define (harr:elts o) (vector-ref o 3))
(define (set-harr:elts o v) (vector-set! o 3 v))
(define (harr r c)
(make-harr r c (make-vector (* r c))))
(define (href ha x y)
(let ((r (quotient y 2))
(c (quotient x 3)))
(vector-ref (harr:elts ha)
(+ (* (harr:ncols ha) r) c))))
(define (hset! ha x y val)
(let ((r (quotient y 2))
(c (quotient x 3)))
(vector-set! (harr:elts ha)
(+ (* (harr:ncols ha) r) c)
val)))
(define (href/rc ha r c)
(vector-ref (harr:elts ha)
(+ (* (harr:ncols ha) r) c)))
;;; Create a nrows x ncols hex array. The elt centered on coord (x, y)
;;; is the value returned by (PROC x y).
(define (harr-tabulate nrows ncols proc)
(let ((v (make-vector (* nrows ncols))))
(do ((r (- nrows 1) (- r 1)))
((< r 0))
(do ((c 0 (+ c 1))
(i (* r ncols) (+ i 1)))
((= c ncols))
(vector-set! v i (proc (* 3 c) (+ (* 2 r) (bitwise-and c 1))))))
(make-harr nrows ncols v)))
(define (harr-for-each proc harr)
(vector-for-each proc (harr:elts harr)))
;------------------------------------------------------------------------------
; Was file "hex.scm".
;;; Hexagonal hackery for maze generation.
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - cell and wall records
;;; - Functional Postscript for HEXES->PATH
;;; - logical functions for bit hacking
;;; - hex array code.
;;; To have the maze span (0,0) to (1,1):
;;; (scale (/ (+ 1 (* 3 ncols))) (/ (+ 1 (* 2 nrows)))
;;; (translate (point 2 1) maze))
;;; Every elt of the hex array manages his SW, S, and SE wall.
;;; Terminology: - An even column is one whose column index is even. That
;;; means the first, third, ... columns (indices 0, 2, ...).
;;; - An odd column is one whose column index is odd. That
;;; means the second, fourth... columns (indices 1, 3, ...).
;;; The even/odd flip-flop is confusing; be careful to keep it
;;; straight. The *even* columns are the low ones. The *odd*
;;; columns are the high ones.
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/
;;; 0 1 2 3
(define south-west 1)
(define south 2)
(define south-east 4)
(define (gen-maze-array r c)
(harr-tabulate r c (lambda (x y) (make-cell (base-set 1) (cons x y)))))
;;; This could be made more efficient.
(define (make-wall-vec harr)
(let* ((nrows (harr:nrows harr))
(ncols (harr:ncols harr))
(xmax (* 3 (- ncols 1)))
;; Accumulate walls.
(walls '())
(add-wall (lambda (o n b) ; owner neighbor bit
(set! walls (cons (make-wall o n b) walls)))))
;; Do everything but the bottom row.
(do ((x (* (- ncols 1) 3) (- x 3)))
((< x 0))
(do ((y (+ (* (- nrows 1) 2) (bitwise-and x 1))
(- y 2)))
((<= y 1)) ; Don't do bottom row.
(let ((hex (href harr x y)))
(if (not (zero? x))
(add-wall hex (href harr (- x 3) (- y 1)) south-west))
(add-wall hex (href harr x (- y 2)) south)
(if (< x xmax)
(add-wall hex (href harr (+ x 3) (- y 1)) south-east)))))
;; Do the SE and SW walls of the odd columns on the bottom row.
;; If the rightmost bottom hex lies in an odd column, however,
;; don't add it's SE wall -- it's a corner hex, and has no SE neighbor.
(if (> ncols 1)
(let ((rmoc-x (+ 3 (* 6 (quotient (- ncols 2) 2)))))
;; Do rightmost odd col.
(let ((rmoc-hex (href harr rmoc-x 1)))
(if (< rmoc-x xmax) ; Not a corner -- do E wall.
(add-wall rmoc-hex (href harr xmax 0) south-east))
(add-wall rmoc-hex (href harr (- rmoc-x 3) 0) south-west))
(do ((x (- rmoc-x 6) ; Do the rest of the bottom row's odd cols.
(- x 6)))
((< x 3)) ; 3 is X coord of leftmost odd column.
(add-wall (href harr x 1) (href harr (- x 3) 0) south-west)
(add-wall (href harr x 1) (href harr (+ x 3) 0) south-east))))
(list->vector walls)))
;;; Find the cell ctop from the top row, and the cell cbot from the bottom
;;; row such that cbot is furthest from ctop.
;;; Return [ctop-x, ctop-y, cbot-x, cbot-y].
(define (pick-entrances harr)
(dfs-maze harr (href/rc harr 0 0) for-each-hex-child)
(let ((nrows (harr:nrows harr))
(ncols (harr:ncols harr)))
(let tp-lp ((max-len -1)
(entrance #f)
(exit #f)
(tcol (- ncols 1)))
(if (< tcol 0) (vector entrance exit)
(let ((top-cell (href/rc harr (- nrows 1) tcol)))
(reroot-maze top-cell)
(let ((result
(let bt-lp ((max-len max-len)
(entrance entrance)
(exit exit)
(bcol (- ncols 1)))
; (format #t "~a ~a ~a ~a~%" max-len entrance exit bcol)
(if (< bcol 0) (vector max-len entrance exit)
(let ((this-len (path-length (href/rc harr 0 bcol))))
(if (> this-len max-len)
(bt-lp this-len tcol bcol (- bcol 1))
(bt-lp max-len entrance exit (- bcol 1))))))))
(let ((max-len (vector-ref result 0))
(entrance (vector-ref result 1))
(exit (vector-ref result 2)))
(tp-lp max-len entrance exit (- tcol 1)))))))))
;;; Apply PROC to each node reachable from CELL.
(define (for-each-hex-child proc harr cell)
(let* ((walls (cell:walls cell))
(id (cell:id cell))
(x (car id))
(y (cdr id))
(nr (harr:nrows harr))
(nc (harr:ncols harr))
(maxy (* 2 (- nr 1)))
(maxx (* 3 (- nc 1))))
(if (not (bit-test walls south-west)) (proc (href harr (- x 3) (- y 1))))
(if (not (bit-test walls south)) (proc (href harr x (- y 2))))
(if (not (bit-test walls south-east)) (proc (href harr (+ x 3) (- y 1))))
;; NW neighbor, if there is one (we may be in col 1, or top row/odd col)
(if (and (> x 0) ; Not in first column.
(or (<= y maxy) ; Not on top row or
(zero? (modulo x 6)))) ; not in an odd column.
(let ((nw (href harr (- x 3) (+ y 1))))
(if (not (bit-test (cell:walls nw) south-east)) (proc nw))))
;; N neighbor, if there is one (we may be on top row).
(if (< y maxy) ; Not on top row
(let ((n (href harr x (+ y 2))))
(if (not (bit-test (cell:walls n) south)) (proc n))))
;; NE neighbor, if there is one (we may be in last col, or top row/odd col)
(if (and (< x maxx) ; Not in last column.
(or (<= y maxy) ; Not on top row or
(zero? (modulo x 6)))) ; not in an odd column.
(let ((ne (href harr (+ x 3) (+ y 1))))
(if (not (bit-test (cell:walls ne) south-west)) (proc ne))))))
;;; The top-level
(define (make-maze nrows ncols)
(let* ((cells (gen-maze-array nrows ncols))
(walls (permute-vec! (make-wall-vec cells) (random-state 20))))
(dig-maze walls (* nrows ncols))
(let ((result (pick-entrances cells)))
(let ((entrance (vector-ref result 0))
(exit (vector-ref result 1)))
(let* ((exit-cell (href/rc cells 0 exit))
(walls (cell:walls exit-cell)))
(reroot-maze (href/rc cells (- nrows 1) entrance))
(mark-path exit-cell)
(set-cell:walls exit-cell (bitwise-and walls (bitwise-not south)))
(vector cells entrance exit))))))
(define (pmaze nrows ncols)
(let ((result (make-maze nrows ncols)))
(let ((cells (vector-ref result 0))
(entrance (vector-ref result 1))
(exit (vector-ref result 2)))
(print-hexmaze cells entrance))))
;------------------------------------------------------------------------------
; Was file "hexprint.scm".
;;; Print out a hex array with characters.
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies:
;;; - hex array code
;;; - hex cell code
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/
;;; Top part of top row looks like this:
;;; _ _ _ _
;;; _/ \_/ \/ \_/ \
;;; /
(define output #f) ; the list of all characters written out, in reverse order.
(define (write-ch c)
(set! output (cons c output)))
(define (print-hexmaze harr entrance)
(let* ((nrows (harr:nrows harr))
(ncols (harr:ncols harr))
(ncols2 (* 2 (quotient ncols 2))))
;; Print out the flat tops for the top row's odd cols.
(do ((c 1 (+ c 2)))
((>= c ncols))
; (display " ")
(write-ch #\space)
(write-ch #\space)
(write-ch #\space)
(write-ch (if (= c entrance) #\space #\_)))
; (newline)
(write-ch #\newline)
;; Print out the slanted tops for the top row's odd cols
;; and the flat tops for the top row's even cols.
(write-ch #\space)
(do ((c 0 (+ c 2)))
((>= c ncols2))
; (format #t "~a/~a\\"
; (if (= c entrance) #\space #\_)
; (dot/space harr (- nrows 1) (+ c 1)))
(write-ch (if (= c entrance) #\space #\_))
(write-ch #\/)
(write-ch (dot/space harr (- nrows 1) (+ c 1)))
(write-ch #\\))
(if (odd? ncols)
(write-ch (if (= entrance (- ncols 1)) #\space #\_)))
; (newline)
(write-ch #\newline)
(do ((r (- nrows 1) (- r 1)))
((< r 0))
;; Do the bottoms for row r's odd cols.
(write-ch #\/)
(do ((c 1 (+ c 2)))
((>= c ncols2))
;; The dot/space for the even col just behind c.
(write-ch (dot/space harr r (- c 1)))
(display-hexbottom (cell:walls (href/rc harr r c))))
(cond ((odd? ncols)
(write-ch (dot/space harr r (- ncols 1)))
(write-ch #\\)))
; (newline)
(write-ch #\newline)
;; Do the bottoms for row r's even cols.
(do ((c 0 (+ c 2)))
((>= c ncols2))
(display-hexbottom (cell:walls (href/rc harr r c)))
;; The dot/space is for the odd col just after c, on row below.
(write-ch (dot/space harr (- r 1) (+ c 1))))
(cond ((odd? ncols)
(display-hexbottom (cell:walls (href/rc harr r (- ncols 1)))))
((not (zero? r)) (write-ch #\\)))
; (newline)
(write-ch #\newline))))
(define (bit-test j bit)
(not (zero? (bitwise-and j bit))))
;;; Return a . if harr[r,c] is marked, otherwise a space.
;;; We use the dot to mark the solution path.
(define (dot/space harr r c)
(if (and (>= r 0) (cell:mark (href/rc harr r c))) #\. #\space))
;;; Print a \_/ hex bottom.
(define (display-hexbottom hexwalls)
(write-ch (if (bit-test hexwalls south-west) #\\ #\space))
(write-ch (if (bit-test hexwalls south ) #\_ #\space))
(write-ch (if (bit-test hexwalls south-east) #\/ #\space)))
;;; _ _
;;; _/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \
;;; / \_/ \_/
;;; \_/ \_/ \_/
;------------------------------------------------------------------------------
(define (run nrows ncols)
(set! output '())
(pmaze nrows ncols)
(reverse output))
(define (main . args)
(run-benchmark
"maze"
maze-iters
(lambda (result)
(equal? result '
(#\ #\ #\ #\_ #\ #\ #\ #\_ #\ #\ #\ #\_ #\newline
#\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\newline
#\/ #\ #\\ #\ #\ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\newline
#\\ #\ #\ #\ #\\ #\ #\/ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
#\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\/ #\newline
#\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline
#\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\newline
#\/ #\ #\\ #\ #\/ #\. #\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\newline
#\\ #\_ #\/ #\ #\\ #\ #\/ #\. #\ #\_ #\ #\. #\\ #\ #\/ #\newline
#\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\ #\\ #\ #\ #\ #\\ #\newline
#\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline
#\\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\_ #\/ #\newline
#\/ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\. #\\ #\newline
#\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\\ #\_ #\ #\ #\\ #\ #\/ #\. #\\ #\ #\ #\. #\\ #\newline
#\\ #\ #\/ #\. #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\ #\ #\ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\newline
#\\ #\ #\/ #\. #\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\ #\/ #\newline
#\/ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\newline
#\\ #\_ #\ #\ #\\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline
#\/ #\ #\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\ #\\ #\newline
#\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline
#\/ #\ #\\ #\ #\/ #\ #\ #\_ #\ #\. #\ #\_ #\ #\ #\\ #\newline
#\\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\ #\ #\\ #\_ #\/ #\newline
#\/ #\ #\ #\_ #\ #\ #\\ #\ #\ #\ #\\ #\_ #\/ #\ #\\ #\newline
#\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\_ #\/ #\ #\ #\_ #\/ #\newline
#\/ #\ #\\ #\ #\ #\. #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\newline
#\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\. #\ #\ #\ #\ #\\ #\newline
#\\ #\ #\ #\ #\ #\ #\ #\. #\ #\ #\/ #\. #\\ #\_ #\/ #\newline
#\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
#\\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\ #\/ #\newline
#\/ #\ #\ #\ #\/ #\ #\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\newline
#\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\_ #\/ #\newline
#\/ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
#\\ #\ #\ #\ #\ #\_ #\/ #\. #\ #\ #\/ #\. #\ #\_ #\/ #\newline
#\/ #\ #\\ #\ #\/ #\. #\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
#\\ #\_ #\/ #\. #\ #\_ #\/ #\. #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline
#\/ #\ #\ #\_ #\ #\. #\\ #\_ #\ #\. #\ #\_ #\ #\. #\\ #\newline
#\\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\newline)))
(lambda (nrows ncols) (lambda () (run nrows ncols)))
20
7)))

210
benchmarks/new/r6rs-benchmarks/mazefun.ss Normal file
View File

@ -0,0 +1,210 @@
;;; MAZEFUN -- Constructs a maze in a purely functional way,
;;; written by Marc Feeley.
(library (r6rs-benchmarks mazefun)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define foldr
(lambda (f base lst)
(define foldr-aux
(lambda (lst)
(if (null? lst)
base
(f (car lst) (foldr-aux (cdr lst))))))
(foldr-aux lst)))
(define foldl
(lambda (f base lst)
(define foldl-aux
(lambda (base lst)
(if (null? lst)
base
(foldl-aux (f base (car lst)) (cdr lst)))))
(foldl-aux base lst)))
(define for
(lambda (lo hi f)
(define for-aux
(lambda (lo)
(if (< lo hi)
(cons (f lo) (for-aux (+ lo 1)))
'())))
(for-aux lo)))
(define concat
(lambda (lists)
(foldr append '() lists)))
(define list-read
(lambda (lst i)
(if (= i 0)
(car lst)
(list-read (cdr lst) (- i 1)))))
(define list-write
(lambda (lst i val)
(if (= i 0)
(cons val (cdr lst))
(cons (car lst) (list-write (cdr lst) (- i 1) val)))))
(define list-remove-pos
(lambda (lst i)
(if (= i 0)
(cdr lst)
(cons (car lst) (list-remove-pos (cdr lst) (- i 1))))))
(define duplicates?
(lambda (lst)
(if (null? lst)
#f
(or (member (car lst) (cdr lst))
(duplicates? (cdr lst))))))
(define make-matrix
(lambda (n m init)
(for 0 n (lambda (i) (for 0 m (lambda (j) (init i j)))))))
(define matrix-read
(lambda (mat i j)
(list-read (list-read mat i) j)))
(define matrix-write
(lambda (mat i j val)
(list-write mat i (list-write (list-read mat i) j val))))
(define matrix-size
(lambda (mat)
(cons (length mat) (length (car mat)))))
(define matrix-map
(lambda (f mat)
(map (lambda (lst) (map f lst)) mat)))
(define initial-random 0)
(define next-random
(lambda (current-random)
(remainder (+ (* current-random 3581) 12751) 131072)))
(define shuffle
(lambda (lst)
(shuffle-aux lst initial-random)))
(define shuffle-aux
(lambda (lst current-random)
(if (null? lst)
'()
(let ((new-random (next-random current-random)))
(let ((i (modulo new-random (length lst))))
(cons (list-read lst i)
(shuffle-aux (list-remove-pos lst i)
new-random)))))))
(define make-maze
(lambda (n m) ; n and m must be odd
(if (not (and (odd? n) (odd? m)))
'error
(let ((cave
(make-matrix n m (lambda (i j)
(if (and (even? i) (even? j))
(cons i j)
#f))))
(possible-holes
(concat
(for 0 n (lambda (i)
(concat
(for 0 m (lambda (j)
(if (equal? (even? i) (even? j))
'()
(list (cons i j)))))))))))
(cave-to-maze (pierce-randomly (shuffle possible-holes) cave))))))
(define cave-to-maze
(lambda (cave)
(matrix-map (lambda (x) (if x '_ '*)) cave)))
(define pierce
(lambda (pos cave)
(let ((i (car pos)) (j (cdr pos)))
(matrix-write cave i j pos))))
(define pierce-randomly
(lambda (possible-holes cave)
(if (null? possible-holes)
cave
(let ((hole (car possible-holes)))
(pierce-randomly (cdr possible-holes)
(try-to-pierce hole cave))))))
(define try-to-pierce
(lambda (pos cave)
(let ((i (car pos)) (j (cdr pos)))
(let ((ncs (neighboring-cavities pos cave)))
(if (duplicates?
(map (lambda (nc) (matrix-read cave (car nc) (cdr nc))) ncs))
cave
(pierce pos
(foldl (lambda (c nc) (change-cavity c nc pos))
cave
ncs)))))))
(define change-cavity
(lambda (cave pos new-cavity-id)
(let ((i (car pos)) (j (cdr pos)))
(change-cavity-aux cave pos new-cavity-id (matrix-read cave i j)))))
(define change-cavity-aux
(lambda (cave pos new-cavity-id old-cavity-id)
(let ((i (car pos)) (j (cdr pos)))
(let ((cavity-id (matrix-read cave i j)))
(if (equal? cavity-id old-cavity-id)
(foldl (lambda (c nc)
(change-cavity-aux c nc new-cavity-id old-cavity-id))
(matrix-write cave i j new-cavity-id)
(neighboring-cavities pos cave))
cave)))))
(define neighboring-cavities
(lambda (pos cave)
(let ((size (matrix-size cave)))
(let ((n (car size)) (m (cdr size)))
(let ((i (car pos)) (j (cdr pos)))
(append (if (and (> i 0) (matrix-read cave (- i 1) j))
(list (cons (- i 1) j))
'())
(if (and (< i (- n 1)) (matrix-read cave (+ i 1) j))
(list (cons (+ i 1) j))
'())
(if (and (> j 0) (matrix-read cave i (- j 1)))
(list (cons i (- j 1)))
'())
(if (and (< j (- m 1)) (matrix-read cave i (+ j 1)))
(list (cons i (+ j 1)))
'())))))))
(define expected-result
'((_ * _ _ _ _ _ _ _ _ _)
(_ * * * * * * * _ * *)
(_ _ _ * _ _ _ * _ _ _)
(_ * _ * _ * _ * _ * _)
(_ * _ _ _ * _ * _ * _)
(* * _ * * * * * _ * _)
(_ * _ _ _ _ _ _ _ * _)
(_ * _ * _ * * * * * *)
(_ _ _ * _ _ _ _ _ _ _)
(_ * * * * * * * _ * *)
(_ * _ _ _ _ _ _ _ _ _)))
(define (main . args)
(run-benchmark
"mazefun"
mazefun-iters
(lambda (result)
(equal? result expected-result))
(lambda (n m) (lambda () (make-maze n m)))
11
11)))

54
benchmarks/new/r6rs-benchmarks/mbrot.ss Normal file
View File

@ -0,0 +1,54 @@
;;; MBROT -- Generation of Mandelbrot set fractal.
(library (r6rs-benchmarks mbrot)
(export main)
(import (r6rs) (r6rs arithmetic flonums) (r6rs-benchmarks))
(define (count r i step x y)
(let ((max-count 64)
(radius^2 16.0))
(let ((cr (fl+ r (fl* (exact->inexact x) step)))
(ci (fl+ i (fl* (exact->inexact y) step))))
(let loop ((zr cr)
(zi ci)
(c 0))
(if (= c max-count)
c
(let ((zr^2 (fl* zr zr))
(zi^2 (fl* zi zi)))
(if (fl>? (fl+ zr^2 zi^2) radius^2)
c
(let ((new-zr (fl+ (fl- zr^2 zi^2) cr))
(new-zi (fl+ (fl* 2.0 (fl* zr zi)) ci)))
(loop new-zr new-zi (+ c 1))))))))))
(define (mbrot matrix r i step n)
(let loop1 ((y (- n 1)))
(if (>= y 0)
(let loop2 ((x (- n 1)))
(if (>= x 0)
(begin
(vector-set! (vector-ref matrix x) y (count r i step x y))
(loop2 (- x 1)))
(loop1 (- y 1)))))))
(define (test n)
(let ((matrix (make-vector n)))
(let loop ((i (- n 1)))
(if (>= i 0)
(begin
(vector-set! matrix i (make-vector n))
(loop (- i 1)))))
(mbrot matrix -1.0 -0.5 0.005 n)
(vector-ref (vector-ref matrix 0) 0)))
(define (main . args)
(run-benchmark
"mbrot"
mbrot-iters
(lambda (result) (equal? result 5))
(lambda (n) (lambda () (test n)))
75)))

774
benchmarks/new/r6rs-benchmarks/nboyer.ss Normal file
View File

@ -0,0 +1,774 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: nboyer.sch
; Description: The Boyer benchmark
; Author: Bob Boyer
; Created: 5-Apr-85
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
; rewrote to eliminate property lists, and added
; a scaling parameter suggested by Bob Boyer)
; 19-Mar-99 (Will Clinger -- cleaned up comments)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; NBOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Fairly CONS intensive.
; Note: The version of this benchmark that appears in Dick Gabriel's book
; contained several bugs that are corrected here. These bugs are discussed
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
;
; The benchmark now returns a boolean result.
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
; in Common Lisp)
; ONE-WAY-UNIFY1 now treats numbers correctly
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
; Rule 19 has been corrected (this rule was not touched by the original
; benchmark, but is used by this version)
; Rules 84 and 101 have been corrected (but these rules are never touched
; by the benchmark)
;
; According to Baker, these bug fixes make the benchmark 10-25% slower.
; Please do not compare the timings from this benchmark against those of
; the original benchmark.
;
; This version of the benchmark also prints the number of rewrites as a sanity
; check, because it is too easy for a buggy version to return the correct
; boolean result. The correct number of rewrites is
;
; n rewrites peak live storage (approximate, in bytes)
; 0 95024 520,000
; 1 591777 2,085,000
; 2 1813975 5,175,000
; 3 5375678
; 4 16445406
; 5 51507739
; Nboyer is a 2-phase benchmark.
; The first phase attaches lemmas to symbols. This phase is not timed,
; but it accounts for very little of the runtime anyway.
; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas.
(library (r6rs-benchmarks nboyer)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (main . args)
(let ((n (if (null? args) 0 (car args))))
(setup-boyer)
(run-benchmark
(string-append "nboyer"
(number->string n))
nboyer-iters
(lambda (rewrites)
(and (number? rewrites)
(case n
((0) (= rewrites 95024))
((1) (= rewrites 591777))
((2) (= rewrites 1813975))
((3) (= rewrites 5375678))
((4) (= rewrites 16445406))
((5) (= rewrites 51507739))
; If it works for n <= 5, assume it works.
(else #t))))
(lambda (alist term n) (lambda () (test-boyer alist term n)))
(quote ((x f (plus (plus a b)
(plus c (zero))))
(y f (times (times a b)
(plus c d)))
(z f (reverse (append (append a b)
(nil))))
(u equal (plus a b)
(difference x y))
(w lessp (remainder a b)
(member a (length b)))))
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))
n)))
(define (setup-boyer) #t) ; assigned below
(define (test-boyer) #t) ; assigned below
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The first phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; In the original benchmark, it stored a list of lemmas on the
; property lists of symbols.
; In the new benchmark, it maintains an association list of
; symbols and symbol-records, and stores the list of lemmas
; within the symbol-records.
(let ()
(define (setup)
(add-lemma-lst
(quote ((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(equal (fix x)
(fix y)))
(equal (greaterp x y)
(lessp y x))
(equal (lesseqp x y)
(not (lessp y x)))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (_1- x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x)))
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (_1- x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (fix x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (plus (plus x y)
z)
(plus x (plus y z)))
(equal (equal (plus a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (difference x x)
(zero))
(equal (equal (plus a b)
(plus a c))
(equal (fix b)
(fix c)))
(equal (equal (zero)
(difference x y))
(not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (append x y))
a)
(plus (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(fix (meaning x a)))
(equal (append (append x y)
z)
(append x (append y z)))
(equal (reverse (append a b))
(append (reverse b)
(reverse a)))
(equal (times x (plus y z))
(plus (times x y)
(times x z)))
(equal (times (times x y)
z)
(times x (times y z)))
(equal (equal (times x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (append x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(append (flatten x)
y))
(equal (member x (append a b))
(or (member x a)
(member x b)))
(equal (member x (reverse y))
(member x y))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c))
(and (member a b)
(member a c)))
(equal (nth (zero)
i)
(zero))
(equal (exp i (plus j k))
(times (exp i j)
(exp i k)))
(equal (exp i (times j k))
(exp (exp i j)
k))
(equal (reverse-loop x y)
(append (reverse x)
y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x)
(count-list z y)))
(equal (equal (append a b)
(append a c))
(equal b c))
(equal (plus (remainder x y)
(times y (quotient x y)))
(fix x))
(equal (power-eval (big-plus1 l i base)
base)
(plus (power-eval l base)
i))
(equal (power-eval (big-plus x y i base)
base)
(plus i (plus (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (lessp (remainder x y)
y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (lessp (quotient i j)
i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (lessp (remainder x y)
x)
(and (not (zerop y))
(not (zerop x))
(not (lessp x y))))
(equal (power-eval (power-rep i base)
base)
(fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (append a b)
i)
(append (nth a i)
(nth b (difference i (length a)))))
(equal (difference (plus x y)
x)
(fix y))
(equal (difference (plus y x)
x)
(fix y))
(equal (difference (plus x y)
(plus x z))
(difference y z))
(equal (times x (difference c w))
(difference (times c x)
(times w x)))
(equal (remainder (times x z)
z)
(zero))
(equal (difference (plus b (plus a c))
a)
(plus b c))
(equal (difference (add1 (plus y z))
z)
(add1 y))
(equal (lessp (plus x y)
(plus x z))
(lessp y z))
(equal (lessp (times x z)
(times y z))
(and (not (zerop z))
(lessp x y)))
(equal (lessp y (plus x y))
(not (zerop x)))
(equal (gcd (times x z)
(times y z))
(times z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y)
1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (append x y))
(times (times-list x)
(times-list y)))
(equal (prime-list (append x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (times w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (times y x)
y)
(zero))
(equal (equal (times a b)
1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (_1- a)
(zero))
(equal (_1- b)
(zero))))
(equal (lessp (length (delete x l))
(length l))
(member x l))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length (cons x1
(cons x2
(cons x3 (cons x4
(cons x5
(cons x6 x7)))))))
(plus 6 (length x7)))
(equal (difference (add1 (add1 x))
2)
(fix x))
(equal (quotient (plus x (plus x y))
2)
(plus x (quotient y 2)))
(equal (sigma (zero)
i)
(quotient (times i (add1 i))
2))
(equal (plus x (add1 y))
(if (numberp y)
(add1 (plus x y))
(add1 x)))
(equal (equal (difference x y)
(difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y)
(not (lessp y x))
(equal (fix x)
(fix z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y)
(difference (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (times x (add1 y))
(if (numberp y)
(plus x (times x y))
(fix x)))
(equal (nth (nil)
i)
(if (zerop i)
(nil)
(zero)))
(equal (last (append a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a))
b)
b)))
(equal (equal (lessp x y)
z)
(if (lessp x y)
(equal (t) z)
(equal (f) z)))
(equal (assignment x (append a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (quotient (times y x)
y)
(if (zerop y)
(zero)
(fix x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem)))))))
(define (add-lemma-lst lst)
(cond ((null? lst)
#t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(define (add-lemma term)
(cond ((and (pair? term)
(eq? (car term)
(quote equal))
(pair? (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons
(translate-term term)
(get (car (cadr term)) (quote lemmas)))))
(else (fatal-error "ADD-LEMMA did not like term: " term))))
; Translates a term by replacing its constructor symbols by symbol-records.
(define (translate-term term)
(cond ((not (pair? term))
term)
(else (cons (symbol->symbol-record (car term))
(translate-args (cdr term))))))
(define (translate-args lst)
(cond ((null? lst)
'())
(else (cons (translate-term (car lst))
(translate-args (cdr lst))))))
; For debugging only, so the use of MAP does not change
; the first-order character of the benchmark.
(define (untranslate-term term)
(cond ((not (pair? term))
term)
(else (cons (get-name (car term))
(map untranslate-term (cdr term))))))
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (put sym property value)
(put-lemmas! (symbol->symbol-record sym) value))
(define (get sym property)
(get-lemmas (symbol->symbol-record sym)))
(define (symbol->symbol-record sym)
(let ((x (assq sym *symbol-records-alist*)))
(if x
(cdr x)
(let ((r (make-symbol-record sym)))
(set! *symbol-records-alist*
(cons (cons sym r)
*symbol-records-alist*))
r))))
; Association list of symbols and symbol-records.
(define *symbol-records-alist* '())
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (make-symbol-record sym)
(vector sym '()))
(define (put-lemmas! symbol-record lemmas)
(vector-set! symbol-record 1 lemmas))
(define (get-lemmas symbol-record)
(vector-ref symbol-record 1))
(define (get-name symbol-record)
(vector-ref symbol-record 0))
(define (symbol-record-equal? r1 r2)
(eq? r1 r2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The second phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test alist term n)
(let ((term
(apply-subst
(translate-alist alist)
(translate-term
(do ((term term (list 'or term '(f)))
(n n (- n 1)))
((zero? n) term))))))
(tautp term)))
(define (translate-alist alist)
(cond ((null? alist)
'())
(else (cons (cons (caar alist)
(translate-term (cdar alist)))
(translate-alist (cdr alist))))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(let ((temp-temp (assq term alist)))
(if temp-temp
(cdr temp-temp)
term)))
(else (cons (car term)
(apply-subst-lst alist (cdr term))))))
(define (apply-subst-lst alist lst)
(cond ((null? lst)
'())
(else (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(define (tautp x)
(tautologyp (rewrite x)
'() '()))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
#t)
((falsep x false-lst)
#f)
((not (pair? x))
#f)
((eq? (car x) if-constructor)
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(else (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(else #f)))
(define if-constructor '*) ; becomes (symbol->symbol-record 'if)
(define rewrite-count 0) ; sanity check
(define (rewrite term)
(set! rewrite-count (+ rewrite-count 1))
(cond ((not (pair? term))
term)
(else (rewrite-with-lemmas (cons (car term)
(rewrite-args (cdr term)))
(get-lemmas (car term))))))
(define (rewrite-args lst)
(cond ((null? lst)
'())
(else (cons (rewrite (car lst))
(rewrite-args (cdr lst))))))
(define (rewrite-with-lemmas term lst)
(cond ((null? lst)
term)
((one-way-unify term (cadr (car lst)))
(rewrite (apply-subst unify-subst (caddr (car lst)))))
(else (rewrite-with-lemmas term (cdr lst)))))
(define unify-subst '*)
(define (one-way-unify term1 term2)
(begin (set! unify-subst '())
(one-way-unify1 term1 term2)))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(let ((temp-temp (assq term2 unify-subst)))
(cond (temp-temp
(term-equal? term1 (cdr temp-temp)))
((number? term2) ; This bug fix makes
(equal? term1 term2)) ; nboyer 10-25% slower!
(else
(set! unify-subst (cons (cons term2 term1)
unify-subst))
#t))))
((not (pair? term1))
#f)
((eq? (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(else #f)))
(define (one-way-unify1-lst lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else #f)))
(define (falsep x lst)
(or (term-equal? x false-term)
(term-member? x lst)))
(define (truep x lst)
(or (term-equal? x true-term)
(term-member? x lst)))
(define false-term '*) ; becomes (translate-term '(f))
(define true-term '*) ; becomes (translate-term '(t))
; The next two procedures were in the original benchmark
; but were never used.
(define (trans-of-implies n)
(translate-term
(list (quote implies)
(trans-of-implies1 n)
(list (quote implies)
0 n))))
(define (trans-of-implies1 n)
(cond ((equal? n 1)
(list (quote implies)
0 1))
(else (list (quote and)
(list (quote implies)
(- n 1)
n)
(trans-of-implies1 (- n 1))))))
; Translated terms can be circular structures, which can't be
; compared using Scheme's equal? and member procedures, so we
; use these instead.
(define (term-equal? x y)
(cond ((pair? x)
(and (pair? y)
(symbol-record-equal? (car x) (car y))
(term-args-equal? (cdr x) (cdr y))))
(else (equal? x y))))
(define (term-args-equal? lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((term-equal? (car lst1) (car lst2))
(term-args-equal? (cdr lst1) (cdr lst2)))
(else #f)))
(define (term-member? x lst)
(cond ((null? lst)
#f)
((term-equal? x (car lst))
#t)
(else (term-member? x (cdr lst)))))
(set! setup-boyer
(lambda ()
(set! *symbol-records-alist* '())
(set! if-constructor (symbol->symbol-record 'if))
(set! false-term (translate-term '(f)))
(set! true-term (translate-term '(t)))
(setup)))
(set! test-boyer
(lambda (alist term n)
(set! rewrite-count 0)
(let ((answer (test alist term n)))
; (write rewrite-count)
; (display " rewrites")
; (newline)
(if answer
rewrite-count
#f))))))

40
benchmarks/new/r6rs-benchmarks/nqueens.ss Normal file
View File

@ -0,0 +1,40 @@
;;; NQUEENS -- Compute number of solutions to 8-queens problem.
(library (r6rs-benchmarks nqueens)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define trace? #f)
(define (nqueens n)
(define (_1-to n)
(let loop ((i n) (l '()))
(if (= i 0) l (loop (- i 1) (cons i l)))))
(define (my-try x y z)
(if (null? x)
(if (null? y)
(begin (if trace? (begin (write z) (newline))) 1)
0)
(+ (if (ok? (car x) 1 z)
(my-try (append (cdr x) y) '() (cons (car x) z))
0)
(my-try (cdr x) (cons (car x) y) z))))
(define (ok? row dist placed)
(if (null? placed)
#t
(and (not (= (car placed) (+ row dist)))
(not (= (car placed) (- row dist)))
(ok? row (+ dist 1) (cdr placed)))))
(my-try (_1-to n) '() '()))
(define (main)
(run-benchmark
"nqueens"
nqueens-iters
(lambda (result) (equal? result 92))
(lambda (n) (lambda () (nqueens n)))
8)))

49
benchmarks/new/r6rs-benchmarks/ntakl.ss Normal file
View File

@ -0,0 +1,49 @@
;;; NTAKL -- The TAKeuchi function using lists as counters,
;;; with an alternative boolean expression.
(library (r6rs-benchmarks ntakl)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (listn n)
(if (= n 0)
'()
(cons n (listn (- n 1)))))
(define l18 (listn 18))
(define l12 (listn 12))
(define l6 (listn 6))
(define (mas x y z)
(if (not (shorterp y x))
z
(mas (mas (cdr x) y z)
(mas (cdr y) z x)
(mas (cdr z) x y))))
; Part of the fun of this benchmark is seeing how well the compiler
; can understand this ridiculous code, which dates back to the original
; Common Lisp. So it probably isn't a good idea to improve upon it.
#;
(define (shorterp x y)
(and (not (null? y))
(or (null? x)
(shorterp (cdr x)
(cdr y)))))
; But SML/NJ runs this benchmark about 15 times as fast when the
; code above is rewritten as follows, so I tried it for Scheme also.
(define (shorterp x y)
(cond ((null? y) #f)
((null? x) #t)
(else
(shorterp (cdr x) (cdr y)))))
(define (main . args)
(run-benchmark
"ntakl"
takl-iters
(lambda (result) (equal? result '(7 6 5 4 3 2 1)))
(lambda () (lambda () (mas l18 l12 l6))))))

180
benchmarks/new/r6rs-benchmarks/paraffins.ss Normal file
View File

@ -0,0 +1,180 @@
;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms.
(library (r6rs-benchmarks paraffins)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (gen n)
(let* ((n/2 (quotient n 2))
(radicals (make-vector (+ n/2 1) '(H))))
(define (rads-of-size n)
(let loop1 ((ps
(three-partitions (- n 1)))
(lst
'()))
(if (null? ps)
lst
(let* ((p (car ps))
(nc1 (vector-ref p 0))
(nc2 (vector-ref p 1))
(nc3 (vector-ref p 2)))
(let loop2 ((rads1
(vector-ref radicals nc1))
(lst
(loop1 (cdr ps)
lst)))
(if (null? rads1)
lst
(let loop3 ((rads2
(if (= nc1 nc2)
rads1
(vector-ref radicals nc2)))
(lst
(loop2 (cdr rads1)
lst)))
(if (null? rads2)
lst
(let loop4 ((rads3
(if (= nc2 nc3)
rads2
(vector-ref radicals nc3)))
(lst
(loop3 (cdr rads2)
lst)))
(if (null? rads3)
lst
(cons (vector 'C
(car rads1)
(car rads2)
(car rads3))
(loop4 (cdr rads3)
lst))))))))))))
(define (bcp-generator j)
(if (odd? j)
'()
(let loop1 ((rads1
(vector-ref radicals (quotient j 2)))
(lst
'()))
(if (null? rads1)
lst
(let loop2 ((rads2
rads1)
(lst
(loop1 (cdr rads1)
lst)))
(if (null? rads2)
lst
(cons (vector 'BCP
(car rads1)
(car rads2))
(loop2 (cdr rads2)
lst))))))))
(define (ccp-generator j)
(let loop1 ((ps
(four-partitions (- j 1)))
(lst
'()))
(if (null? ps)
lst
(let* ((p (car ps))
(nc1 (vector-ref p 0))
(nc2 (vector-ref p 1))
(nc3 (vector-ref p 2))
(nc4 (vector-ref p 3)))
(let loop2 ((rads1
(vector-ref radicals nc1))
(lst
(loop1 (cdr ps)
lst)))
(if (null? rads1)
lst
(let loop3 ((rads2
(if (= nc1 nc2)
rads1
(vector-ref radicals nc2)))
(lst
(loop2 (cdr rads1)
lst)))
(if (null? rads2)
lst
(let loop4 ((rads3
(if (= nc2 nc3)
rads2
(vector-ref radicals nc3)))
(lst
(loop3 (cdr rads2)
lst)))
(if (null? rads3)
lst
(let loop5 ((rads4
(if (= nc3 nc4)
rads3
(vector-ref radicals nc4)))
(lst
(loop4 (cdr rads3)
lst)))
(if (null? rads4)
lst
(cons (vector 'CCP
(car rads1)
(car rads2)
(car rads3)
(car rads4))
(loop5 (cdr rads4)
lst))))))))))))))
(let loop ((i 1))
(if (> i n/2)
(vector (bcp-generator n)
(ccp-generator n))
(begin
(vector-set! radicals i (rads-of-size i))
(loop (+ i 1)))))))
(define (three-partitions m)
(let loop1 ((lst '())
(nc1 (quotient m 3)))
(if (< nc1 0)
lst
(let loop2 ((lst lst)
(nc2 (quotient (- m nc1) 2)))
(if (< nc2 nc1)
(loop1 lst
(- nc1 1))
(loop2 (cons (vector nc1 nc2 (- m (+ nc1 nc2))) lst)
(- nc2 1)))))))
(define (four-partitions m)
(let loop1 ((lst '())
(nc1 (quotient m 4)))
(if (< nc1 0)
lst
(let loop2 ((lst lst)
(nc2 (quotient (- m nc1) 3)))
(if (< nc2 nc1)
(loop1 lst
(- nc1 1))
(let ((start (max nc2 (- (quotient (+ m 1) 2) (+ nc1 nc2)))))
(let loop3 ((lst lst)
(nc3 (quotient (- m (+ nc1 nc2)) 2)))
(if (< nc3 start)
(loop2 lst (- nc2 1))
(loop3 (cons (vector nc1 nc2 nc3 (- m (+ nc1 (+ nc2 nc3)))) lst)
(- nc3 1))))))))))
(define (nb n)
(let ((x (gen n)))
(+ (length (vector-ref x 0))
(length (vector-ref x 1)))))
(define (main . args)
(run-benchmark
"paraffins"
paraffins-iters
(lambda (result) (equal? result 24894))
(lambda (n) (lambda () (nb n)))
17)))

770
benchmarks/new/r6rs-benchmarks/parsing-test.sch Normal file
View File

@ -0,0 +1,770 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: nboyer.sch
; Description: The Boyer benchmark
; Author: Bob Boyer
; Created: 5-Apr-85
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
; rewrote to eliminate property lists, and added
; a scaling parameter suggested by Bob Boyer)
; 19-Mar-99 (Will Clinger -- cleaned up comments)
; 4-Apr-01 (Will Clinger -- changed four 1- symbols to sub1)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; NBOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Fairly CONS intensive.
; Note: The version of this benchmark that appears in Dick Gabriel's book
; contained several bugs that are corrected here. These bugs are discussed
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
;
; The benchmark now returns a boolean result.
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
; in Common Lisp)
; ONE-WAY-UNIFY1 now treats numbers correctly
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
; Rule 19 has been corrected (this rule was not touched by the original
; benchmark, but is used by this version)
; Rules 84 and 101 have been corrected (but these rules are never touched
; by the benchmark)
;
; According to Baker, these bug fixes make the benchmark 10-25% slower.
; Please do not compare the timings from this benchmark against those of
; the original benchmark.
;
; This version of the benchmark also prints the number of rewrites as a sanity
; check, because it is too easy for a buggy version to return the correct
; boolean result. The correct number of rewrites is
;
; n rewrites peak live storage (approximate, in bytes)
; 0 95024 520,000
; 1 591777 2,085,000
; 2 1813975 5,175,000
; 3 5375678
; 4 16445406
; 5 51507739
; Nboyer is a 2-phase benchmark.
; The first phase attaches lemmas to symbols. This phase is not timed,
; but it accounts for very little of the runtime anyway.
; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas.
(define (nboyer-benchmark . args)
(let ((n (if (null? args) 0 (car args))))
(setup-boyer)
(run-benchmark (string-append "nboyer"
(number->string n))
1
(lambda () (test-boyer n))
(lambda (rewrites)
(and (number? rewrites)
(case n
((0) (= rewrites 95024))
((1) (= rewrites 591777))
((2) (= rewrites 1813975))
((3) (= rewrites 5375678))
((4) (= rewrites 16445406))
((5) (= rewrites 51507739))
; If it works for n <= 5, assume it works.
(else #t)))))))
(define (setup-boyer) #t) ; assigned below
(define (test-boyer) #t) ; assigned below
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The first phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; In the original benchmark, it stored a list of lemmas on the
; property lists of symbols.
; In the new benchmark, it maintains an association list of
; symbols and symbol-records, and stores the list of lemmas
; within the symbol-records.
(let ()
(define (setup)
(add-lemma-lst
(quote ((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(equal (fix x)
(fix y)))
(equal (greaterp x y)
(lessp y x))
(equal (lesseqp x y)
(not (lessp y x)))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (sub1 x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x)))
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (sub1 x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (fix x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (plus (plus x y)
z)
(plus x (plus y z)))
(equal (equal (plus a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (difference x x)
(zero))
(equal (equal (plus a b)
(plus a c))
(equal (fix b)
(fix c)))
(equal (equal (zero)
(difference x y))
(not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (append x y))
a)
(plus (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(fix (meaning x a)))
(equal (append (append x y)
z)
(append x (append y z)))
(equal (reverse (append a b))
(append (reverse b)
(reverse a)))
(equal (times x (plus y z))
(plus (times x y)
(times x z)))
(equal (times (times x y)
z)
(times x (times y z)))
(equal (equal (times x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (append x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(append (flatten x)
y))
(equal (member x (append a b))
(or (member x a)
(member x b)))
(equal (member x (reverse y))
(member x y))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c))
(and (member a b)
(member a c)))
(equal (nth (zero)
i)
(zero))
(equal (exp i (plus j k))
(times (exp i j)
(exp i k)))
(equal (exp i (times j k))
(exp (exp i j)
k))
(equal (reverse-loop x y)
(append (reverse x)
y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x)
(count-list z y)))
(equal (equal (append a b)
(append a c))
(equal b c))
(equal (plus (remainder x y)
(times y (quotient x y)))
(fix x))
(equal (power-eval (big-plus1 l i base)
base)
(plus (power-eval l base)
i))
(equal (power-eval (big-plus x y i base)
base)
(plus i (plus (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (lessp (remainder x y)
y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (lessp (quotient i j)
i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (lessp (remainder x y)
x)
(and (not (zerop y))
(not (zerop x))
(not (lessp x y))))
(equal (power-eval (power-rep i base)
base)
(fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (append a b)
i)
(append (nth a i)
(nth b (difference i (length a)))))
(equal (difference (plus x y)
x)
(fix y))
(equal (difference (plus y x)
x)
(fix y))
(equal (difference (plus x y)
(plus x z))
(difference y z))
(equal (times x (difference c w))
(difference (times c x)
(times w x)))
(equal (remainder (times x z)
z)
(zero))
(equal (difference (plus b (plus a c))
a)
(plus b c))
(equal (difference (add1 (plus y z))
z)
(add1 y))
(equal (lessp (plus x y)
(plus x z))
(lessp y z))
(equal (lessp (times x z)
(times y z))
(and (not (zerop z))
(lessp x y)))
(equal (lessp y (plus x y))
(not (zerop x)))
(equal (gcd (times x z)
(times y z))
(times z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y)
1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (append x y))
(times (times-list x)
(times-list y)))
(equal (prime-list (append x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (times w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (times y x)
y)
(zero))
(equal (equal (times a b)
1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (sub1 a)
(zero))
(equal (sub1 b)
(zero))))
(equal (lessp (length (delete x l))
(length l))
(member x l))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length (cons x1
(cons x2
(cons x3 (cons x4
(cons x5
(cons x6 x7)))))))
(plus 6 (length x7)))
(equal (difference (add1 (add1 x))
2)
(fix x))
(equal (quotient (plus x (plus x y))
2)
(plus x (quotient y 2)))
(equal (sigma (zero)
i)
(quotient (times i (add1 i))
2))
(equal (plus x (add1 y))
(if (numberp y)
(add1 (plus x y))
(add1 x)))
(equal (equal (difference x y)
(difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y)
(not (lessp y x))
(equal (fix x)
(fix z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y)
(difference (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (times x (add1 y))
(if (numberp y)
(plus x (times x y))
(fix x)))
(equal (nth (nil)
i)
(if (zerop i)
(nil)
(zero)))
(equal (last (append a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a))
b)
b)))
(equal (equal (lessp x y)
z)
(if (lessp x y)
(equal (t) z)
(equal (f) z)))
(equal (assignment x (append a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (quotient (times y x)
y)
(if (zerop y)
(zero)
(fix x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem)))))))
(define (add-lemma-lst lst)
(cond ((null? lst)
#t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(define (add-lemma term)
(cond ((and (pair? term)
(eq? (car term)
(quote equal))
(pair? (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons
(translate-term term)
(get (car (cadr term)) (quote lemmas)))))
(else (error "ADD-LEMMA did not like term: " term))))
; Translates a term by replacing its constructor symbols by symbol-records.
(define (translate-term term)
(cond ((not (pair? term))
term)
(else (cons (symbol->symbol-record (car term))
(translate-args (cdr term))))))
(define (translate-args lst)
(cond ((null? lst)
'())
(else (cons (translate-term (car lst))
(translate-args (cdr lst))))))
; For debugging only, so the use of MAP does not change
; the first-order character of the benchmark.
(define (untranslate-term term)
(cond ((not (pair? term))
term)
(else (cons (get-name (car term))
(map untranslate-term (cdr term))))))
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (put sym property value)
(put-lemmas! (symbol->symbol-record sym) value))
(define (get sym property)
(get-lemmas (symbol->symbol-record sym)))
(define (symbol->symbol-record sym)
(let ((x (assq sym *symbol-records-alist*)))
(if x
(cdr x)
(let ((r (make-symbol-record sym)))
(set! *symbol-records-alist*
(cons (cons sym r)
*symbol-records-alist*))
r))))
; Association list of symbols and symbol-records.
(define *symbol-records-alist* '())
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (make-symbol-record sym)
(vector sym '()))
(define (put-lemmas! symbol-record lemmas)
(vector-set! symbol-record 1 lemmas))
(define (get-lemmas symbol-record)
(vector-ref symbol-record 1))
(define (get-name symbol-record)
(vector-ref symbol-record 0))
(define (symbol-record-equal? r1 r2)
(eq? r1 r2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The second phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test n)
(let ((term
(apply-subst
(translate-alist
(quote ((x f (plus (plus a b)
(plus c (zero))))
(y f (times (times a b)
(plus c d)))
(z f (reverse (append (append a b)
(nil))))
(u equal (plus a b)
(difference x y))
(w lessp (remainder a b)
(member a (length b))))))
(translate-term
(do ((term
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))
(list 'or term '(f)))
(n n (- n 1)))
((zero? n) term))))))
(tautp term)))
(define (translate-alist alist)
(cond ((null? alist)
'())
(else (cons (cons (caar alist)
(translate-term (cdar alist)))
(translate-alist (cdr alist))))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(let ((temp-temp (assq term alist)))
(if temp-temp
(cdr temp-temp)
term)))
(else (cons (car term)
(apply-subst-lst alist (cdr term))))))
(define (apply-subst-lst alist lst)
(cond ((null? lst)
'())
(else (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(define (tautp x)
(tautologyp (rewrite x)
'() '()))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
#t)
((falsep x false-lst)
#f)
((not (pair? x))
#f)
((eq? (car x) if-constructor)
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(else (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(else #f)))
(define if-constructor '*) ; becomes (symbol->symbol-record 'if)
(define rewrite-count 0) ; sanity check
(define (rewrite term)
(set! rewrite-count (+ rewrite-count 1))
(cond ((not (pair? term))
term)
(else (rewrite-with-lemmas (cons (car term)
(rewrite-args (cdr term)))
(get-lemmas (car term))))))
(define (rewrite-args lst)
(cond ((null? lst)
'())
(else (cons (rewrite (car lst))
(rewrite-args (cdr lst))))))
(define (rewrite-with-lemmas term lst)
(cond ((null? lst)
term)
((one-way-unify term (cadr (car lst)))
(rewrite (apply-subst unify-subst (caddr (car lst)))))
(else (rewrite-with-lemmas term (cdr lst)))))
(define unify-subst '*)
(define (one-way-unify term1 term2)
(begin (set! unify-subst '())
(one-way-unify1 term1 term2)))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(let ((temp-temp (assq term2 unify-subst)))
(cond (temp-temp
(term-equal? term1 (cdr temp-temp)))
((number? term2) ; This bug fix makes
(equal? term1 term2)) ; nboyer 10-25% slower!
(else
(set! unify-subst (cons (cons term2 term1)
unify-subst))
#t))))
((not (pair? term1))
#f)
((eq? (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(else #f)))
(define (one-way-unify1-lst lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else #f)))
(define (falsep x lst)
(or (term-equal? x false-term)
(term-member? x lst)))
(define (truep x lst)
(or (term-equal? x true-term)
(term-member? x lst)))
(define false-term '*) ; becomes (translate-term '(f))
(define true-term '*) ; becomes (translate-term '(t))
; The next two procedures were in the original benchmark
; but were never used.
(define (trans-of-implies n)
(translate-term
(list (quote implies)
(trans-of-implies1 n)
(list (quote implies)
0 n))))
(define (trans-of-implies1 n)
(cond ((equal? n 1)
(list (quote implies)
0 1))
(else (list (quote and)
(list (quote implies)
(- n 1)
n)
(trans-of-implies1 (- n 1))))))
; Translated terms can be circular structures, which can't be
; compared using Scheme's equal? and member procedures, so we
; use these instead.
(define (term-equal? x y)
(cond ((pair? x)
(and (pair? y)
(symbol-record-equal? (car x) (car y))
(term-args-equal? (cdr x) (cdr y))))
(else (equal? x y))))
(define (term-args-equal? lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((term-equal? (car lst1) (car lst2))
(term-args-equal? (cdr lst1) (cdr lst2)))
(else #f)))
(define (term-member? x lst)
(cond ((null? lst)
#f)
((term-equal? x (car lst))
#t)
(else (term-member? x (cdr lst)))))
(set! setup-boyer
(lambda ()
(set! *symbol-records-alist* '())
(set! if-constructor (symbol->symbol-record 'if))
(set! false-term (translate-term '(f)))
(set! true-term (translate-term '(t)))
(setup)))
(set! test-boyer
(lambda (n)
(set! rewrite-count 0)
(let ((answer (test n)))
(write rewrite-count)
(display " rewrites")
(newline)
(if answer
rewrite-count
#f)))))

954
benchmarks/new/r6rs-benchmarks/parsing.ss Normal file
View File

@ -0,0 +1,954 @@
; Hacked to change error to fatal-error.
; (One of the benchmarked systems has a problem with calls to error.)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Parsing benchmark.
;
; Reads nboyer.sch into a string before timing begins.
;
; The timed portion of the benchmark parses the string
; representation of nboyer.sch 1000 times.
;
; The output of that parse is checked by comparing it
; the the value returned by the read procedure.
;
; Usage:
; (parsing-benchmark n input)
;
; n defaults to 1000, and input defaults to "nboyer.sch".
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(library (r6rs-benchmarks parsing)
(export main)
(import (r6rs) (r6rs-benchmarks))
(define (parsing-benchmark . rest)
(let* ((n (if (null? rest) 1000 (car rest)))
(input (if (or (null? rest) (null? (cdr rest)))
"nboyer.sch"
(cadr rest)))
(input-string (read-file-as-string input))
(answer (call-with-input-file
input
(lambda (in)
(do ((x (read in) (read in))
(answer '() x))
((eof-object? x)
answer)))))
(benchmark-name
(string-append "parsing:" input ":" (number->string n))))
(run-benchmark benchmark-name
n
(lambda (x) (equal? x answer))
(lambda (input-string)
(lambda () (parse-string input-string)))
input-string)))
(define (read-from-string-port-benchmark . rest)
(let* ((n (if (null? rest) 1000 (car rest)))
(input (if (or (null? rest) (null? (cdr rest)))
"nboyer.sch"
(cadr rest)))
(input-string (read-file-as-string input))
(answer (call-with-input-file
input
(lambda (in)
(do ((x (read in) (read in))
(answer '() x))
((eof-object? x)
answer)))))
(benchmark-name
(string-append "reading:" input ":" (number->string n))))
(run-benchmark benchmark-name
n
(lambda ()
(let ((in (open-input-string input-string)))
(do ((x (read in) (read in))
(y #f x))
((eof-object? x) y))))
(lambda (x) (equal? x answer)))))
(define (read-file-as-string name)
(call-with-input-file
name
(lambda (in)
(do ((x (read-char in) (read-char in))
(chars '() (cons x chars)))
((eof-object? x)
(list->string (reverse chars)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The parser used for benchmarking.
;
; Given a string containing Scheme code, parses the entire
; string and returns the last <datum> read from the string.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (parse-string input-string)
; Constants and local variables.
(let* (; Constants.
; Any character that doesn't appear within nboyer.sch
; (or the input file, if different) can be used to
; represent end-of-file.
(eof #\~)
; length of longest token allowed
; (this allows static allocation in C)
(max_token_size 1024)
; Encodings of error messages.
(errLongToken 1) ; extremely long token
(errincompletetoken 2) ; any lexical error, really
(errLexGenBug 3) ; can't happen
; State for one-token buffering in lexical analyzer.
(kindOfNextToken 'z1) ; valid iff nextTokenIsReady
(nextTokenIsReady #f)
(tokenValue "") ; string associated with current token
(totalErrors 0) ; errors so far
(lineNumber 1) ; rudimentary source code location
(lineNumberOfLastError 0) ; ditto
; A string buffer for the characters of the current token.
(string_accumulator (make-string max_token_size))
; Number of characters in string_accumulator.
(string_accumulator_length 0)
; A single character of buffering.
; nextCharacter is valid iff nextCharacterIsReady
(nextCharacter #\space)
(nextCharacterIsReady #f)
; Index of next character to be read from input-string.
(input-index 0)
(input-length (string-length input-string))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; LexGen generated the code for the state machine.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (scanner0)
(let loop ((c (scanchar)))
(if (char-whitespace? c)
(begin
(consumechar)
(set! string_accumulator_length 0)
(loop (scanchar)))))
(let ((c (scanchar)))
(if (char=? c eof) (accept 'eof) (state0 c))))
(define (state0 c)
(case c
((#\`) (consumechar) (accept 'backquote))
((#\') (consumechar) (accept 'quote))
((#\)) (consumechar) (accept 'rparen))
((#\() (consumechar) (accept 'lparen))
((#\;) (consumechar) (state29 (scanchar)))
((#\+ #\-) (consumechar) (state28 (scanchar)))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state27 (scanchar)))
((#\.) (consumechar) (state16 (scanchar)))
((#\a
#\b
#\c
#\d
#\e
#\f
#\g
#\h
#\i
#\j
#\k
#\l
#\m
#\n
#\o
#\p
#\q
#\r
#\s
#\t
#\u
#\v
#\w
#\x
#\y
#\z
#\A
#\B
#\C
#\D
#\E
#\F
#\G
#\H
#\I
#\J
#\K
#\L
#\M
#\N
#\O
#\P
#\Q
#\R
#\S
#\T
#\U
#\V
#\W
#\X
#\Y
#\Z
#\!
#\$
#\%
#\&
#\*
#\/
#\:
#\<
#\=
#\>
#\?
#\^
#\_
#\~)
(consumechar)
(state14 (scanchar)))
((#\#) (consumechar) (state13 (scanchar)))
((#\") (consumechar) (state2 (scanchar)))
((#\,) (consumechar) (state1 (scanchar)))
(else
(if (char-whitespace? c)
(begin (consumechar) (state30 (scanchar)))
(scannererror errincompletetoken)))))
(define (state1 c)
(case c
((#\@) (consumechar) (accept 'splicing))
(else (accept 'comma))))
(define (state2 c)
(case c
((#\") (consumechar) (accept 'string))
(else
(if (isnotdoublequote? c)
(begin (consumechar) (state2 (scanchar)))
(scannererror errincompletetoken)))))
(define (state3 c)
(case c
((#\n) (consumechar) (state8 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state4 c)
(case c
((#\i) (consumechar) (state3 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state5 c)
(case c
((#\l) (consumechar) (state4 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state6 c)
(case c
((#\w) (consumechar) (state5 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state7 c)
(case c
((#\e) (consumechar) (state6 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state8 c)
(case c
((#\e) (consumechar) (accept 'character))
(else (scannererror errincompletetoken))))
(define (state9 c)
(case c
((#\c) (consumechar) (state8 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state10 c)
(case c
((#\a) (consumechar) (state9 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state11 c)
(case c
((#\p) (consumechar) (state10 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state12 c)
(case c
((#\s) (consumechar) (state11 (scanchar)))
((#\n) (consumechar) (state7 (scanchar)))
(else
(if (char? c)
(begin (consumechar) (accept 'character))
(scannererror errincompletetoken)))))
(define (state13 c)
(case c
((#\() (consumechar) (accept 'vecstart))
((#\t #\f) (consumechar) (accept 'boolean))
((#\\) (consumechar) (state12 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state14 c)
(case c
((#\a
#\b
#\c
#\d
#\e
#\f
#\g
#\h
#\i
#\j
#\k
#\l
#\m
#\n
#\o
#\p
#\q
#\r
#\s
#\t
#\u
#\v
#\w
#\x
#\y
#\z
#\A
#\B
#\C
#\D
#\E
#\F
#\G
#\H
#\I
#\J
#\K
#\L
#\M
#\N
#\O
#\P
#\Q
#\R
#\S
#\T
#\U
#\V
#\W
#\X
#\Y
#\Z
#\!
#\$
#\%
#\&
#\*
#\/
#\:
#\<
#\=
#\>
#\?
#\^
#\_
#\~
#\0
#\1
#\2
#\3
#\4
#\5
#\6
#\7
#\8
#\9
#\+
#\-
#\.
#\@)
(consumechar)
(state14 (scanchar)))
(else (accept 'id))))
(define (state15 c)
(case c
((#\.) (consumechar) (accept 'id))
(else (scannererror errincompletetoken))))
(define (state16 c)
(case c
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state18 (scanchar)))
((#\.) (consumechar) (state15 (scanchar)))
(else (accept 'period))))
(define (state17 c)
(case c
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state18 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state18 c)
(case c
((#\e #\s #\f #\d #\l)
(consumechar)
(state22 (scanchar)))
((#\#) (consumechar) (state19 (scanchar)))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state18 (scanchar)))
(else (accept 'number))))
(define (state19 c)
(case c
((#\e #\s #\f #\d #\l)
(consumechar)
(state22 (scanchar)))
((#\#) (consumechar) (state19 (scanchar)))
(else (accept 'number))))
(define (state20 c)
(case c
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state20 (scanchar)))
(else (accept 'number))))
(define (state21 c)
(case c
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state20 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state22 c)
(case c
((#\+ #\-) (consumechar) (state21 (scanchar)))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state20 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state23 c)
(case c
((#\#) (consumechar) (state23 (scanchar)))
(else (accept 'number))))
(define (state24 c)
(case c
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state24 (scanchar)))
((#\#) (consumechar) (state23 (scanchar)))
(else (accept 'number))))
(define (state25 c)
(case c
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state24 (scanchar)))
(else (scannererror errincompletetoken))))
(define (state26 c)
(case c
((#\#) (consumechar) (state26 (scanchar)))
((#\/) (consumechar) (state25 (scanchar)))
((#\e #\s #\f #\d #\l)
(consumechar)
(state22 (scanchar)))
((#\.) (consumechar) (state19 (scanchar)))
(else (accept 'number))))
(define (state27 c)
(case c
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state27 (scanchar)))
((#\#) (consumechar) (state26 (scanchar)))
((#\/) (consumechar) (state25 (scanchar)))
((#\e #\s #\f #\d #\l)
(consumechar)
(state22 (scanchar)))
((#\.) (consumechar) (state18 (scanchar)))
(else (accept 'number))))
(define (state28 c)
(case c
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(consumechar)
(state27 (scanchar)))
((#\.) (consumechar) (state17 (scanchar)))
(else (accept 'id))))
(define (state29 c)
(case c
((#\newline)
(consumechar)
(begin
(set! string_accumulator_length 0)
(state0 (scanchar))))
(else
(if (isnotnewline? c)
(begin (consumechar) (state29 (scanchar)))
(scannererror errincompletetoken)))))
(define (state30 c)
(case c
(else
(if (char-whitespace? c)
(begin (consumechar) (state30 (scanchar)))
(begin
(set! string_accumulator_length 0)
(state0 (scanchar)))))))
(define (state31 c)
(case c
(else
(begin
(set! string_accumulator_length 0)
(state0 (scanchar))))))
(define (state32 c) (case c (else (accept 'id))))
(define (state33 c)
(case c (else (accept 'boolean))))
(define (state34 c)
(case c (else (accept 'character))))
(define (state35 c)
(case c (else (accept 'vecstart))))
(define (state36 c)
(case c (else (accept 'string))))
(define (state37 c)
(case c (else (accept 'lparen))))
(define (state38 c)
(case c (else (accept 'rparen))))
(define (state39 c)
(case c (else (accept 'quote))))
(define (state40 c)
(case c (else (accept 'backquote))))
(define (state41 c)
(case c (else (accept 'splicing))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; End of state machine generated by LexGen.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; ParseGen generated the code for the strong LL(1) parser.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (parse-datum)
(case (next-token)
((splicing comma backquote quote lparen vecstart)
(let ((ast1 (parse-compound-datum)))
(identity ast1)))
((boolean number character string id)
(let ((ast1 (parse-simple-datum)))
(identity ast1)))
(else
(parse-error
'<datum>
'(backquote
boolean
character
comma
id
lparen
number
quote
splicing
string
vecstart)))))
(define (parse-simple-datum)
(case (next-token)
((id)
(let ((ast1 (parse-symbol))) (identity ast1)))
((string) (begin (consume-token!) (makeString)))
((character) (begin (consume-token!) (makeChar)))
((number) (begin (consume-token!) (makeNum)))
((boolean) (begin (consume-token!) (makeBool)))
(else
(parse-error
'<simple-datum>
'(boolean character id number string)))))
(define (parse-symbol)
(case (next-token)
((id) (begin (consume-token!) (makeSym)))
(else (parse-error '<symbol> '(id)))))
(define (parse-compound-datum)
(case (next-token)
((vecstart)
(let ((ast1 (parse-vector))) (identity ast1)))
((lparen quote backquote comma splicing)
(let ((ast1 (parse-list))) (identity ast1)))
(else
(parse-error
'<compound-datum>
'(backquote comma lparen quote splicing vecstart)))))
(define (parse-list)
(case (next-token)
((splicing comma backquote quote)
(let ((ast1 (parse-abbreviation)))
(identity ast1)))
((lparen)
(begin
(consume-token!)
(let ((ast1 (parse-list2))) (identity ast1))))
(else
(parse-error
'<list>
'(backquote comma lparen quote splicing)))))
(define (parse-list2)
(case (next-token)
((id string
character
number
boolean
vecstart
lparen
quote
backquote
comma
splicing)
(let ((ast1 (parse-datum)))
(let ((ast2 (parse-list3))) (cons ast1 ast2))))
((rparen) (begin (consume-token!) (emptyList)))
(else
(parse-error
'<list2>
'(backquote
boolean
character
comma
id
lparen
number
quote
rparen
splicing
string
vecstart)))))
(define (parse-list3)
(case (next-token)
((rparen
period
splicing
comma
backquote
quote
lparen
vecstart
boolean
number
character
string
id)
(let ((ast1 (parse-data)))
(let ((ast2 (parse-list4)))
(pseudoAppend ast1 ast2))))
(else
(parse-error
'<list3>
'(backquote
boolean
character
comma
id
lparen
number
period
quote
rparen
splicing
string
vecstart)))))
(define (parse-list4)
(case (next-token)
((period)
(begin
(consume-token!)
(let ((ast1 (parse-datum)))
(if (eq? (next-token) 'rparen)
(begin (consume-token!) (identity ast1))
(parse-error '<list4> '(rparen))))))
((rparen) (begin (consume-token!) (emptyList)))
(else (parse-error '<list4> '(period rparen)))))
(define (parse-abbreviation)
(case (next-token)
((quote backquote comma splicing)
(let ((ast1 (parse-abbrev-prefix)))
(let ((ast2 (parse-datum))) (list ast1 ast2))))
(else
(parse-error
'<abbreviation>
'(backquote comma quote splicing)))))
(define (parse-abbrev-prefix)
(case (next-token)
((splicing)
(begin (consume-token!) (symSplicing)))
((comma) (begin (consume-token!) (symUnquote)))
((backquote)
(begin (consume-token!) (symBackquote)))
((quote) (begin (consume-token!) (symQuote)))
(else
(parse-error
'<abbrev-prefix>
'(backquote comma quote splicing)))))
(define (parse-vector)
(case (next-token)
((vecstart)
(begin
(consume-token!)
(let ((ast1 (parse-data)))
(if (eq? (next-token) 'rparen)
(begin (consume-token!) (list2vector ast1))
(parse-error '<vector> '(rparen))))))
(else (parse-error '<vector> '(vecstart)))))
(define (parse-data)
(case (next-token)
((id string
character
number
boolean
vecstart
lparen
quote
backquote
comma
splicing)
(let ((ast1 (parse-datum)))
(let ((ast2 (parse-data))) (cons ast1 ast2))))
((rparen period) (emptyList))
(else
(parse-error
'<data>
'(backquote
boolean
character
comma
id
lparen
number
period
quote
rparen
splicing
string
vecstart)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; End of LL(1) parser generated by ParseGen.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Help predicates used by the lexical analyzer's state machine.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (isnotdoublequote? c) (not (char=? c #\")))
(define (isnotnewline? c) (not (char=? c #\newline)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Lexical analyzer.
;
; This code is adapted from the quirk23 lexical analyzer written
; by Will Clinger for a compiler course.
;
; The scanner and parser were generated automatically and then
; printed using an R5RS Scheme pretty-printer, so they do not
; preserve case. In preparation for the case-sensitivity of
; R6RS Scheme, several identifiers and constants have been
; lower-cased in the hand-written code to match the generated
; code.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; next-token and consume-token! are called by the parser.
; Returns the current token.
(define (next-token)
(if nextTokenIsReady
kindOfNextToken
(begin (set! string_accumulator_length 0)
(scanner0))))
; Consumes the current token.
(define (consume-token!)
(set! nextTokenIsReady #f))
; Called by the lexical analyzer's state machine,
; hence the unfortunate lower case.
(define (scannererror msg)
(define msgtxt
(cond ((= msg errLongToken)
"Amazingly long token")
((= msg errincompletetoken)
"in line ")
((= msg errLexGenBug)
"Bug in lexical analyzer (generated)")
(else "Bug in lexical analyzer")))
(fatal-error (string-append "Lexical Error: " msgtxt) lineNumber)
(set! nextTokenIsReady #f)
(set! nextCharacterIsReady #f)
(next-token))
; Accepts a token of the given kind, returning that kind.
;
; For some kinds of tokens, a value for the token must also be
; recorded in tokenValue.
(define (accept t)
(if (memq t '(boolean character id number string))
(set! tokenValue
(substring string_accumulator 0 string_accumulator_length)))
(set! kindOfNextToken t)
(set! nextTokenIsReady #t)
t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Character i/o, so to speak.
; Uses the input-string as input.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Returns the current character from the input.
(define (scanchar)
(if nextCharacterIsReady
nextCharacter
(begin (if (< input-index input-length)
(begin (set! nextCharacter
(string-ref input-string input-index))
(set! input-index (+ input-index 1)))
(set! nextCharacter eof))
(set! nextCharacterIsReady #t)
; For debugging, change #f to #t below.
(if #f
(write-char nextCharacter))
(scanchar))))
; Consumes the current character, and returns the next.
(define (consumechar)
(if (not nextCharacterIsReady)
(scanchar))
(if (< string_accumulator_length max_token_size)
(begin (set! nextCharacterIsReady #f)
(if (char=? nextCharacter #\newline)
(set! lineNumber (+ lineNumber 1)))
(string-set! string_accumulator
string_accumulator_length
nextCharacter)
(set! string_accumulator_length
(+ string_accumulator_length 1)))
(scannererror errLongToken)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Action procedures called by the parser.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (emptyList) '())
(define (identity x) x)
(define (list2vector vals) (list->vector vals))
(define (makeBool)
(string=? tokenValue "#t"))
(define (makeChar)
(string-ref tokenValue 0))
(define (makeNum)
(string->number tokenValue))
(define (makeString)
; Must strip off outer double quotes.
; Ought to process escape characters also, but we won't.
(substring tokenValue 1 (- (string-length tokenValue) 1)))
(define (makeSym)
(string->symbol tokenValue))
; Like append, but allows the last argument to be a non-list.
(define (pseudoAppend vals terminus)
(if (null? vals)
terminus
(cons (car vals)
(pseudoAppend (cdr vals) terminus))))
(define (symBackquote) 'quasiquote)
(define (symQuote) 'quote)
(define (symSplicing) 'unquote-splicing)
(define (symUnquote) 'unquote)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Error procedure called by the parser.
; As a hack, this error procedure recovers from end-of-file.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (parse-error nonterminal expected-terminals)
(if (eq? 'eof (next-token))
'eof
(begin
(display "Syntax error in line ")
(display lineNumber)
(display " while parsing a ")
(write nonterminal)
(newline)
(display " Encountered a ")
(display (next-token))
(display " while expecting something in")
(newline)
(display " ")
(write expected-terminals)
(newline)
(fatal-error "Syntax error"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Parses repeatedly, returning the last <datum> parsed.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(do ((x (parse-datum) (parse-datum))
(y 'eof x))
((eq? x 'eof)
y))))
(define (main . args)
(parsing-benchmark parsing-iters "r6rs-benchmarks/parsing-test.sch")))

115
benchmarks/new/r6rs-benchmarks/perm9.ss Normal file
View File

@ -0,0 +1,115 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: perm9.sch
; Description: memory system benchmark using Zaks's permutation generator
; Author: Lars Hansen, Will Clinger, and Gene Luks
; Created: 18-Mar-94
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 940720 / lth Added some more benchmarks for the thesis paper.
; 970215 / wdc Increased problem size from 8 to 9; improved tenperm9-benchmark.
; 970531 / wdc Cleaned up for public release.
; 981116 / wdc Simplified to fit in with Feeley's benchmark suite.
; The perm9 benchmark generates a list of all 362880 permutations of
; the first 9 integers, allocating 1349288 pairs (typically 10,794,304
; bytes), all of which goes into the generated list. (That is, the
; perm9 benchmark generates absolutely no garbage.) This represents
; a savings of about 63% over the storage that would be required by
; an unshared list of permutations. The generated permutations are
; in order of a grey code that bears no obvious relationship to a
; lexicographic order.
;
; The 10perm9 benchmark repeats the perm9 benchmark 10 times, so it
; allocates and reclaims 13492880 pairs (typically 107,943,040 bytes).
; The live storage peaks at twice the storage that is allocated by the
; perm9 benchmark. At the end of each iteration, the oldest half of
; the live storage becomes garbage. Object lifetimes are distributed
; uniformly between 10.3 and 20.6 megabytes.
; Date: Thu, 17 Mar 94 19:43:32 -0800
; From: luks@sisters.cs.uoregon.edu
; To: will
; Subject: Pancake flips
(library (r6rs-benchmarks perm9)
(export main)
(import (r6rs) (r6rs-benchmarks))
; Procedure P_n generates a grey code of all perms of n elements
; on top of stack ending with reversal of starting sequence
;
; F_n is flip of top n elements.
;
;
; procedure P_n
;
; if n>1 then
; begin
; repeat P_{n-1},F_n n-1 times;
; P_{n-1}
; end
;
(define (permutations x)
(let ((x x)
(perms (list x)))
(define (P n)
(if (> n 1)
(do ((j (- n 1) (- j 1)))
((zero? j)
(P (- n 1)))
(P (- n 1))
(F n))))
(define (F n)
(set! x (revloop x n (list-tail x n)))
(set! perms (cons x perms)))
(define (revloop x n y)
(if (zero? n)
y
(revloop (cdr x)
(- n 1)
(cons (car x) y))))
(define (list-tail x n)
(if (zero? n)
x
(list-tail (cdr x) (- n 1))))
(P (length x))
perms))
; Given a list of lists of numbers, returns the sum of the sums
; of those lists.
;
; for (; x != NULL; x = x->rest)
; for (y = x->first; y != NULL; y = y->rest)
; sum = sum + y->first;
(define (sumlists x)
(do ((x x (cdr x))
(sum 0 (do ((y (car x) (cdr y))
(sum sum (+ sum (car y))))
((null? y) sum))))
((null? x) sum)))
(define (one..n n)
(do ((n n (- n 1))
(p '() (cons n p)))
((zero? n) p)))
(define (main . args)
(let ((n 9))
(define (factorial n)
(if (zero? n)
1
(* n (factorial (- n 1)))))
(run-benchmark
(string-append "perm" (number->string n))
perm9-iters
(lambda (result)
(= (sumlists result)
(* (quotient (* n (+ n 1)) 2) (factorial n))))
(lambda (lst)
(lambda ()
(permutations lst)))
(one..n n)))))

643
benchmarks/new/r6rs-benchmarks/peval.ss Normal file
View File

@ -0,0 +1,643 @@
;;; PEVAL -- A simple partial evaluator for Scheme, written by Marc Feeley.
(library (r6rs-benchmarks peval)
(export main)
(import (r6rs) (r6rs mutable-pairs) (r6rs-benchmarks))
;------------------------------------------------------------------------------
; Utilities
(define (every? pred? l)
(let loop ((l l))
(or (null? l) (and (pred? (car l)) (loop (cdr l))))))
(define (some? pred? l)
(let loop ((l l))
(if (null? l) #f (or (pred? (car l)) (loop (cdr l))))))
(define (map2 f l1 l2)
(let loop ((l1 l1) (l2 l2))
(if (pair? l1)
(cons (f (car l1) (car l2)) (loop (cdr l1) (cdr l2)))
'())))
(define (get-last-pair l)
(let loop ((l l))
(let ((x (cdr l))) (if (pair? x) (loop x) l))))
;------------------------------------------------------------------------------
;
; The partial evaluator.
(define (partial-evaluate proc args)
(peval (alphatize proc '()) args))
(define (alphatize exp env) ; return a copy of 'exp' where each bound var has
(define (alpha exp) ; been renamed (to prevent aliasing problems)
(cond ((const-expr? exp)
(quot (const-value exp)))
((symbol? exp)
(let ((x (assq exp env))) (if x (cdr x) exp)))
((or (eq? (car exp) 'if) (eq? (car exp) 'begin))
(cons (car exp) (map alpha (cdr exp))))
((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
(let ((new-env (new-variables (map car (cadr exp)) env)))
(list (car exp)
(map (lambda (x)
(list (cdr (assq (car x) new-env))
(if (eq? (car exp) 'let)
(alpha (cadr x))
(alphatize (cadr x) new-env))))
(cadr exp))
(alphatize (caddr exp) new-env))))
((eq? (car exp) 'lambda)
(let ((new-env (new-variables (cadr exp) env)))
(list 'lambda
(map (lambda (x) (cdr (assq x new-env))) (cadr exp))
(alphatize (caddr exp) new-env))))
(else
(map alpha exp))))
(alpha exp))
(define (const-expr? expr) ; is 'expr' a constant expression?
(and (not (symbol? expr))
(or (not (pair? expr))
(eq? (car expr) 'quote))))
(define (const-value expr) ; return the value of a constant expression
(if (pair? expr) ; then it must be a quoted constant
(cadr expr)
expr))
(define (quot val) ; make a quoted constant whose value is 'val'
(list 'quote val))
(define (new-variables parms env)
(append (map (lambda (x) (cons x (new-variable x))) parms) env))
(define *current-num* 0)
(define (new-variable name)
(set! *current-num* (+ *current-num* 1))
(string->symbol
(string-append (symbol->string name)
"_"
(number->string *current-num*))))
;------------------------------------------------------------------------------
;
; (peval proc args) will transform a procedure that is known to be called
; with constants as some of its arguments into a specialized procedure that
; is 'equivalent' but accepts only the non-constant parameters. 'proc' is the
; list representation of a lambda-expression and 'args' is a list of values,
; one for each parameter of the lambda-expression. A special value (i.e.
; 'not-constant') is used to indicate an argument that is not a constant.
; The returned procedure is one that has as parameters the parameters of the
; original procedure which are NOT passed constants. Constants will have been
; substituted for the constant parameters that are referenced in the body
; of the procedure.
;
; For example:
;
; (peval
; '(lambda (x y z) (f z x y)) ; the procedure
; (list 1 not-constant #t)) ; the knowledge about x, y and z
;
; will return: (lambda (y) (f '#t '1 y))
(define (peval proc args)
(simplify!
(let ((parms (cadr proc)) ; get the parameter list
(body (caddr proc))) ; get the body of the procedure
(list 'lambda
(remove-constant parms args) ; remove the constant parameters
(beta-subst ; in the body, replace variable refs to the constant
body ; parameters by the corresponding constant
(map2 (lambda (x y) (if (not-constant? y) '(()) (cons x (quot y))))
parms
args))))))
(define not-constant (list '?)) ; special value indicating non-constant parms.
(define (not-constant? x) (eq? x not-constant))
(define (remove-constant l a) ; remove from list 'l' all elements whose
(cond ((null? l) ; corresponding element in 'a' is a constant
'())
((not-constant? (car a))
(cons (car l) (remove-constant (cdr l) (cdr a))))
(else
(remove-constant (cdr l) (cdr a)))))
(define (extract-constant l a) ; extract from list 'l' all elements whose
(cond ((null? l) ; corresponding element in 'a' is a constant
'())
((not-constant? (car a))
(extract-constant (cdr l) (cdr a)))
(else
(cons (car l) (extract-constant (cdr l) (cdr a))))))
(define (beta-subst exp env) ; return a modified 'exp' where each var named in
(define (bs exp) ; 'env' is replaced by the corresponding expr (it
(cond ((const-expr? exp) ; is assumed that the code has been alphatized)
(quot (const-value exp)))
((symbol? exp)
(let ((x (assq exp env)))
(if x (cdr x) exp)))
((or (eq? (car exp) 'if) (eq? (car exp) 'begin))
(cons (car exp) (map bs (cdr exp))))
((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
(list (car exp)
(map (lambda (x) (list (car x) (bs (cadr x)))) (cadr exp))
(bs (caddr exp))))
((eq? (car exp) 'lambda)
(list 'lambda
(cadr exp)
(bs (caddr exp))))
(else
(map bs exp))))
(bs exp))
;------------------------------------------------------------------------------
;
; The expression simplifier.
(define (simplify! exp) ; simplify the expression 'exp' destructively (it
; is assumed that the code has been alphatized)
(define (simp! where env)
(define (s! where)
(let ((exp (car where)))
(cond ((const-expr? exp)) ; leave constants the way they are
((symbol? exp)) ; leave variable references the way they are
((eq? (car exp) 'if) ; dead code removal for conditionals
(s! (cdr exp)) ; simplify the predicate
(if (const-expr? (cadr exp)) ; is the predicate a constant?
(begin
(set-car! where
(if (memq (const-value (cadr exp)) '(#f ())) ; false?
(if (= (length exp) 3) ''() (cadddr exp))
(caddr exp)))
(s! where))
(for-each! s! (cddr exp)))) ; simplify consequent and alt.
((eq? (car exp) 'begin)
(for-each! s! (cdr exp))
(let loop ((exps exp)) ; remove all useless expressions
(if (not (null? (cddr exps))) ; not last expression?
(let ((x (cadr exps)))
(loop (if (or (const-expr? x)
(symbol? x)
(and (pair? x) (eq? (car x) 'lambda)))
(begin (set-cdr! exps (cddr exps)) exps)
(cdr exps))))))
(if (null? (cddr exp)) ; only one expression in the begin?
(set-car! where (cadr exp))))
((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
(let ((new-env (cons exp env)))
(define (keep i)
(if (>= i (length (cadar where)))
'()
(let* ((var (car (list-ref (cadar where) i)))
(val (cadr (assq var (cadar where))))
(refs (ref-count (car where) var))
(self-refs (ref-count val var))
(total-refs (- (car refs) (car self-refs)))
(oper-refs (- (cadr refs) (cadr self-refs))))
(cond ((= total-refs 0)
(keep (+ i 1)))
((or (const-expr? val)
(symbol? val)
(and (pair? val)
(eq? (car val) 'lambda)
(= total-refs 1)
(= oper-refs 1)
(= (car self-refs) 0))
(and (caddr refs)
(= total-refs 1)))
(set-car! where
(beta-subst (car where)
(list (cons var val))))
(keep (+ i 1)))
(else
(cons var (keep (+ i 1))))))))
(simp! (cddr exp) new-env)
(for-each! (lambda (x) (simp! (cdar x) new-env)) (cadr exp))
(let ((to-keep (keep 0)))
(if (< (length to-keep) (length (cadar where)))
(begin
(if (null? to-keep)
(set-car! where (caddar where))
(set-car! (cdar where)
(map (lambda (v) (assq v (cadar where))) to-keep)))
(s! where))
(if (null? to-keep)
(set-car! where (caddar where)))))))
((eq? (car exp) 'lambda)
(simp! (cddr exp) (cons exp env)))
(else
(for-each! s! exp)
(cond ((symbol? (car exp)) ; is the operator position a var ref?
(let ((frame (binding-frame (car exp) env)))
(if frame ; is it a bound variable?
(let ((proc (bound-expr (car exp) frame)))
(if (and (pair? proc)
(eq? (car proc) 'lambda)
(some? const-expr? (cdr exp)))
(let* ((args (arg-pattern (cdr exp)))
(new-proc (peval proc args))
(new-args (remove-constant (cdr exp) args)))
(set-car! where
(cons (add-binding new-proc frame (car exp))
new-args)))))
(set-car! where
(constant-fold-global (car exp) (cdr exp))))))
((not (pair? (car exp))))
((eq? (caar exp) 'lambda)
(set-car! where
(list 'let
(map2 list (cadar exp) (cdr exp))
(caddar exp)))
(s! where)))))))
(s! where))
(define (remove-empty-calls! where env)
(define (rec! where)
(let ((exp (car where)))
(cond ((const-expr? exp))
((symbol? exp))
((eq? (car exp) 'if)
(rec! (cdr exp))
(rec! (cddr exp))
(rec! (cdddr exp)))
((eq? (car exp) 'begin)
(for-each! rec! (cdr exp)))
((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
(let ((new-env (cons exp env)))
(remove-empty-calls! (cddr exp) new-env)
(for-each! (lambda (x) (remove-empty-calls! (cdar x) new-env))
(cadr exp))))
((eq? (car exp) 'lambda)
(rec! (cddr exp)))
(else
(for-each! rec! (cdr exp))
(if (and (null? (cdr exp)) (symbol? (car exp)))
(let ((frame (binding-frame (car exp) env)))
(if frame ; is it a bound variable?
(let ((proc (bound-expr (car exp) frame)))
(if (and (pair? proc)
(eq? (car proc) 'lambda))
(begin
(set! changed? #t)
(set-car! where (caddr proc))))))))))))
(rec! where))
(define changed? #f)
(let ((x (list exp)))
(let loop ()
(set! changed? #f)
(simp! x '())
(remove-empty-calls! x '())
(if changed? (loop) (car x)))))
(define (ref-count exp var) ; compute how many references to variable 'var'
(let ((total 0) ; are contained in 'exp'
(oper 0)
(always-evaled #t))
(define (rc exp ae)
(cond ((const-expr? exp))
((symbol? exp)
(if (eq? exp var)
(begin
(set! total (+ total 1))
(set! always-evaled (and ae always-evaled)))))
((eq? (car exp) 'if)
(rc (cadr exp) ae)
(for-each (lambda (x) (rc x #f)) (cddr exp)))
((eq? (car exp) 'begin)
(for-each (lambda (x) (rc x ae)) (cdr exp)))
((or (eq? (car exp) 'let) (eq? (car exp) 'letrec))
(for-each (lambda (x) (rc (cadr x) ae)) (cadr exp))
(rc (caddr exp) ae))
((eq? (car exp) 'lambda)
(rc (caddr exp) #f))
(else
(for-each (lambda (x) (rc x ae)) exp)
(if (symbol? (car exp))
(if (eq? (car exp) var) (set! oper (+ oper 1)))))))
(rc exp #t)
(list total oper always-evaled)))
(define (binding-frame var env)
(cond ((null? env) #f)
((or (eq? (caar env) 'let) (eq? (caar env) 'letrec))
(if (assq var (cadar env)) (car env) (binding-frame var (cdr env))))
((eq? (caar env) 'lambda)
(if (memq var (cadar env)) (car env) (binding-frame var (cdr env))))
(else
(fatal-error "ill-formed environment"))))
(define (bound-expr var frame)
(cond ((or (eq? (car frame) 'let) (eq? (car frame) 'letrec))
(cadr (assq var (cadr frame))))
((eq? (car frame) 'lambda)
not-constant)
(else
(fatal-error "ill-formed frame"))))
(define (add-binding val frame name)
(define (find-val val bindings)
(cond ((null? bindings) #f)
((equal? val (cadar bindings)) ; *kludge* equal? is not exactly what
(caar bindings)) ; we want...
(else
(find-val val (cdr bindings)))))
(or (find-val val (cadr frame))
(let ((var (new-variable name)))
(set-cdr! (get-last-pair (cadr frame)) (list (list var val)))
var)))
(define (for-each! proc! l) ; call proc! on each CONS CELL in the list 'l'
(if (not (null? l))
(begin (proc! l) (for-each! proc! (cdr l)))))
(define (arg-pattern exps) ; return the argument pattern (i.e. the list of
(if (null? exps) ; constants in 'exps' but with the not-constant
'() ; value wherever the corresponding expression in
(cons (if (const-expr? (car exps)) ; 'exps' is not a constant)
(const-value (car exps))
not-constant)
(arg-pattern (cdr exps)))))
;------------------------------------------------------------------------------
;
; Knowledge about primitive procedures.
(define *primitives*
(list
(cons 'car (lambda (args)
(and (= (length args) 1)
(pair? (car args))
(quot (car (car args))))))
(cons 'cdr (lambda (args)
(and (= (length args) 1)
(pair? (car args))
(quot (cdr (car args))))))
(cons '+ (lambda (args)
(and (every? number? args)
(quot (sum args 0)))))
(cons '* (lambda (args)
(and (every? number? args)
(quot (product args 1)))))
(cons '- (lambda (args)
(and (> (length args) 0)
(every? number? args)
(quot (if (null? (cdr args))
(- (car args))
(- (car args) (sum (cdr args) 0)))))))
(cons '/ (lambda (args)
(and (> (length args) 1)
(every? number? args)
(quot (if (null? (cdr args))
(/ (car args))
(/ (car args) (product (cdr args) 1)))))))
(cons '< (lambda (args)
(and (= (length args) 2)
(every? number? args)
(quot (< (car args) (cadr args))))))
(cons '= (lambda (args)
(and (= (length args) 2)
(every? number? args)
(quot (= (car args) (cadr args))))))
(cons '> (lambda (args)
(and (= (length args) 2)
(every? number? args)
(quot (> (car args) (cadr args))))))
(cons 'eq? (lambda (args)
(and (= (length args) 2)
(quot (eq? (car args) (cadr args))))))
(cons 'not (lambda (args)
(and (= (length args) 1)
(quot (not (car args))))))
(cons 'null? (lambda (args)
(and (= (length args) 1)
(quot (null? (car args))))))
(cons 'pair? (lambda (args)
(and (= (length args) 1)
(quot (pair? (car args))))))
(cons 'symbol? (lambda (args)
(and (= (length args) 1)
(quot (symbol? (car args))))))
)
)
(define (sum lst n)
(if (null? lst)
n
(sum (cdr lst) (+ n (car lst)))))
(define (product lst n)
(if (null? lst)
n
(product (cdr lst) (* n (car lst)))))
(define (reduce-global name args)
(let ((x (assq name *primitives*)))
(and x ((cdr x) args))))
(define (constant-fold-global name exprs)
(define (flatten args op)
(cond ((null? args)
'())
((and (pair? (car args)) (eq? (caar args) op))
(append (flatten (cdar args) op) (flatten (cdr args) op)))
(else
(cons (car args) (flatten (cdr args) op)))))
(let ((args (if (or (eq? name '+) (eq? name '*)) ; associative ops
(flatten exprs name)
exprs)))
(or (and (every? const-expr? args)
(reduce-global name (map const-value args)))
(let ((pattern (arg-pattern args)))
(let ((non-const (remove-constant args pattern))
(const (map const-value (extract-constant args pattern))))
(cond ((eq? name '+) ; + is commutative
(let ((x (reduce-global '+ const)))
(if x
(let ((y (const-value x)))
(cons '+
(if (= y 0) non-const (cons x non-const))))
(cons name args))))
((eq? name '*) ; * is commutative
(let ((x (reduce-global '* const)))
(if x
(let ((y (const-value x)))
(cons '*
(if (= y 1) non-const (cons x non-const))))
(cons name args))))
((eq? name 'cons)
(cond ((and (const-expr? (cadr args))
(null? (const-value (cadr args))))
(list 'list (car args)))
((and (pair? (cadr args))
(eq? (car (cadr args)) 'list))
(cons 'list (cons (car args) (cdr (cadr args)))))
(else
(cons name args))))
(else
(cons name args))))))))
;------------------------------------------------------------------------------
;
; Examples:
(define (try-peval proc args)
(partial-evaluate proc args))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example1
'(lambda (a b c)
(if (null? a) b (+ (car a) c))))
;(try-peval example1 (list '(10 11) not-constant '1))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example2
'(lambda (x y)
(let ((q (lambda (a b) (if (< a 0) b (- 10 b)))))
(if (< x 0) (q (- y) (- x)) (q y x)))))
;(try-peval example2 (list not-constant '1))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example3
'(lambda (l n)
(letrec ((add-list
(lambda (l n)
(if (null? l)
'()
(cons (+ (car l) n) (add-list (cdr l) n))))))
(add-list l n))))
;(try-peval example3 (list not-constant '1))
;(try-peval example3 (list '(1 2 3) not-constant))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example4
'(lambda (exp env)
(letrec ((eval
(lambda (exp env)
(letrec ((eval-list
(lambda (l env)
(if (null? l)
'()
(cons (eval (car l) env)
(eval-list (cdr l) env))))))
(if (symbol? exp) (lookup exp env)
(if (not (pair? exp)) exp
(if (eq? (car exp) 'quote) (car (cdr exp))
(apply (eval (car exp) env)
(eval-list (cdr exp) env)))))))))
(eval exp env))))
;(try-peval example4 (list 'x not-constant))
;(try-peval example4 (list '(f 1 2 3) not-constant))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example5
'(lambda (a b)
(letrec ((funct
(lambda (x)
(+ x b (if (< x 1) 0 (funct (- x 1)))))))
(funct a))))
;(try-peval example5 (list '5 not-constant))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example6
'(lambda ()
(letrec ((fib
(lambda (x)
(if (< x 2) x (+ (fib (- x 1)) (fib (- x 2)))))))
(fib 10))))
;(try-peval example6 '())
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example7
'(lambda (input)
(letrec ((copy (lambda (in)
(if (pair? in)
(cons (copy (car in))
(copy (cdr in)))
in))))
(copy input))))
;(try-peval example7 (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define example8
'(lambda (input)
(letrec ((reverse (lambda (in result)
(if (pair? in)
(reverse (cdr in) (cons (car in) result))
result))))
(reverse input '()))))
;(try-peval example8 (list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
(define (test)
(set! *current-num* 0)
(list (try-peval example1 (list '(10 11) not-constant '1))
(try-peval example2 (list not-constant '1))
(try-peval example3 (list not-constant '1))
(try-peval example3 (list '(1 2 3) not-constant))
(try-peval example4 (list 'x not-constant))
(try-peval example4 (list '(f 1 2 3) not-constant))
(try-peval example5 (list '5 not-constant))
(try-peval example6 '())
(try-peval
example7
(list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
(try-peval
example8
(list '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))))
(define (main . args)
(run-benchmark
"peval"
peval-iters
(lambda (result)
(and (list? result)
(= (length result) 10)
(equal? (list-ref result 9)
'(lambda ()
(list 'z 'y 'x 'w 'v 'u 't 's 'r 'q 'p 'o 'n
'm 'l 'k 'j 'i 'h 'g 'f 'e 'd 'c 'b 'a)))))
(lambda () (lambda () (test))))))

158
benchmarks/new/r6rs-benchmarks/pi.ss Normal file
View File

@ -0,0 +1,158 @@
;;; PI -- Compute PI using bignums.
; See http://mathworld.wolfram.com/Pi.html for the various algorithms.
(library (r6rs-benchmarks pi)
(export main)
(import (r6rs) (r6rs-benchmarks))
; Utilities.
(define (width x)
(let loop ((i 0) (n 1))
(if (< x n) i (loop (+ i 1) (* n 2)))))
(define (root x y)
(let loop ((g (expt
2
(quotient (+ (width x) (- y 1)) y))))
(let ((a (expt g (- y 1))))
(let ((b (* a y)))
(let ((c (* a (- y 1))))
(let ((d (quotient (+ x (* g c)) b)))
(if (< d g) (loop d) g)))))))
(define (square-root x)
(root x 2))
(define (quartic-root x)
(root x 4))
(define (square x)
(* x x))
; Compute pi using the 'brent-salamin' method.
(define (pi-brent-salamin nb-digits)
(let ((one (expt 10 nb-digits)))
(let loop ((a one)
(b (square-root (quotient (square one) 2)))
(t (quotient one 4))
(x 1))
(if (= a b)
(quotient (square (+ a b)) (* 4 t))
(let ((new-a (quotient (+ a b) 2)))
(loop new-a
(square-root (* a b))
(- t
(quotient
(* x (square (- new-a a)))
one))
(* 2 x)))))))
; Compute pi using the quadratically converging 'borwein' method.
(define (pi-borwein2 nb-digits)
(let* ((one (expt 10 nb-digits))
(one^2 (square one))
(one^4 (square one^2))
(sqrt2 (square-root (* one^2 2)))
(qurt2 (quartic-root (* one^4 2))))
(let loop ((x (quotient
(* one (+ sqrt2 one))
(* 2 qurt2)))
(y qurt2)
(p (+ (* 2 one) sqrt2)))
(let ((new-p (quotient (* p (+ x one))
(+ y one))))
(if (= x one)
new-p
(let ((sqrt-x (square-root (* one x))))
(loop (quotient
(* one (+ x one))
(* 2 sqrt-x))
(quotient
(* one (+ (* x y) one^2))
(* (+ y one) sqrt-x))
new-p)))))))
; Compute pi using the quartically converging 'borwein' method.
(define (pi-borwein4 nb-digits)
(let* ((one (expt 10 nb-digits))
(one^2 (square one))
(one^4 (square one^2))
(sqrt2 (square-root (* one^2 2))))
(let loop ((y (- sqrt2 one))
(a (- (* 6 one) (* 4 sqrt2)))
(x 8))
(if (= y 0)
(quotient one^2 a)
(let* ((t1 (quartic-root (- one^4 (square (square y)))))
(t2 (quotient
(* one (- one t1))
(+ one t1)))
(t3 (quotient
(square (quotient (square (+ one t2)) one))
one))
(t4 (+ one
(+ t2
(quotient (square t2) one)))))
(loop t2
(quotient
(- (* t3 a) (* x (* t2 t4)))
one)
(* 4 x)))))))
; Try it.
(define (pies n m s)
(if (< m n)
'()
(let ((bs (pi-brent-salamin n))
(b2 (pi-borwein2 n))
(b4 (pi-borwein4 n)))
(cons (list b2 (- bs b2) (- b4 b2))
(pies (+ n s) m s)))))
(define expected
'((314159265358979323846264338327950288419716939937507
-54
124)
(31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170673
-51
-417)
(3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408122
-57
-819)
(314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038195
-76
332)
(31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019089
-83
477)
(3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141268
-72
-2981)
(314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536431
-70
-2065)
(31415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019091456485669234603486104543266482133936072602491412737245870066063155881748815209209628292540917153643678925903600113305305488204665213841469519415116089
-79
1687)
(3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701938521105559644622948954930381964428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141273724587006606315588174881520920962829254091715364367892590360011330530548820466521384146951941511609433057270365759591953092186117381932611793105118542
-92
-2728)
(314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536436789259036001133053054882046652138414695194151160943305727036575959195309218611738193261179310511854807446237996274956735188575272489122793818301194907
-76
-3726)))
(define (main . args)
(run-benchmark
"pi"
pi-iters
(lambda (result) (equal? result expected))
(lambda (n m s) (lambda () (pies n m s)))
50
500
50)))

50
benchmarks/new/r6rs-benchmarks/pnpoly.ss Normal file
View File

@ -0,0 +1,50 @@
;;; PNPOLY - Test if a point is contained in a 2D polygon.
(library (r6rs-benchmarks pnpoly)
(export main)
(import (r6rs) (r6rs arithmetic flonums) (r6rs-benchmarks))
(define (pt-in-poly2 xp yp x y)
(let loop ((c #f) (i (- (vector-length xp) 1)) (j 0))
(if (< i 0)
c
(if (or (and (or (fl>? (vector-ref yp i) y)
(fl>=? y (vector-ref yp j)))
(or (fl>? (vector-ref yp j) y)
(fl>=? y (vector-ref yp i))))
(fl>=? x
(fl+ (vector-ref xp i)
(fl/ (fl*
(fl- (vector-ref xp j)
(vector-ref xp i))
(fl- y (vector-ref yp i)))
(fl- (vector-ref yp j)
(vector-ref yp i))))))
(loop c (- i 1) i)
(loop (not c) (- i 1) i)))))
(define (run)
(let ((count 0)
(xp (vector 0. 1. 1. 0. 0. 1. -.5 -1. -1. -2. -2.5 -2. -1.5 -.5 1. 1. 0. -.5 -1. -.5))
(yp (vector 0. 0. 1. 1. 2. 3. 2. 3. 0. -.5 -1. -1.5 -2. -2. -1.5 -1. -.5 -1. -1. -.5)))
(if (pt-in-poly2 xp yp .5 .5) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp .5 1.5) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp -.5 1.5) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp .75 2.25) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp 0. 2.01) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp -.5 2.5) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp -1. -.5) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp -1.5 .5) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp -2.25 -1.) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp .5 -.25) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp .5 -1.25) (set! count (+ count 1)))
(if (pt-in-poly2 xp yp -.5 -2.5) (set! count (+ count 1)))
count))
(define (main . args)
(run-benchmark
"pnpoly"
pnpoly-iters
(lambda (result)
(and (number? result) (= result 6)))
(lambda () (lambda () (run))))))

178
benchmarks/new/r6rs-benchmarks/ray.ss Normal file
View File

@ -0,0 +1,178 @@
;;; RAY -- Ray-trace a simple scene with spheres, generating a ".pgm" file.
;;; Translated to Scheme from Paul Graham's book ANSI Common Lisp, Example 9.8
(library (r6rs-benchmarks ray)
(export main)
(import (r6rs) (r6rs arithmetic flonums) (r6rs-benchmarks))
(define (make-point x y z)
(vector x y z))
(define (point-x p) (vector-ref p 0))
(define (point-y p) (vector-ref p 1))
(define (point-z p) (vector-ref p 2))
(define (sq x) (fl* x x))
(define (mag x y z)
(flsqrt (fl+ (sq x) (sq y) (sq z))))
(define (unit-vector x y z)
(let ((d (mag x y z)))
(make-point (fl/ x d) (fl/ y d) (fl/ z d))))
(define (distance p1 p2)
(mag (fl- (point-x p1) (point-x p2))
(fl- (point-y p1) (point-y p2))
(fl- (point-z p1) (point-z p2))))
(define (minroot a b c)
(if (flzero? a)
(fl/ (fl- c) b)
(let ((disc (fl- (sq b) (fl* 4.0 a c))))
(if (flnegative? disc)
#f
(let ((discrt (flsqrt disc))
(minus-b (fl- b))
(two-a (fl* 2.0 a)))
(flmin (fl/ (fl+ minus-b discrt) two-a)
(fl/ (fl- minus-b discrt) two-a)))))))
(define *world* '())
(define eye (make-point 0.0 0.0 200.0))
(define (tracer pathname res)
(call-with-output-file/truncate
pathname
(lambda (p)
(let ((extent (* res 100)))
(display "P2 " p)
(write extent p)
(display " " p)
(write extent p)
(display " 255" p)
(newline p)
(do ((y 0 (+ y 1)))
((= y extent))
(do ((x 0 (+ x 1)))
((= x extent))
(write (color-at
(fl+ -50.0
(fl/ (exact->inexact x) (exact->inexact res)))
(fl+ -50.0
(fl/ (exact->inexact y) (exact->inexact res))))
p)
(newline p)))))))
(define (color-at x y)
(let ((ray (unit-vector (fl- x (point-x eye))
(fl- y (point-y eye))
(fl- (point-z eye)))))
(flinexact->exact (flround (fl* (sendray eye ray) 255.0)))))
(define (sendray pt ray)
(let* ((x (first-hit pt ray))
(s (vector-ref x 0))
(int (vector-ref x 1)))
(if s
(fl* (lambert s int ray)
(surface-color s))
0.0)))
(define (first-hit pt ray)
(let loop ((lst *world*) (surface #f) (hit #f) (dist 1e308))
(if (null? lst)
(vector surface hit)
(let ((s (car lst)))
(let ((h (intersect s pt ray)))
(if h
(let ((d (distance h pt)))
(if (fl< d dist)
(loop (cdr lst) s h d)
(loop (cdr lst) surface hit dist)))
(loop (cdr lst) surface hit dist)))))))
(define (lambert s int ray)
(let ((n (normal s int)))
(flmax 0.0
(fl+ (fl* (point-x ray) (point-x n))
(fl* (point-y ray) (point-y n))
(fl* (point-z ray) (point-z n))))))
(define (make-sphere color radius center)
(vector color radius center))
(define (sphere-color s) (vector-ref s 0))
(define (sphere-radius s) (vector-ref s 1))
(define (sphere-center s) (vector-ref s 2))
(define (defsphere x y z r c)
(let ((s (make-sphere c r (make-point x y z))))
(set! *world* (cons s *world*))
s))
(define (surface-color s)
(sphere-color s))
(define (intersect s pt ray)
(sphere-intersect s pt ray))
(define (sphere-intersect s pt ray)
(let* ((xr (point-x ray))
(yr (point-y ray))
(zr (point-z ray))
(c (sphere-center s))
(n (minroot
(fl+ (sq xr) (sq yr) (sq zr))
(fl* 2.0
(fl+ (fl* (fl- (point-x pt) (point-x c)) xr)
(fl* (fl- (point-y pt) (point-y c)) yr)
(fl* (fl- (point-z pt) (point-z c)) zr)))
(fl+ (sq (fl- (point-x pt) (point-x c)))
(sq (fl- (point-y pt) (point-y c)))
(sq (fl- (point-z pt) (point-z c)))
(fl- (sq (sphere-radius s)))))))
(if n
(make-point (fl+ (point-x pt) (fl* n xr))
(fl+ (point-y pt) (fl* n yr))
(fl+ (point-z pt) (fl* n zr)))
#f)))
(define (normal s pt)
(sphere-normal s pt))
(define (sphere-normal s pt)
(let ((c (sphere-center s)))
(unit-vector (fl- (point-x c) (point-x pt))
(fl- (point-y c) (point-y pt))
(fl- (point-z c) (point-z pt)))))
(define (ray-test . opt)
(set! *world* '())
(defsphere 0.0 -300.0 -1200.0 200.0 0.8)
(defsphere -80.0 -150.0 -1200.0 200.0 0.7)
(defsphere 70.0 -100.0 -1200.0 200.0 0.9)
(do ((x -2 (+ x 1)))
((> x 2))
(do ((z 2 (+ z 1)))
((> z 7))
(defsphere
(fl* (exact->inexact x) 200.0)
300.0
(fl* (exact->inexact z) -400.0)
40.0
0.75)))
(tracer "spheres.pgm" (if (null? opt) 1 (car opt))))
(define (run)
(ray-test 1)
'ok)
(define (main . args)
(run-benchmark
"ray"
ray-iters
(lambda (result)
(equal? result 'ok))
(lambda () (lambda () (run))))))

8
benchmarks/new/r6rs-benchmarks/todo-src/README.flonum-benchmarks Normal file
View File

@ -0,0 +1,8 @@
fft.scm
nbody.scm
nucleic.scm
ray.scm
simplex.scm
slatex.scm
sum1.scm
test.scm

11693
benchmarks/new/r6rs-benchmarks/todo-src/compiler.scm Normal file
View File

File diff suppressed because it is too large Load Diff

79
benchmarks/new/r6rs-benchmarks/todo-src/fft.scm Normal file
View File

@ -0,0 +1,79 @@
;;; FFT - Fast Fourier Transform, translated from "Numerical Recipes in C"
(define (four1 data)
(let ((n (FLOATvector-length data))
(pi*2 6.28318530717959)) ; to compute the inverse, negate this value
; bit-reversal section
(let loop1 ((i 0) (j 0))
(if (< i n)
(begin
(if (< i j)
(begin
(let ((temp (FLOATvector-ref data i)))
(FLOATvector-set! data i (FLOATvector-ref data j))
(FLOATvector-set! data j temp))
(let ((temp (FLOATvector-ref data (+ i 1))))
(FLOATvector-set! data (+ i 1) (FLOATvector-ref data (+ j 1)))
(FLOATvector-set! data (+ j 1) temp))))
(let loop2 ((m (quotient n 2)) (j j))
(if (and (>= m 2) (>= j m))
(loop2 (quotient m 2) (- j m))
(loop1 (+ i 2) (+ j m)))))))
; Danielson-Lanczos section
(let loop3 ((mmax 2))
(if (< mmax n)
(let* ((theta
(FLOAT/ pi*2 (exact->inexact mmax)))
(wpr
(let ((x (FLOATsin (FLOAT* 0.5 theta))))
(FLOAT* -2.0 (FLOAT* x x))))
(wpi
(FLOATsin theta)))
(let loop4 ((wr 1.0) (wi 0.0) (m 0))
(if (< m mmax)
(begin
(let loop5 ((i m))
(if (< i n)
(let* ((j
(+ i mmax))
(tempr
(FLOAT-
(FLOAT* wr (FLOATvector-ref data j))
(FLOAT* wi (FLOATvector-ref data (+ j 1)))))
(tempi
(FLOAT+
(FLOAT* wr (FLOATvector-ref data (+ j 1)))
(FLOAT* wi (FLOATvector-ref data j)))))
(FLOATvector-set! data j
(FLOAT- (FLOATvector-ref data i) tempr))
(FLOATvector-set! data (+ j 1)
(FLOAT- (FLOATvector-ref data (+ i 1)) tempi))
(FLOATvector-set! data i
(FLOAT+ (FLOATvector-ref data i) tempr))
(FLOATvector-set! data (+ i 1)
(FLOAT+ (FLOATvector-ref data (+ i 1)) tempi))
(loop5 (+ j mmax)));***))
(loop4 (FLOAT+ (FLOAT- (FLOAT* wr wpr) (FLOAT* wi wpi)) wr)
(FLOAT+ (FLOAT+ (FLOAT* wi wpr) (FLOAT* wr wpi)) wi)
(+ m 2)))))
));******
(loop3 (* mmax 2)))))))
(define data
(FLOATmake-vector 1024 0.0))
(define (run data)
(four1 data)
(FLOATvector-ref data 0))
(define (main . args)
(run-benchmark
"fft"
fft-iters
(lambda (result) (equal? result 0.0))
(lambda (data) (lambda () (run data)))
data))

14
benchmarks/new/r6rs-benchmarks/todo-src/fpsum.scm Normal file
View File

@ -0,0 +1,14 @@
;;; FPSUM - Compute sum of integers from 0 to 1e6 using floating point
(define (run)
(let loop ((i 1e6) (n 0.))
(if (FLOAT< i 0.)
n
(loop (FLOAT- i 1.) (FLOAT+ i n)))))
(define (main . args)
(run-benchmark
"fpsum"
fpsum-iters
(lambda () (run))
(lambda (result) (equal? result 500000500000.))))

1438
benchmarks/new/r6rs-benchmarks/todo-src/nbody.scm Normal file
View File

File diff suppressed because it is too large Load Diff

3478
benchmarks/new/r6rs-benchmarks/todo-src/nucleic.scm Normal file
View File

File diff suppressed because it is too large Load Diff

34
benchmarks/new/r6rs-benchmarks/todo-src/primes.scm Normal file
View File

@ -0,0 +1,34 @@
;;; PRIMES -- Compute primes less than 100, written by Eric Mohr.
(define (interval-list m n)
(if (> m n)
'()
(cons m (interval-list (+ 1 m) n))))
(define (sieve l)
(letrec ((remove-multiples
(lambda (n l)
(if (null? l)
'()
(if (= (modulo (car l) n) 0)
(remove-multiples n (cdr l))
(cons (car l)
(remove-multiples n (cdr l))))))))
(if (null? l)
'()
(cons (car l)
(sieve (remove-multiples (car l) (cdr l)))))))
(define (primes<= n)
(sieve (interval-list 2 n)))
(define (main)
(run-benchmark
"primes"
primes-iters
(lambda (result)
(equal? result
'(2 3 5 7 11 13 17 19 23 29 31 37 41
43 47 53 59 61 67 71 73 79 83 89 97)))
(lambda (n) (lambda () (primes<= n)))
100))

144
benchmarks/new/r6rs-benchmarks/todo-src/puzzle.scm Normal file
View File

@ -0,0 +1,144 @@
;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
(define (my-iota n)
(do ((n n (- n 1))
(list '() (cons (- n 1) list)))
((zero? n) list)))
(define size 511)
(define classmax 3)
(define typemax 12)
(define *iii* 0)
(define *kount* 0)
(define *d* 8)
(define *piececount* (make-vector (+ classmax 1) 0))
(define *class* (make-vector (+ typemax 1) 0))
(define *piecemax* (make-vector (+ typemax 1) 0))
(define *puzzle* (make-vector (+ size 1)))
(define *p* (make-vector (+ typemax 1)))
(define (fit i j)
(let ((end (vector-ref *piecemax* i)))
(do ((k 0 (+ k 1)))
((or (> k end)
(and (vector-ref (vector-ref *p* i) k)
(vector-ref *puzzle* (+ j k))))
(if (> k end) #t #f)))))
(define (place i j)
(let ((end (vector-ref *piecemax* i)))
(do ((k 0 (+ k 1)))
((> k end))
(cond ((vector-ref (vector-ref *p* i) k)
(vector-set! *puzzle* (+ j k) #t)
#t)))
(vector-set! *piececount*
(vector-ref *class* i)
(- (vector-ref *piececount* (vector-ref *class* i)) 1))
(do ((k j (+ k 1)))
((or (> k size) (not (vector-ref *puzzle* k)))
(if (> k size) 0 k)))))
(define (puzzle-remove i j)
(let ((end (vector-ref *piecemax* i)))
(do ((k 0 (+ k 1)))
((> k end))
(cond ((vector-ref (vector-ref *p* i) k)
(vector-set! *puzzle* (+ j k) #f)
#f)))
(vector-set! *piececount*
(vector-ref *class* i)
(+ (vector-ref *piececount* (vector-ref *class* i)) 1))))
(define (trial j)
(let ((k 0))
(call-with-current-continuation
(lambda (return)
(do ((i 0 (+ i 1)))
((> i typemax) (set! *kount* (+ *kount* 1)) #f)
(cond
((not
(zero?
(vector-ref *piececount* (vector-ref *class* i))))
(cond
((fit i j)
(set! k (place i j))
(cond
((or (trial k) (zero? k))
(set! *kount* (+ *kount* 1))
(return #t))
(else (puzzle-remove i j))))))))))))
(define (definePiece iclass ii jj kk)
(let ((index 0))
(do ((i 0 (+ i 1)))
((> i ii))
(do ((j 0 (+ j 1)))
((> j jj))
(do ((k 0 (+ k 1)))
((> k kk))
(set! index (+ i (* *d* (+ j (* *d* k)))))
(vector-set! (vector-ref *p* *iii*) index #t))))
(vector-set! *class* *iii* iclass)
(vector-set! *piecemax* *iii* index)
(cond ((not (= *iii* typemax))
(set! *iii* (+ *iii* 1))))))
(define (start)
(set! *kount* 0)
(do ((m 0 (+ m 1)))
((> m size))
(vector-set! *puzzle* m #t))
(do ((i 1 (+ i 1)))
((> i 5))
(do ((j 1 (+ j 1)))
((> j 5))
(do ((k 1 (+ k 1)))
((> k 5))
(vector-set! *puzzle* (+ i (* *d* (+ j (* *d* k)))) #f))))
(do ((i 0 (+ i 1)))
((> i typemax))
(do ((m 0 (+ m 1)))
((> m size))
(vector-set! (vector-ref *p* i) m #f)))
(set! *iii* 0)
(definePiece 0 3 1 0)
(definePiece 0 1 0 3)
(definePiece 0 0 3 1)
(definePiece 0 1 3 0)
(definePiece 0 3 0 1)
(definePiece 0 0 1 3)
(definePiece 1 2 0 0)
(definePiece 1 0 2 0)
(definePiece 1 0 0 2)
(definePiece 2 1 1 0)
(definePiece 2 1 0 1)
(definePiece 2 0 1 1)
(definePiece 3 1 1 1)
(vector-set! *piececount* 0 13)
(vector-set! *piececount* 1 3)
(vector-set! *piececount* 2 1)
(vector-set! *piececount* 3 1)
(let ((m (+ (* *d* (+ *d* 1)) 1))
(n 0))
(cond ((fit 0 m) (set! n (place 0 m)))
(else (begin (newline) (display "Error."))))
(if (trial n)
*kount*
#f)))
(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
(my-iota (+ typemax 1)))
(define (main . args)
(run-benchmark
"puzzle"
puzzle-iters
(lambda (result) (equal? result 2005))
(lambda () (lambda () (start)))))

94
benchmarks/new/r6rs-benchmarks/todo-src/quicksort.scm Normal file
View File

@ -0,0 +1,94 @@
; The quick-1 benchmark. (Figure 35, page 132.)
(define (quick-1 v less?)
(define (helper left right)
(if (< left right)
(let ((median (partition v left right less?)))
(if (< (- median left) (- right median))
(begin (helper left (- median 1))
(helper (+ median 1) right))
(begin (helper (+ median 1) right)
(helper left (- median 1)))))
v))
(helper 0 (- (vector-length v) 1)))
(define (partition v left right less?)
(let ((mid (vector-ref v right)))
(define (uploop i)
(let ((i (+ i 1)))
(if (and (< i right) (less? (vector-ref v i) mid))
(uploop i)
i)))
(define (downloop j)
(let ((j (- j 1)))
(if (and (> j left) (less? mid (vector-ref v j)))
(downloop j)
j)))
(define (ploop i j)
(let* ((i (uploop i))
(j (downloop j)))
(let ((tmp (vector-ref v i)))
(vector-set! v i (vector-ref v j))
(vector-set! v j tmp)
(if (< i j)
(ploop i j)
(begin (vector-set! v j (vector-ref v i))
(vector-set! v i (vector-ref v right))
(vector-set! v right tmp)
i)))))
(ploop (- left 1) right)))
; minimal standard random number generator
; 32 bit integer version
; cacm 31 10, oct 88
;
(define *seed* (list 1))
(define (srand seed)
(set-car! *seed* seed))
(define (rand)
(let* ((hi (quotient (car *seed*) 127773))
(lo (modulo (car *seed*) 127773))
(test (- (* 16807 lo) (* 2836 hi))))
(if (> test 0)
(set-car! *seed* test)
(set-car! *seed* (+ test 2147483647)))
(car *seed*)))
;; return a random number in the interval [0,n)
(define random
(lambda (n)
(modulo (abs (rand)) n)))
(define (quicksort-benchmark)
(let* ((n 30000)
(v (make-vector n)))
(do ((i 0 (+ i 1)))
((= i n))
(vector-set! v i (random 4000)))
(quick-1 v (lambda (x y) (< x y)))))
(define (main . args)
(run-benchmark
"quicksort30"
quicksort-iters
quicksort-benchmark
(lambda (v)
(call-with-current-continuation
(lambda (return)
(do ((i 1 (+ i 1)))
((= i (vector-length v))
#t)
(if (not (<= (vector-ref v (- i 1))
(vector-ref v i)))
(return #f))))))))

100000
benchmarks/new/r6rs-benchmarks/todo-src/rn100 Normal file
View File

File diff suppressed because it is too large Load Diff

784
benchmarks/new/r6rs-benchmarks/todo-src/sboyer.scm Normal file
View File

@ -0,0 +1,784 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: sboyer.sch
; Description: The Boyer benchmark
; Author: Bob Boyer
; Created: 5-Apr-85
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
; 22-Jul-87 (Will Clinger)
; 2-Jul-88 (Will Clinger -- distinguished #f and the empty list)
; 13-Feb-97 (Will Clinger -- fixed bugs in unifier and rules,
; rewrote to eliminate property lists, and added
; a scaling parameter suggested by Bob Boyer)
; 19-Mar-99 (Will Clinger -- cleaned up comments)
; Language: Scheme
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SBOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Much less CONS-intensive than NBOYER because it uses Henry Baker's
;;; "sharing cons".
; Note: The version of this benchmark that appears in Dick Gabriel's book
; contained several bugs that are corrected here. These bugs are discussed
; by Henry Baker, "The Boyer Benchmark Meets Linear Logic", ACM SIGPLAN Lisp
; Pointers 6(4), October-December 1993, pages 3-10. The fixed bugs are:
;
; The benchmark now returns a boolean result.
; FALSEP and TRUEP use TERM-MEMBER? rather than MEMV (which is called MEMBER
; in Common Lisp)
; ONE-WAY-UNIFY1 now treats numbers correctly
; ONE-WAY-UNIFY1-LST now treats empty lists correctly
; Rule 19 has been corrected (this rule was not touched by the original
; benchmark, but is used by this version)
; Rules 84 and 101 have been corrected (but these rules are never touched
; by the benchmark)
;
; According to Baker, these bug fixes make the benchmark 10-25% slower.
; Please do not compare the timings from this benchmark against those of
; the original benchmark.
;
; This version of the benchmark also prints the number of rewrites as a sanity
; check, because it is too easy for a buggy version to return the correct
; boolean result. The correct number of rewrites is
;
; n rewrites peak live storage (approximate, in bytes)
; 0 95024
; 1 591777
; 2 1813975
; 3 5375678
; 4 16445406
; 5 51507739
; Sboyer is a 2-phase benchmark.
; The first phase attaches lemmas to symbols. This phase is not timed,
; but it accounts for very little of the runtime anyway.
; The second phase creates the test problem, and tests to see
; whether it is implied by the lemmas.
(define (main . args)
(let ((n (if (null? args) 0 (car args))))
(setup-boyer)
(run-benchmark
(string-append "sboyer"
(number->string n))
sboyer-iters
(lambda (rewrites)
(and (number? rewrites)
(case n
((0) (= rewrites 95024))
((1) (= rewrites 591777))
((2) (= rewrites 1813975))
((3) (= rewrites 5375678))
((4) (= rewrites 16445406))
((5) (= rewrites 51507739))
; If it works for n <= 5, assume it works.
(else #t))))
(lambda (alist term n) (lambda () (test-boyer alist term n)))
(quote ((x f (plus (plus a b)
(plus c (zero))))
(y f (times (times a b)
(plus c d)))
(z f (reverse (append (append a b)
(nil))))
(u equal (plus a b)
(difference x y))
(w lessp (remainder a b)
(member a (length b)))))
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w)))
n)))
(define (setup-boyer) #t) ; assigned below
(define (test-boyer) #t) ; assigned below
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The first phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; In the original benchmark, it stored a list of lemmas on the
; property lists of symbols.
; In the new benchmark, it maintains an association list of
; symbols and symbol-records, and stores the list of lemmas
; within the symbol-records.
(let ()
(define (setup)
(add-lemma-lst
(quote ((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(equal (fix x)
(fix y)))
(equal (greaterp x y)
(lessp y x))
(equal (lesseqp x y)
(not (lessp y x)))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (_1- x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x)))
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (_1- x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (fix x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (plus (plus x y)
z)
(plus x (plus y z)))
(equal (equal (plus a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (difference x x)
(zero))
(equal (equal (plus a b)
(plus a c))
(equal (fix b)
(fix c)))
(equal (equal (zero)
(difference x y))
(not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (append x y))
a)
(plus (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(fix (meaning x a)))
(equal (append (append x y)
z)
(append x (append y z)))
(equal (reverse (append a b))
(append (reverse b)
(reverse a)))
(equal (times x (plus y z))
(plus (times x y)
(times x z)))
(equal (times (times x y)
z)
(times x (times y z)))
(equal (equal (times x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (append x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(append (flatten x)
y))
(equal (member x (append a b))
(or (member x a)
(member x b)))
(equal (member x (reverse y))
(member x y))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c))
(and (member a b)
(member a c)))
(equal (nth (zero)
i)
(zero))
(equal (exp i (plus j k))
(times (exp i j)
(exp i k)))
(equal (exp i (times j k))
(exp (exp i j)
k))
(equal (reverse-loop x y)
(append (reverse x)
y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x)
(count-list z y)))
(equal (equal (append a b)
(append a c))
(equal b c))
(equal (plus (remainder x y)
(times y (quotient x y)))
(fix x))
(equal (power-eval (big-plus1 l i base)
base)
(plus (power-eval l base)
i))
(equal (power-eval (big-plus x y i base)
base)
(plus i (plus (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (lessp (remainder x y)
y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (lessp (quotient i j)
i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (lessp (remainder x y)
x)
(and (not (zerop y))
(not (zerop x))
(not (lessp x y))))
(equal (power-eval (power-rep i base)
base)
(fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (append a b)
i)
(append (nth a i)
(nth b (difference i (length a)))))
(equal (difference (plus x y)
x)
(fix y))
(equal (difference (plus y x)
x)
(fix y))
(equal (difference (plus x y)
(plus x z))
(difference y z))
(equal (times x (difference c w))
(difference (times c x)
(times w x)))
(equal (remainder (times x z)
z)
(zero))
(equal (difference (plus b (plus a c))
a)
(plus b c))
(equal (difference (add1 (plus y z))
z)
(add1 y))
(equal (lessp (plus x y)
(plus x z))
(lessp y z))
(equal (lessp (times x z)
(times y z))
(and (not (zerop z))
(lessp x y)))
(equal (lessp y (plus x y))
(not (zerop x)))
(equal (gcd (times x z)
(times y z))
(times z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y)
1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (append x y))
(times (times-list x)
(times-list y)))
(equal (prime-list (append x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (times w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (times y x)
y)
(zero))
(equal (equal (times a b)
1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (_1- a)
(zero))
(equal (_1- b)
(zero))))
(equal (lessp (length (delete x l))
(length l))
(member x l))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length (cons x1
(cons x2
(cons x3 (cons x4
(cons x5
(cons x6 x7)))))))
(plus 6 (length x7)))
(equal (difference (add1 (add1 x))
2)
(fix x))
(equal (quotient (plus x (plus x y))
2)
(plus x (quotient y 2)))
(equal (sigma (zero)
i)
(quotient (times i (add1 i))
2))
(equal (plus x (add1 y))
(if (numberp y)
(add1 (plus x y))
(add1 x)))
(equal (equal (difference x y)
(difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y)
(not (lessp y x))
(equal (fix x)
(fix z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y)
(difference (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (times x (add1 y))
(if (numberp y)
(plus x (times x y))
(fix x)))
(equal (nth (nil)
i)
(if (zerop i)
(nil)
(zero)))
(equal (last (append a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a))
b)
b)))
(equal (equal (lessp x y)
z)
(if (lessp x y)
(equal (t) z)
(equal (f) z)))
(equal (assignment x (append a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (quotient (times y x)
y)
(if (zerop y)
(zero)
(fix x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem)))))))
(define (add-lemma-lst lst)
(cond ((null? lst)
#t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(define (add-lemma term)
(cond ((and (pair? term)
(eq? (car term)
(quote equal))
(pair? (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons
(translate-term term)
(get (car (cadr term)) (quote lemmas)))))
(else (fatal-error "ADD-LEMMA did not like term: " term))))
; Translates a term by replacing its constructor symbols by symbol-records.
(define (translate-term term)
(cond ((not (pair? term))
term)
(else (cons (symbol->symbol-record (car term))
(translate-args (cdr term))))))
(define (translate-args lst)
(cond ((null? lst)
'())
(else (cons (translate-term (car lst))
(translate-args (cdr lst))))))
; For debugging only, so the use of MAP does not change
; the first-order character of the benchmark.
(define (untranslate-term term)
(cond ((not (pair? term))
term)
(else (cons (get-name (car term))
(map untranslate-term (cdr term))))))
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (put sym property value)
(put-lemmas! (symbol->symbol-record sym) value))
(define (get sym property)
(get-lemmas (symbol->symbol-record sym)))
(define (symbol->symbol-record sym)
(let ((x (assq sym *symbol-records-alist*)))
(if x
(cdr x)
(let ((r (make-symbol-record sym)))
(set! *symbol-records-alist*
(cons (cons sym r)
*symbol-records-alist*))
r))))
; Association list of symbols and symbol-records.
(define *symbol-records-alist* '())
; A symbol-record is represented as a vector with two fields:
; the symbol (for debugging) and
; the list of lemmas associated with the symbol.
(define (make-symbol-record sym)
(vector sym '()))
(define (put-lemmas! symbol-record lemmas)
(vector-set! symbol-record 1 lemmas))
(define (get-lemmas symbol-record)
(vector-ref symbol-record 1))
(define (get-name symbol-record)
(vector-ref symbol-record 0))
(define (symbol-record-equal? r1 r2)
(eq? r1 r2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The second phase.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test alist term n)
(let ((term
(apply-subst
(translate-alist alist)
(translate-term
(do ((term term (list 'or term '(f)))
(n n (- n 1)))
((zero? n) term))))))
(tautp term)))
(define (translate-alist alist)
(cond ((null? alist)
'())
(else (cons (cons (caar alist)
(translate-term (cdar alist)))
(translate-alist (cdr alist))))))
(define (apply-subst alist term)
(cond ((not (pair? term))
(let ((temp-temp (assq term alist)))
(if temp-temp
(cdr temp-temp)
term)))
(else (cons (car term)
(apply-subst-lst alist (cdr term))))))
(define (apply-subst-lst alist lst)
(cond ((null? lst)
'())
(else (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(define (tautp x)
(tautologyp (rewrite x)
'() '()))
(define (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
#t)
((falsep x false-lst)
#f)
((not (pair? x))
#f)
((eq? (car x) if-constructor)
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(else (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(else #f)))
(define if-constructor '*) ; becomes (symbol->symbol-record 'if)
(define rewrite-count 0) ; sanity check
; The next procedure is Henry Baker's sharing CONS, which avoids
; allocation if the result is already in hand.
; The REWRITE and REWRITE-ARGS procedures have been modified to
; use SCONS instead of CONS.
(define (scons x y original)
(if (and (eq? x (car original))
(eq? y (cdr original)))
original
(cons x y)))
(define (rewrite term)
(set! rewrite-count (+ rewrite-count 1))
(cond ((not (pair? term))
term)
(else (rewrite-with-lemmas (scons (car term)
(rewrite-args (cdr term))
term)
(get-lemmas (car term))))))
(define (rewrite-args lst)
(cond ((null? lst)
'())
(else (scons (rewrite (car lst))
(rewrite-args (cdr lst))
lst))))
(define (rewrite-with-lemmas term lst)
(cond ((null? lst)
term)
((one-way-unify term (cadr (car lst)))
(rewrite (apply-subst unify-subst (caddr (car lst)))))
(else (rewrite-with-lemmas term (cdr lst)))))
(define unify-subst '*)
(define (one-way-unify term1 term2)
(begin (set! unify-subst '())
(one-way-unify1 term1 term2)))
(define (one-way-unify1 term1 term2)
(cond ((not (pair? term2))
(let ((temp-temp (assq term2 unify-subst)))
(cond (temp-temp
(term-equal? term1 (cdr temp-temp)))
((number? term2) ; This bug fix makes
(equal? term1 term2)) ; nboyer 10-25% slower!
(else
(set! unify-subst (cons (cons term2 term1)
unify-subst))
#t))))
((not (pair? term1))
#f)
((eq? (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(else #f)))
(define (one-way-unify1-lst lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else #f)))
(define (falsep x lst)
(or (term-equal? x false-term)
(term-member? x lst)))
(define (truep x lst)
(or (term-equal? x true-term)
(term-member? x lst)))
(define false-term '*) ; becomes (translate-term '(f))
(define true-term '*) ; becomes (translate-term '(t))
; The next two procedures were in the original benchmark
; but were never used.
(define (trans-of-implies n)
(translate-term
(list (quote implies)
(trans-of-implies1 n)
(list (quote implies)
0 n))))
(define (trans-of-implies1 n)
(cond ((equal? n 1)
(list (quote implies)
0 1))
(else (list (quote and)
(list (quote implies)
(- n 1)
n)
(trans-of-implies1 (- n 1))))))
; Translated terms can be circular structures, which can't be
; compared using Scheme's equal? and member procedures, so we
; use these instead.
(define (term-equal? x y)
(cond ((pair? x)
(and (pair? y)
(symbol-record-equal? (car x) (car y))
(term-args-equal? (cdr x) (cdr y))))
(else (equal? x y))))
(define (term-args-equal? lst1 lst2)
(cond ((null? lst1)
(null? lst2))
((null? lst2)
#f)
((term-equal? (car lst1) (car lst2))
(term-args-equal? (cdr lst1) (cdr lst2)))
(else #f)))
(define (term-member? x lst)
(cond ((null? lst)
#f)
((term-equal? x (car lst))
#t)
(else (term-member? x (cdr lst)))))
(set! setup-boyer
(lambda ()
(set! *symbol-records-alist* '())
(set! if-constructor (symbol->symbol-record 'if))
(set! false-term (translate-term '(f)))
(set! true-term (translate-term '(t)))
(setup)))
(set! test-boyer
(lambda (alist term n)
(set! rewrite-count 0)
(let ((answer (test alist term n)))
; (write rewrite-count)
; (display " rewrites")
; (newline)
(if answer
rewrite-count
#f)))))

1075
benchmarks/new/r6rs-benchmarks/todo-src/scheme.scm Normal file
View File

File diff suppressed because it is too large Load Diff

188
benchmarks/new/r6rs-benchmarks/todo-src/simplex.scm Normal file
View File

@ -0,0 +1,188 @@
;;; SIMPLEX -- Simplex algorithm.
(define (matrix-rows a) (vector-length a))
(define (matrix-columns a) (FLOATvector-length (vector-ref a 0)))
(define (matrix-ref a i j) (FLOATvector-ref (vector-ref a i) j))
(define (matrix-set! a i j x) (FLOATvector-set! (vector-ref a i) j x))
(define (fuck-up)
(fatal-error "This shouldn't happen"))
(define (simplex a m1 m2 m3)
(define *epsilon* 1e-6)
;(define *epsilon* 0.000001)
(if (not (and (>= m1 0)
(>= m2 0)
(>= m3 0)
(= (matrix-rows a) (+ m1 m2 m3 2))))
(fuck-up))
(let* ((m12 (+ m1 m2 1))
(m (- (matrix-rows a) 2))
(n (- (matrix-columns a) 1))
(l1 (make-vector n))
(l2 (make-vector m))
(l3 (make-vector m2))
(nl1 n)
(iposv (make-vector m))
(izrov (make-vector n))
(ip 0)
(kp 0)
(bmax 0.0)
(one? #f)
(pass2? #t))
(define (simp1 mm abs?)
(set! kp (vector-ref l1 0))
(set! bmax (matrix-ref a mm kp))
(do ((k 1 (+ k 1))) ((>= k nl1))
(if (FLOATpositive?
(if abs?
(FLOAT- (FLOATabs (matrix-ref a mm (vector-ref l1 k)))
(FLOATabs bmax))
(FLOAT- (matrix-ref a mm (vector-ref l1 k)) bmax)))
(begin
(set! kp (vector-ref l1 k))
(set! bmax (matrix-ref a mm (vector-ref l1 k)))))))
(define (simp2)
(set! ip 0)
(let ((q1 0.0)
(flag? #f))
(do ((i 0 (+ i 1))) ((= i m))
(if flag?
(if (FLOAT< (matrix-ref a (vector-ref l2 i) kp) (FLOAT- *epsilon*))
(begin
(let ((q (FLOAT/ (FLOAT- (matrix-ref a (vector-ref l2 i) 0))
(matrix-ref a (vector-ref l2 i) kp))))
(cond
((FLOAT< q q1)
(set! ip (vector-ref l2 i))
(set! q1 q))
((FLOAT= q q1)
(let ((qp 0.0)
(q0 0.0))
(let loop ((k 1))
(if (<= k n)
(begin
(set! qp (FLOAT/ (FLOAT- (matrix-ref a ip k))
(matrix-ref a ip kp)))
(set! q0 (FLOAT/ (FLOAT-
(matrix-ref a (vector-ref l2 i) k))
(matrix-ref a (vector-ref l2 i) kp)))
(if (FLOAT= q0 qp)
(loop (+ k 1))))))
(if (FLOAT< q0 qp)
(set! ip (vector-ref l2 i)))))))))
(if (FLOAT< (matrix-ref a (vector-ref l2 i) kp) (FLOAT- *epsilon*))
(begin
(set! q1 (FLOAT/ (FLOAT- (matrix-ref a (vector-ref l2 i) 0))
(matrix-ref a (vector-ref l2 i) kp)))
(set! ip (vector-ref l2 i))
(set! flag? #t)))))))
(define (simp3 one?)
(let ((piv (FLOAT/ (matrix-ref a ip kp))))
(do ((ii 0 (+ ii 1))) ((= ii (+ m (if one? 2 1))))
(if (not (= ii ip))
(begin
(matrix-set! a ii kp (FLOAT* piv (matrix-ref a ii kp)))
(do ((kk 0 (+ kk 1))) ((= kk (+ n 1)))
(if (not (= kk kp))
(matrix-set! a ii kk (FLOAT- (matrix-ref a ii kk)
(FLOAT* (matrix-ref a ip kk)
(matrix-ref a ii kp)))))))))
(do ((kk 0 (+ kk 1))) ((= kk (+ n 1)))
(if (not (= kk kp))
(matrix-set! a ip kk (FLOAT* (FLOAT- piv) (matrix-ref a ip kk)))))
(matrix-set! a ip kp piv)))
(do ((k 0 (+ k 1))) ((= k n))
(vector-set! l1 k (+ k 1))
(vector-set! izrov k k))
(do ((i 0 (+ i 1))) ((= i m))
(if (FLOATnegative? (matrix-ref a (+ i 1) 0))
(fuck-up))
(vector-set! l2 i (+ i 1))
(vector-set! iposv i (+ n i)))
(do ((i 0 (+ i 1))) ((= i m2)) (vector-set! l3 i #t))
(if (positive? (+ m2 m3))
(begin
(do ((k 0 (+ k 1))) ((= k (+ n 1)))
(do ((i (+ m1 1) (+ i 1)) (sum 0.0 (FLOAT+ sum (matrix-ref a i k))))
((> i m) (matrix-set! a (+ m 1) k (FLOAT- sum)))))
(let loop ()
(simp1 (+ m 1) #f)
(cond
((FLOAT<= bmax *epsilon*)
(cond ((FLOAT< (matrix-ref a (+ m 1) 0) (FLOAT- *epsilon*))
(set! pass2? #f))
((FLOAT<= (matrix-ref a (+ m 1) 0) *epsilon*)
(let loop ((ip1 m12))
(if (<= ip1 m)
(cond ((= (vector-ref iposv (- ip1 1)) (+ ip n -1))
(simp1 ip1 #t)
(cond ((FLOATpositive? bmax)
(set! ip ip1)
(set! one? #t))
(else
(loop (+ ip1 1)))))
(else
(loop (+ ip1 1))))
(do ((i (+ m1 1) (+ i 1))) ((>= i m12))
(if (vector-ref l3 (- i (+ m1 1)))
(do ((k 0 (+ k 1))) ((= k (+ n 1)))
(matrix-set! a i k (FLOAT- (matrix-ref a i k)))))))))
(else (simp2) (if (zero? ip) (set! pass2? #f) (set! one? #t)))))
(else (simp2) (if (zero? ip) (set! pass2? #f) (set! one? #t))))
(if one?
(begin
(set! one? #f)
(simp3 #t)
(cond
((>= (vector-ref iposv (- ip 1)) (+ n m12 -1))
(let loop ((k 0))
(cond
((and (< k nl1) (not (= kp (vector-ref l1 k))))
(loop (+ k 1)))
(else
(set! nl1 (- nl1 1))
(do ((is k (+ is 1))) ((>= is nl1))
(vector-set! l1 is (vector-ref l1 (+ is 1))))
(matrix-set! a (+ m 1) kp (FLOAT+ (matrix-ref a (+ m 1) kp) 1.0))
(do ((i 0 (+ i 1))) ((= i (+ m 2)))
(matrix-set! a i kp (FLOAT- (matrix-ref a i kp))))))))
((and (>= (vector-ref iposv (- ip 1)) (+ n m1))
(vector-ref l3 (- (vector-ref iposv (- ip 1)) (+ m1 n))))
(vector-set! l3 (- (vector-ref iposv (- ip 1)) (+ m1 n)) #f)
(matrix-set! a (+ m 1) kp (FLOAT+ (matrix-ref a (+ m 1) kp) 1.0))
(do ((i 0 (+ i 1))) ((= i (+ m 2)))
(matrix-set! a i kp (FLOAT- (matrix-ref a i kp))))))
(let ((t (vector-ref izrov (- kp 1))))
(vector-set! izrov (- kp 1) (vector-ref iposv (- ip 1)))
(vector-set! iposv (- ip 1) t))
(loop))))))
(and pass2?
(let loop ()
(simp1 0 #f)
(cond
((FLOATpositive? bmax)
(simp2)
(cond ((zero? ip) #t)
(else (simp3 #f)
(let ((t (vector-ref izrov (- kp 1))))
(vector-set! izrov (- kp 1) (vector-ref iposv (- ip 1)))
(vector-set! iposv (- ip 1) t))
(loop))))
(else (list iposv izrov)))))))
(define (test)
(simplex (vector (FLOATvector 0.0 1.0 1.0 3.0 -0.5)
(FLOATvector 740.0 -1.0 0.0 -2.0 0.0)
(FLOATvector 0.0 0.0 -2.0 0.0 7.0)
(FLOATvector 0.5 0.0 -1.0 1.0 -2.0)
(FLOATvector 9.0 -1.0 -1.0 -1.0 -1.0)
(FLOATvector 0.0 0.0 0.0 0.0 0.0))
2 1 1))
(define (main . args)
(run-benchmark
"simplex"
simplex-iters
(lambda (result) (equal? result '(#(4 1 3 2) #(0 5 7 6))))
(lambda () (lambda () (test)))))

2339
benchmarks/new/r6rs-benchmarks/todo-src/slatex.scm Normal file
View File

File diff suppressed because it is too large Load Diff

547
benchmarks/new/r6rs-benchmarks/todo-src/slatex.sty Normal file
View File

@ -0,0 +1,547 @@
% slatex.sty
% SLaTeX v. 2.2
% style file to be used in (La)TeX when using SLaTeX
% (c) Dorai Sitaram, Rice U., 1991, 1994
% This file (or a soft link to it) should be in some
% directory in your TEXINPUTS path (i.e., the one
% (La)TeX scours for \input or \documentstyle option
% files).
% Do not attempt to debug this file, since the results
% are not transparent just to (La)TeX. The Scheme part
% of SLaTeX depends on information laid out here -- so
% (La)TeX-minded debugging of this file will almost
% inevitably sabotage SLaTeX.
% It's possible you don't find the default style set
% out here appealing: e.g., you may want to change the
% positioning of displayed code; change the fonts for
% keywords, constants, and variables; add new keywords,
% constants, and variables; use your names instead of
% the provided \scheme, [\begin|\end]{schemedisplay},
% [\begin|\end]{schemebox}, (or \[end]schemedisplay,
% \[end]schemebox for TeX), which might be seem too
% long or unmnemonic, and many other things. The clean
% way to do these things is outlined in the
% accompanying manual, slatex-d.tex. This way is both
% easier than messing with this .sty file, and safer
% since you will not unwittingly break SLaTeX.
%%%
% to prevent loading slatex.sty more than once
\ifx\slatexignorecurrentfile\UNDEFINED
\else\endinput\fi
% use \slatexignorecurrentfile to disable slatex for
% the current file. (Unstrangely, the very definition
% disables slatex for the rest of _this_ file, slatex.sty.)
\def\slatexignorecurrentfile{}
% checking whether we're using LaTeX or TeX?
\newif\ifusinglatex
\ifx\newenvironment\UNDEFINED\usinglatexfalse\else\usinglatextrue\fi
% make @ a letter for TeX
\ifusinglatex\relax\else
\edef\atcatcodebeforeslatex{\the\catcode`@}
\catcode`@11
\fi
% identification of TeX/LaTeX style for schemedisplay.
% Do \defslatexenvstyle{tex} to get TeX environment
% style in LaTeX
\def\defslatexenvstyle#1{\gdef\slatexenvstyle{#1}}
\ifusinglatex\defslatexenvstyle{latex}\else\defslatexenvstyle{tex}\fi
% TeX doesn't have sans-serif; use roman instead
\ifx\sf\UNDEFINED\def\sf{\rm}\fi
% tabbing from plain TeX
%
\newif\ifus@ \newif\if@cr
\newbox\tabs \newbox\tabsyet \newbox\tabsdone
%
\def\cleartabs{\global\setbox\tabsyet\null \setbox\tabs\null}
\def\settabs{\setbox\tabs\null \futurelet\next\sett@b}
\let\+=\relax % in case this file is being read in twice
\def\sett@b{\ifx\next\+\let\next\relax
\def\next{\afterassignment\s@tt@b\let\next}%
\else\let\next\s@tcols\fi\next}
\def\s@tt@b{\let\next\relax\us@false\m@ketabbox}
\def\tabalign{\us@true\m@ketabbox} % non-\outer version of \+
\outer\def\+{\tabalign}
\def\s@tcols#1\columns{\count@#1 \dimen@\hsize
\loop\ifnum\count@>\z@ \@nother \repeat}
\def\@nother{\dimen@ii\dimen@ \divide\dimen@ii\count@
\setbox\tabs\hbox{\hbox to\dimen@ii{}\unhbox\tabs}%
\advance\dimen@-\dimen@ii \advance\count@\m@ne}
%
\def\m@ketabbox{\begingroup
\global\setbox\tabsyet\copy\tabs
\global\setbox\tabsdone\null
\def\cr{\@crtrue\crcr\egroup\egroup
\ifus@\unvbox\z@\lastbox\fi\endgroup
\setbox\tabs\hbox{\unhbox\tabsyet\unhbox\tabsdone}}%
\setbox\z@\vbox\bgroup\@crfalse
\ialign\bgroup&\t@bbox##\t@bb@x\crcr}
%
\def\t@bbox{\setbox\z@\hbox\bgroup}
\def\t@bb@x{\if@cr\egroup % now \box\z@ holds the column
\else\hss\egroup \global\setbox\tabsyet\hbox{\unhbox\tabsyet
\global\setbox\@ne\lastbox}% now \box\@ne holds its size
\ifvoid\@ne\global\setbox\@ne\hbox to\wd\z@{}%
\else\setbox\z@\hbox to\wd\@ne{\unhbox\z@}\fi
\global\setbox\tabsdone\hbox{\box\@ne\unhbox\tabsdone}\fi
\box\z@}
% finished (re)defining TeX's tabbing macros
% above from plain.tex; was disabled in lplain.tex. Do
% not modify above unless you really know what you're
% up to. Make all changes you want to following code.
% The new env is preferable to LaTeX's tabbing env
% since latter accepts only a small number of tabs
% following retrieves something like LaTeX's tabbing
% env without the above problem (it also creates a box
% for easy manipulation!)
\def\lat@xtabbing{\leavevmode\hbox\bgroup\vbox\bgroup
\def\={\cleartabs&} \def\>{&} \def\\{\cr\tabalign} \tabalign}
\def\endlat@xtabbing{\cr\egroup\egroup}
%new
\def\lat@xtabbing{\begingroup
\def\={\cleartabs&} \def\>{&}%
\def\\{\cr\tabalign\lat@xtabbingleftmost}%
\tabalign\lat@xtabbingleftmost}
\def\endlat@xtabbing{\cr\endgroup}
\let\lat@xtabbingleftmost\relax
% stuff for formating Scheme code
\newskip\par@nlen \newskip\brack@tlen \newskip\quot@len
\newskip\h@lflambda
\newbox\garb@ge
\def\s@ttowidth#1#2{\setbox\garb@ge\hbox{#2}#1\wd\garb@ge\relax}
\s@ttowidth\par@nlen{$($} % size of paren
\s@ttowidth\brack@tlen{$[$} % size of bracket
\s@ttowidth\quot@len{'} % size of quote indentation
\s@ttowidth\h@lflambda{ii} % size of half of lambda indentation
\def\PRN{\hskip\par@nlen} % these are used by SLaTeX's codesetter
\def\BKT{\hskip\brack@tlen}
\def\QUO{\hskip\quot@len}
\def\HL{\hskip\h@lflambda}
\newskip\abovecodeskip \newskip\belowcodeskip
\newskip\leftcodeskip \newskip\rightcodeskip
% the following default assignments give a flushleft
% display
\abovecodeskip=\medskipamount \belowcodeskip=\medskipamount
\leftcodeskip=0pt \rightcodeskip=0pt
% adjust above,below,left,right codeskip's to personal
% taste
% for centered displays
%
% \leftcodeskip=0pt plus 1fil
% \rightcodeskip=0pt plus 1fil
%
% if \rightcodeskip != 0pt, pagebreaks within Scheme
% blocks in {schemedisplay} are disabled
\def\checkfollpar{\futurelet\next\checkfollparII}
\def\checkfollparII{\ifx\next\par\let\next\relax
\else\par\noindent\let\next\ignorespaces\fi\next}
% the following are the default font assignments for
% words in code. Change them to suit personal taste
\def\keywordfont#1{{\bf #1}}
\def\variablefont#1{{\it #1\/}}
\def\constantfont#1{{\sf #1}}
\def\datafont#1{\constantfont{#1}}
\def\schemecodehook{}
%program listings that allow page breaks but
%can't be centered
\def\ZZZZschemedisplay{\edef\thez@skip{\the\z@skip}%
\edef\@tempa{\the\rightcodeskip}%
\ifx\@tempa\thez@skip\let\next\ZZZZschemeprogram
\else\let\next\ZZZZschemeprogramII\fi\next}
\def\endZZZZschemedisplay{\edef\thez@skip{\the\z@skip}%
\edef\@tempa{\the\rightcodeskip}%
\ifx\@tempa\thez@skip\let\next\endZZZZschemeprogram
\else\let\next\endZZZZschemeprogramII\fi\next}
\def\ZZZZschemeprogram{\vskip\abovecodeskip
\begingroup
\schemecodehook
\let\sy=\keywordfont \let\cn=\constantfont
\let\va=\variablefont \let\dt=\datafont
\def\lat@xtabbingleftmost{\hskip\leftcodeskip\relax}%
\lat@xtabbing}
\def\endZZZZschemeprogram{\endlat@xtabbing
\endgroup
\vskip\belowcodeskip
\ifusinglatex\let\next\@endparenv
\else\let\next\checkfollpar\fi\next}
\def\ZZZZschemeprogramII{\vskip\abovecodeskip
\begingroup
\noindent
%\schemecodehook %\ZZZZschemebox already has it
\hskip\leftcodeskip
\ZZZZschemebox}
\def\endZZZZschemeprogramII{\endZZZZschemebox
\hskip\rightcodeskip
\endgroup
\vskip\belowcodeskip
\ifusinglatex\let\next\@endparenv
\else\let\next\checkfollpar\fi\next}
%
\def\ZZZZschemebox{%
\leavevmode\hbox\bgroup\vbox\bgroup
\schemecodehook
\let\sy=\keywordfont \let\cn=\constantfont
\let\va=\variablefont \let\dt=\datafont
\lat@xtabbing}
\def\endZZZZschemebox{\endlat@xtabbing
\egroup\egroup\ignorespaces}
%in-text
\def\ZZZZschemecodeintext{\begingroup
\let\sy\keywordfont \let\cn\constantfont
\let\va\variablefont \let\dt\datafont}
\def\endZZZZschemecodeintext{\endgroup\ignorespaces}
\def\ZZZZschemeresultintext{\begingroup
\let\sy\datafont \let\cn\constantfont
\let\va\datafont \let\dt\datafont}
\def\endZZZZschemeresultintext{\endgroup\ignorespaces}
% \comm@nt<some-char>...text...<same-char> comments out
% TeX source analogous to
% \verb<some-char>...text...<same-char>. Sp. case:
% \comm@nt{...text...} == \comm@nt}...text...}
\def\@makeother#1{\catcode`#112\relax}
\def\comm@nt{%
\begingroup
\let\do\@makeother \dospecials
\@comm}
\begingroup\catcode`\<1\catcode`\>2
\catcode`\{12\catcode`\}12
\long\gdef\@comm#1<%
\if#1{\long\def\@tempa ##1}<\endgroup>\else
\long\def\@tempa ##1#1<\endgroup>\fi
\@tempa>
\endgroup
% input file if possible, else relax
\def\inputifpossible#1{%
\immediate\openin0=#1\relax%
\ifeof0\relax\else\input#1\relax\fi%
\immediate\closein0}
\def\ZZZZinput#1{\input#1\relax}
% you may replace the above by
%
% \def\ZZZZinput#1{\inputifpossible{#1}}
%
% if you just want to call (La)TeX on your text
% ignoring the portions that need to be SLaTeX'ed
%use \subjobname rather than \jobname to generate
%slatex's temp files --- this allows us to change
%\subjobname for more control, if necessary.
\let\subjobname\jobname
% counter for generating temp file names
\newcount\sch@mefilenamecount
\sch@mefilenamecount=-1
% To produce displayed Scheme code:
% in LaTeX:
% \begin{schemedisplay}
% ... indented program (with sev'l lines) ...
% \end{schemedisplay}
%
% in TeX:
% \schemedisplay
% ... indented program (with sev'l lines) ...
% \endschemedisplay
\begingroup\catcode`\|=0\catcode`\[=1\catcode`\]=2%
\catcode`\{=12\catcode`\}=12\catcode`\\=12%
|gdef|defschemedisplaytoken#1[%
|long|expandafter|gdef|csname ZZZZcomment#1|endcsname[%
|begingroup
|let|do|@makeother |dospecials
|csname ZZZZcomment|slatexenvstyle II#1|endcsname]%
|long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[%
|endgroup|end[#1]]%
|long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[%
|endgroup|csname end#1|endcsname]%
|long|expandafter|gdef|csname #1|endcsname[%
|global|advance|sch@mefilenamecount by 1|relax%
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|csname ZZZZcomment#1|endcsname]%
|long|expandafter|gdef|csname end#1|endcsname[]]%
|endgroup
\defschemedisplaytoken{schemedisplay}
\def\undefschemedisplaytoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% \scheme|...program fragment...| produces Scheme code
% in-text. Sp. case: \scheme{...} == \scheme}...}
\def\defschemetoken#1{%
\long\expandafter\def\csname#1\endcsname{%
\global\advance\sch@mefilenamecount by 1\relax%
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}%
\comm@nt}}
\defschemetoken{scheme}
\def\undefschemetoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% \schemeresult|...program fragment...| produces a
% Scheme code result in-text: i.e. keyword or variable
% fonts are replaced by the data font. Sp. case:
% \schemeresult{...} == \schemeresult}...}
\def\defschemeresulttoken#1{%
\long\expandafter\def\csname#1\endcsname{%
\global\advance\sch@mefilenamecount by 1\relax%
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}%
\comm@nt}}
\defschemeresulttoken{schemeresult}
\def\undefschemeresulttoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% To produce a box of Scheme code:
% in LaTeX:
% \begin{schemebox}
% ... indented program (with sev'l lines) ...
% \end{schemebox}
%
% in TeX:
% \schemebox
% ... indented program (with sev'l lines) ...
% \endschemebox
\begingroup\catcode`\|=0\catcode`\[=1\catcode`\]=2%
\catcode`\{=12\catcode`\}=12\catcode`\\=12%
|gdef|defschemeboxtoken#1[%
|long|expandafter|gdef|csname ZZZZcomment#1|endcsname[%
|begingroup
|let|do|@makeother |dospecials
|csname ZZZZcomment|slatexenvstyle II#1|endcsname]%
|long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[%
|endgroup|end[#1]]%
|long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[%
|endgroup|csname end#1|endcsname]%
|long|expandafter|gdef|csname #1|endcsname[%
|global|advance|sch@mefilenamecount by 1|relax%
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|csname ZZZZcomment#1|endcsname]%
|long|expandafter|gdef|csname end#1|endcsname[]]%
|endgroup
\defschemeboxtoken{schemebox}
\def\undefschemeboxtoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% for wholesale dumping of all-Scheme files into TeX (converting
% .scm files to .tex),
% use
% \schemeinput{<filename>}
% .scm, .ss, .s extensions optional
\def\defschemeinputtoken#1{%
\long\expandafter\gdef\csname#1\endcsname##1{%
\global\advance\sch@mefilenamecount by 1\relax%
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}}}
\defschemeinputtoken{schemeinput}
\def\undefschemeinputtoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% delineating a region that features typeset code
% not usually needed, except when using \scheme and schemedisplay
% inside macro-args and macro-definition-bodies
% in LaTeX:
% \begin{schemeregion}
% ...
% \end{schemeregion}
%
% in TeX:
% \schemeregion
% ...
% \endschemeregion
\begingroup\catcode`\|=0\catcode`\[=1\catcode`\]=2%
\catcode`\{=12\catcode`\}=12\catcode`\\=12%
|gdef|defschemeregiontoken#1[%
|long|expandafter|gdef|csname ZZZZcomment#1|endcsname[%
|begingroup
|let|do|@makeother |dospecials
|csname ZZZZcomment|slatexenvstyle II#1|endcsname]%
|long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[%
|endgroup|end[#1]]%
|long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[%
|endgroup|csname end#1|endcsname]%
|long|expandafter|gdef|csname #1|endcsname[%
|global|advance|sch@mefilenamecount by 1|relax%
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|csname ZZZZcomment#1|endcsname]%
|long|expandafter|gdef|csname end#1|endcsname[]]%
|endgroup
\defschemeregiontoken{schemeregion}
\def\undefschemeregiontoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% introducing new code-tokens to the keyword, variable and constant
% categories
\def\comm@ntII{%
\begingroup
\let\do\@makeother \dospecials
\@commII}
\begingroup\catcode`\[1\catcode`\]2
\catcode`\{12\catcode`\}12
\long\gdef\@commII{[%
\long\def\@tempa ##1}[\endgroup]\@tempa]%
\endgroup
\let\setkeyword\comm@ntII
\let\setvariable\comm@ntII
\let\setconstant\comm@ntII
% \defschememathescape makes the succeeding grouped character an
% escape into latex math from within Scheme code;
% this character can't be }
\let\defschememathescape\comm@ntII
\let\undefschememathescape\comm@ntII
% telling SLaTeX that a certain Scheme identifier is to
% be replaced by the specified LaTeX expression.
% Useful for generating ``mathematical''-looking
% typeset code even though the corresponding Scheme
% code is ascii as usual and doesn't violate
% identifier-naming rules
\def\setspecialsymbol{%
\begingroup
\let\do\@makeother \dospecials
\@commIII}
\begingroup\catcode`\[1\catcode`\]2
\catcode`\{12\catcode`\}12
\long\gdef\@commIII{[%
\long\def\@tempa ##1}[\endgroup\@gobbleI]\@tempa]%
\endgroup
\def\@gobbleI#1{}
% \unsetspecialsymbol strips Scheme identifier(s) of
% any ``mathematical'' look lent by the above
\let\unsetspecialsymbol\comm@ntII
% enabling/disabling slatex
\def\slatexdisable#1{\expandafter\gdef\csname#1\endcsname{}}
% \schemecasesensitive takes either true or false as
% argument
\def\schemecasesensitive#1{}
%for latex only: use \slatexseparateincludes before the
%occurrence of any Scheme code in your file, if you
%want the various \include'd files to have their own
%pool of temporary slatex files. This lets you juggle
%your \include's in successive runs of LaTeX without
%having to worry that the temp. files may interfere.
%By default, only a single pool of temp files is used.
%Warning: On DOS, if your \include'd files have fairly
%similar names, avoid \slatexseparateincludes since the
%short filenames on DOS will likely confuse the temp
%file pools of different \include files.
\def\slatexseparateincludes{%
\gdef\include##1{{\def\subjobname{##1}%
\sch@mefilenamecount=-1%
\@include##1 }}}
% convenient abbreviations for characters
\begingroup
\catcode`\|=0
|catcode`|\=12
|gdef|ttbackslash{{|tt|catcode`|\=12\}}
|endgroup
\mathchardef\lt="313C
\mathchardef\gt="313E
\begingroup
\catcode`\@12%
\global\let\atsign@%
\endgroup
\chardef\dq=`\"
% leading character of slatex filenames: . for unix to
% keep them out of the way
\def\filehider{.}
% since the above doesn't work of dos, slatex on dos
% will use a different character, and make the
% redefinition available through the following
\inputifpossible{xZfilhid.tex}
% @ is no longer a letter for TeX
\ifusinglatex\relax\else
\catcode`@\atcatcodebeforeslatex
\fi
\message{*** Check: Are you sure you called SLaTeX? ***}

1020
benchmarks/new/r6rs-benchmarks/todo-src/smlboyer.scm Normal file
View File

File diff suppressed because it is too large Load Diff

29
benchmarks/new/r6rs-benchmarks/todo-src/string.scm Normal file
View File

@ -0,0 +1,29 @@
;;; STRING -- One of the Kernighan and Van Wyk benchmarks.
(define s "abcdef")
(define (grow)
(set! s (string-append "123" s "456" s "789"))
(set! s (string-append
(substring s (quotient (string-length s) 2) (string-length s))
(substring s 0 (+ 1 (quotient (string-length s) 2)))))
s)
(define (trial n)
(do ((i 0 (+ i 1)))
((> (string-length s) n) (string-length s))
(grow)))
(define (my-try n)
(do ((i 0 (+ i 1)))
((>= i 10) (string-length s))
(set! s "abcdef")
(trial n)))
(define (main . args)
(run-benchmark
"string"
string-iters
(lambda (result) (equal? result 524278))
(lambda (n) (lambda () (my-try n)))
500000))

10
benchmarks/new/r6rs-benchmarks/todo-src/succeed.scm Normal file
View File

@ -0,0 +1,10 @@
;;; SUCCEED - Test of success condition.
(define (main . args)
(run-benchmark
"succeed"
1
(lambda (result)
(equal? result #f))
(lambda (f) (lambda () f))
#f))

15
benchmarks/new/r6rs-benchmarks/todo-src/sum.scm Normal file
View File

@ -0,0 +1,15 @@
;;; SUM -- Compute sum of integers from 0 to 10000
(define (run n)
(let loop ((i n) (sum 0))
(if (< i 0)
sum
(loop (- i 1) (+ i sum)))))
(define (main . args)
(run-benchmark
"sum"
sum-iters
(lambda (result) (equal? result 50005000))
(lambda (n) (lambda () (run n)))
10000))

26
benchmarks/new/r6rs-benchmarks/todo-src/sum1.scm Normal file
View File

@ -0,0 +1,26 @@
;;; SUM1 -- One of the Kernighan and Van Wyk benchmarks.
(define inport #f)
(define (sumport port sum-so-far)
(let ((x (read port)))
(if (eof-object? x)
sum-so-far
(sumport port (FLOAT+ x sum-so-far)))))
(define (sum port)
(sumport port 0.0))
(define (go)
(set! inport (open-input-file "../../src/rn100"))
(let ((result (sum inport)))
(close-input-port inport)
result))
(define (main . args)
(run-benchmark
"sum1"
sum1-iters
(lambda (result) (and (FLOAT>= result 15794.974999999)
(FLOAT<= result 15794.975000001)))
(lambda () (lambda () (go)))))

15
benchmarks/new/r6rs-benchmarks/todo-src/sumfp.scm Normal file
View File

@ -0,0 +1,15 @@
;;; SUMFP -- Compute sum of integers from 0 to 10000 using floating point
(define (run n)
(let loop ((i n) (sum 0.))
(if (FLOAT< i 0.)
sum
(loop (FLOAT- i 1.) (FLOAT+ i sum)))))
(define (main . args)
(run-benchmark
"sumfp"
sumfp-iters
(lambda (result) (equal? result 50005000.))
(lambda (n) (lambda () (run n)))
10000.))

27
benchmarks/new/r6rs-benchmarks/todo-src/sumloop.scm Normal file
View File

@ -0,0 +1,27 @@
;;; SUMLOOP -- One of the Kernighan and Van Wyk benchmarks.
(define sum 0)
(define (tail-rec-aux i n)
(if (< i n)
(begin (set! sum (+ sum 1)) (tail-rec-aux (+ i 1) n))
sum))
(define (tail-rec-loop n)
(set! sum 0)
(tail-rec-aux 0 n)
sum)
(define (do-loop n)
(set! sum 0)
(do ((i 0 (+ i 1)))
((>= i n) sum)
(set! sum (+ sum 1))))
(define (main . args)
(run-benchmark
"sumloop"
sumloop-iters
(lambda (result) (equal? result 100000000))
(lambda (n) (lambda () (do-loop n)))
100000000))

37
benchmarks/new/r6rs-benchmarks/todo-src/tail.scm Normal file
View File

@ -0,0 +1,37 @@
;;; TAIL -- One of the Kernighan and Van Wyk benchmarks.
(define inport #f)
(define outport #f)
(define (readline port line-so-far)
(let ((x (read-char port)))
(cond ((eof-object? x)
x)
((char=? x #\newline)
(list->string (reverse
(cons x line-so-far))))
(#t (readline port (cons x line-so-far))))))
(define (tail-r-aux port file-so-far)
(let ((x (readline port '())))
(if (eof-object? x)
(begin
(display file-so-far outport)
(close-output-port outport))
(tail-r-aux port (cons x file-so-far)))))
(define (tail-r port)
(tail-r-aux port '()))
(define (go)
(set! inport (open-input-file "../../src/bib"))
(set! outport (open-output-file "foo"))
(tail-r inport)
(close-input-port inport))
(define (main . args)
(run-benchmark
"tail"
tail-iters
(lambda (result) #t)
(lambda () (lambda () (go)))))

27
benchmarks/new/r6rs-benchmarks/todo-src/tak.scm Normal file
View File

@ -0,0 +1,27 @@
;;; TAK -- A vanilla version of the TAKeuchi function.
(define (tak x y z)
(if (not (< y x))
z
(tak (tak (- x 1) y z)
(tak (- y 1) z x)
(tak (- z 1) x y))))
;;; (define (tak x y z)
;;; (if (not (#%$fx< y x))
;;; z
;;; (tak (tak (fxsub1 x) y z)
;;; (tak (fxsub1 y) z x)
;;; (tak (fxsub1 z) x y))))
(define (main . args)
(run-benchmark
"tak"
tak-iters
(lambda (result) (equal? result 7))
(lambda (x y z) (lambda () (tak x y z)))
18
12
6))

33
benchmarks/new/r6rs-benchmarks/todo-src/takl.scm Normal file
View File

@ -0,0 +1,33 @@
;;; TAKL -- The TAKeuchi function using lists as counters.
(define (listn n)
(if (= n 0)
'()
(cons n (listn (- n 1)))))
(define l18 (listn 18))
(define l12 (listn 12))
(define l6 (listn 6))
(define (mas x y z)
(if (not (shorterp y x))
z
(mas (mas (cdr x) y z)
(mas (cdr y) z x)
(mas (cdr z) x y))))
(define (shorterp x y)
(and (not (null? y))
(or (null? x)
(shorterp (cdr x)
(cdr y)))))
(define (main . args)
(run-benchmark
"takl"
takl-iters
(lambda (result) (equal? result '(7 6 5 4 3 2 1)))
(lambda (x y z) (lambda () (mas x y z)))
l18
l12
l6))

135
benchmarks/new/r6rs-benchmarks/todo-src/temp.scm Normal file
View File

@ -0,0 +1,135 @@
; Hacked to estimate cost of one closed call per character.
(define transcoder 'usual)
(define (slow-read-char in)
(if (eq? transcoder 'usual)
(read-char in)
(read-char (car (vector->list (make-vector 3 in))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Reading benchmarks.
;
; The timed portion of read-characters-from-file-port-benchmark
; uses read-char to read nboyer.sch 1000 times, performing
; file i/o each time.
;
; The timed portion of read-from-file-port-benchmark
; parses nboyer.sch 1000 times, performing file i/o
; each time.
;
; The timed portion of read-from-string-port-benchmark
; parses the string representation of nboyer.sch 1000 times.
;
; The output of that parse is checked by comparing it
; the the value returned by the read procedure.
;
; Usage:
; (read-from-file-port-benchmark n input)
; (read-from-string-port-benchmark n input)
;
; n defaults to 1000, and input defaults to "nboyer.sch".
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (read-characters-from-file-benchmark . rest)
(let* ((n (if (null? rest) 1000 (car rest)))
(input (if (or (null? rest) (null? (cdr rest)))
"nboyer.sch"
(cadr rest)))
(benchmark-name
(string-append "chario:file:" input ":" (number->string n))))
(run-benchmark benchmark-name
n
(lambda ()
(call-with-input-file
input
(lambda (in)
(do ((x (slow-read-char in) (slow-read-char in))
(n 0 (+ n 1)))
((eof-object? x) n)))))
(lambda (x) #t))))
(define (read-characters-from-string-benchmark . rest)
(let* ((n (if (null? rest) 1000 (car rest)))
(input (if (or (null? rest) (null? (cdr rest)))
"nboyer.sch"
(cadr rest)))
(input-string (read-file-as-string input))
(benchmark-name
(string-append "chario:string:" input ":" (number->string n))))
(run-benchmark benchmark-name
n
(lambda ()
(let ((in (open-input-string input-string)))
(do ((x (slow-read-char in) (slow-read-char in))
(n 0 (+ n 1)))
((eof-object? x) n))))
(lambda (x) #t))))
(define (read-from-file-benchmark . rest)
(let* ((n (if (null? rest) 1000 (car rest)))
(input (if (or (null? rest) (null? (cdr rest)))
"nboyer.sch"
(cadr rest)))
(answer (call-with-input-file
input
(lambda (in)
(do ((x (read in) (read in))
(answer '() x))
((eof-object? x)
answer)))))
(benchmark-name
(string-append "reading:file:" input ":" (number->string n))))
(run-benchmark benchmark-name
n
(lambda ()
(call-with-input-file
input
(lambda (in)
(do ((x (read in) (read in))
(y #f x))
((eof-object? x) y)))))
(lambda (x) (equal? x answer)))))
(define (read-from-string-benchmark . rest)
(let* ((n (if (null? rest) 1000 (car rest)))
(input (if (or (null? rest) (null? (cdr rest)))
"nboyer.sch"
(cadr rest)))
(input-string (read-file-as-string input))
(answer (call-with-input-file
input
(lambda (in)
(do ((x (read in) (read in))
(answer '() x))
((eof-object? x)
answer)))))
(benchmark-name
(string-append "reading:string:" input ":" (number->string n))))
(run-benchmark benchmark-name
n
(lambda ()
(let ((in (open-input-string input-string)))
(do ((x (read in) (read in))
(y #f x))
((eof-object? x) y))))
(lambda (x) (equal? x answer)))))
(define (read-file-as-string name)
(call-with-input-file
name
(lambda (in)
(do ((x (read-char in) (read-char in))
(chars '() (cons x chars)))
((eof-object? x)
(list->string (reverse chars)))))))
(define (main . args)
(run-benchmark
"slow-read-chars-from-string"
1
(lambda ()
(read-characters-from-string-benchmark reading-iters))
(lambda (result) #t)))

16
benchmarks/new/r6rs-benchmarks/todo-src/temp2.scm Normal file
View File

@ -0,0 +1,16 @@
;;; FIBFP -- Computes fib(25) using floating point
(define (fibfp n)
(write n)
(newline)
(if (< n 2.)
n
(+ (fibfp (- n 1.))
(fibfp (- n 2.)))))
(define (main . args)
(run-benchmark
"fibfp"
fibfp-iters
(lambda () (fibfp 1.))
(lambda (result) (equal? result 75025.))))

6532
benchmarks/new/r6rs-benchmarks/todo-src/test.scm Normal file
View File

File diff suppressed because it is too large Load Diff

1658
benchmarks/new/r6rs-benchmarks/todo-src/test.tex Normal file
View File

File diff suppressed because it is too large Load Diff

28
benchmarks/new/r6rs-benchmarks/todo-src/tfib.scm Normal file
View File

@ -0,0 +1,28 @@
;;; TFIB -- Like FIB but using threads.
(define (tfib n)
(if (< n 2)
1
(let ((x (make-thread (lambda () (tfib (- n 2))))))
(thread-start! x)
(let ((y (tfib (- n 1))))
(+ (thread-join! x) y)))))
(define (go n repeat)
(let loop ((repeat repeat)
(result '()))
(if (> repeat 0)
(let ((x (make-thread (lambda () (tfib n)))))
(thread-start! x)
(let ((r (thread-join! x)))
(loop (- repeat 1) r)))
result)))
(define (main . args)
(run-benchmark
"tfib"
tfib-iters
(lambda (result) (equal? result 610))
(lambda (n repeat) (lambda () (go n repeat)))
14
100))

144
benchmarks/new/r6rs-benchmarks/todo-src/trav1.scm Normal file
View File

@ -0,0 +1,144 @@
;;; TRAV1 -- Benchmark which creates and traverses a tree structure.
(define (make-node)
(vector 'node '() '() (snb) #f #f #f #f #f #f #f))
(define (node-parents node) (vector-ref node 1))
(define (node-sons node) (vector-ref node 2))
(define (node-sn node) (vector-ref node 3))
(define (node-entry1 node) (vector-ref node 4))
(define (node-entry2 node) (vector-ref node 5))
(define (node-entry3 node) (vector-ref node 6))
(define (node-entry4 node) (vector-ref node 7))
(define (node-entry5 node) (vector-ref node 8))
(define (node-entry6 node) (vector-ref node 9))
(define (node-mark node) (vector-ref node 10))
(define (node-parents-set! node v) (vector-set! node 1 v))
(define (node-sons-set! node v) (vector-set! node 2 v))
(define (node-sn-set! node v) (vector-set! node 3 v))
(define (node-entry1-set! node v) (vector-set! node 4 v))
(define (node-entry2-set! node v) (vector-set! node 5 v))
(define (node-entry3-set! node v) (vector-set! node 6 v))
(define (node-entry4-set! node v) (vector-set! node 7 v))
(define (node-entry5-set! node v) (vector-set! node 8 v))
(define (node-entry6-set! node v) (vector-set! node 9 v))
(define (node-mark-set! node v) (vector-set! node 10 v))
(define *sn* 0)
(define *rand* 21)
(define *count* 0)
(define *marker* #f)
(define *root* '())
(define (snb)
(set! *sn* (+ 1 *sn*))
*sn*)
(define (seed)
(set! *rand* 21)
*rand*)
(define (traverse-random)
(set! *rand* (remainder (* *rand* 17) 251))
*rand*)
(define (traverse-remove n q)
(cond ((eq? (cdr (car q)) (car q))
(let ((x (caar q))) (set-car! q '()) x))
((= n 0)
(let ((x (caar q)))
(do ((p (car q) (cdr p)))
((eq? (cdr p) (car q))
(set-cdr! p (cdr (car q)))
(set-car! q p)))
x))
(else (do ((n n (- n 1))
(q (car q) (cdr q))
(p (cdr (car q)) (cdr p)))
((= n 0) (let ((x (car q))) (set-cdr! q p) x))))))
(define (traverse-select n q)
(do ((n n (- n 1))
(q (car q) (cdr q)))
((= n 0) (car q))))
(define (add a q)
(cond ((null? q)
`(,(let ((x `(,a)))
(set-cdr! x x) x)))
((null? (car q))
(let ((x `(,a)))
(set-cdr! x x)
(set-car! q x)
q))
; the CL version had a useless set-car! in the next line (wc)
(else (set-cdr! (car q) `(,a ,@(cdr (car q))))
q)))
(define (create-structure n)
(let ((a `(,(make-node))))
(do ((m (- n 1) (- m 1))
(p a))
((= m 0)
(set! a `(,(begin (set-cdr! p a) p)))
(do ((unused a)
(used (add (traverse-remove 0 a) '()))
(x '())
(y '()))
((null? (car unused))
(find-root (traverse-select 0 used) n))
(set! x (traverse-remove (remainder (traverse-random) n) unused))
(set! y (traverse-select (remainder (traverse-random) n) used))
(add x used)
(node-sons-set! y `(,x ,@(node-sons y)))
(node-parents-set! x `(,y ,@(node-parents x))) ))
(set! a (cons (make-node) a)))))
(define (find-root node n)
(do ((n n (- n 1)))
((or (= n 0) (null? (node-parents node)))
node)
(set! node (car (node-parents node)))))
(define (travers node mark)
(cond ((eq? (node-mark node) mark) #f)
(else (node-mark-set! node mark)
(set! *count* (+ 1 *count*))
(node-entry1-set! node (not (node-entry1 node)))
(node-entry2-set! node (not (node-entry2 node)))
(node-entry3-set! node (not (node-entry3 node)))
(node-entry4-set! node (not (node-entry4 node)))
(node-entry5-set! node (not (node-entry5 node)))
(node-entry6-set! node (not (node-entry6 node)))
(do ((sons (node-sons node) (cdr sons)))
((null? sons) #f)
(travers (car sons) mark)))))
(define (traverse root)
(let ((*count* 0))
(travers root (begin (set! *marker* (not *marker*)) *marker*))
*count*))
(define (init-traverse) ; Changed from defmacro to defun \bs
(set! *root* (create-structure 100))
#f)
(define (run-traverse) ; Changed from defmacro to defun \bs
(do ((i 50 (- i 1)))
((= i 0))
(traverse *root*)
(traverse *root*)
(traverse *root*)
(traverse *root*)
(traverse *root*)))
;;; to initialize, call: (init-traverse)
;;; to run traverse, call: (run-traverse)
(define (main . args)
(run-benchmark
"trav1"
trav1-iters
(lambda (result) #t)
(lambda () (lambda () (init-traverse)))))

146
benchmarks/new/r6rs-benchmarks/todo-src/trav2.scm Normal file
View File

@ -0,0 +1,146 @@
;;; TRAV2 -- Benchmark which creates and traverses a tree structure.
(define (make-node)
(vector 'node '() '() (snb) #f #f #f #f #f #f #f))
(define (node-parents node) (vector-ref node 1))
(define (node-sons node) (vector-ref node 2))
(define (node-sn node) (vector-ref node 3))
(define (node-entry1 node) (vector-ref node 4))
(define (node-entry2 node) (vector-ref node 5))
(define (node-entry3 node) (vector-ref node 6))
(define (node-entry4 node) (vector-ref node 7))
(define (node-entry5 node) (vector-ref node 8))
(define (node-entry6 node) (vector-ref node 9))
(define (node-mark node) (vector-ref node 10))
(define (node-parents-set! node v) (vector-set! node 1 v))
(define (node-sons-set! node v) (vector-set! node 2 v))
(define (node-sn-set! node v) (vector-set! node 3 v))
(define (node-entry1-set! node v) (vector-set! node 4 v))
(define (node-entry2-set! node v) (vector-set! node 5 v))
(define (node-entry3-set! node v) (vector-set! node 6 v))
(define (node-entry4-set! node v) (vector-set! node 7 v))
(define (node-entry5-set! node v) (vector-set! node 8 v))
(define (node-entry6-set! node v) (vector-set! node 9 v))
(define (node-mark-set! node v) (vector-set! node 10 v))
(define *sn* 0)
(define *rand* 21)
(define *count* 0)
(define *marker* #f)
(define *root* '())
(define (snb)
(set! *sn* (+ 1 *sn*))
*sn*)
(define (seed)
(set! *rand* 21)
*rand*)
(define (traverse-random)
(set! *rand* (remainder (* *rand* 17) 251))
*rand*)
(define (traverse-remove n q)
(cond ((eq? (cdr (car q)) (car q))
(let ((x (caar q))) (set-car! q '()) x))
((= n 0)
(let ((x (caar q)))
(do ((p (car q) (cdr p)))
((eq? (cdr p) (car q))
(set-cdr! p (cdr (car q)))
(set-car! q p)))
x))
(else (do ((n n (- n 1))
(q (car q) (cdr q))
(p (cdr (car q)) (cdr p)))
((= n 0) (let ((x (car q))) (set-cdr! q p) x))))))
(define (traverse-select n q)
(do ((n n (- n 1))
(q (car q) (cdr q)))
((= n 0) (car q))))
(define (add a q)
(cond ((null? q)
`(,(let ((x `(,a)))
(set-cdr! x x) x)))
((null? (car q))
(let ((x `(,a)))
(set-cdr! x x)
(set-car! q x)
q))
; the CL version had a useless set-car! in the next line (wc)
(else (set-cdr! (car q) `(,a ,@(cdr (car q))))
q)))
(define (create-structure n)
(let ((a `(,(make-node))))
(do ((m (- n 1) (- m 1))
(p a))
((= m 0)
(set! a `(,(begin (set-cdr! p a) p)))
(do ((unused a)
(used (add (traverse-remove 0 a) '()))
(x '())
(y '()))
((null? (car unused))
(find-root (traverse-select 0 used) n))
(set! x (traverse-remove (remainder (traverse-random) n) unused))
(set! y (traverse-select (remainder (traverse-random) n) used))
(add x used)
(node-sons-set! y `(,x ,@(node-sons y)))
(node-parents-set! x `(,y ,@(node-parents x))) ))
(set! a (cons (make-node) a)))))
(define (find-root node n)
(do ((n n (- n 1)))
((or (= n 0) (null? (node-parents node)))
node)
(set! node (car (node-parents node)))))
(define (travers node mark)
(cond ((eq? (node-mark node) mark) #f)
(else (node-mark-set! node mark)
(set! *count* (+ 1 *count*))
(node-entry1-set! node (not (node-entry1 node)))
(node-entry2-set! node (not (node-entry2 node)))
(node-entry3-set! node (not (node-entry3 node)))
(node-entry4-set! node (not (node-entry4 node)))
(node-entry5-set! node (not (node-entry5 node)))
(node-entry6-set! node (not (node-entry6 node)))
(do ((sons (node-sons node) (cdr sons)))
((null? sons) #f)
(travers (car sons) mark)))))
(define (traverse root)
(let ((*count* 0))
(travers root (begin (set! *marker* (not *marker*)) *marker*))
*count*))
(define (init-traverse) ; Changed from defmacro to defun \bs
(set! *root* (create-structure 100))
#f)
(define (run-traverse) ; Changed from defmacro to defun \bs
(do ((i 50 (- i 1)))
((= i 0))
(traverse *root*)
(traverse *root*)
(traverse *root*)
(traverse *root*)
(traverse *root*)))
;;; to initialize, call: (init-traverse)
;;; to run traverse, call: (run-traverse)
(init-traverse)
(define (main . args)
(run-benchmark
"trav2"
trav2-iters
(lambda (result) #t)
(lambda () (lambda () (run-traverse)))))

60
benchmarks/new/r6rs-benchmarks/todo-src/triangl.scm Normal file
View File

@ -0,0 +1,60 @@
;;; TRIANGL -- Board game benchmark.
(define *board*
(list->vector '(1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1)))
(define *sequence*
(list->vector '(0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
(define *a*
(list->vector '(1 2 4 3 5 6 1 3 6 2 5 4 11 12
13 7 8 4 4 7 11 8 12 13 6 10
15 9 14 13 13 14 15 9 10
6 6)))
(define *b*
(list->vector '(2 4 7 5 8 9 3 6 10 5 9 8
12 13 14 8 9 5 2 4 7 5 8
9 3 6 10 5 9 8 12 13 14
8 9 5 5)))
(define *c*
(list->vector '(4 7 11 8 12 13 6 10 15 9 14 13
13 14 15 9 10 6 1 2 4 3 5 6 1
3 6 2 5 4 11 12 13 7 8 4 4)))
(define *answer* '())
(define (attempt i depth)
(cond ((= depth 14)
(set! *answer*
(cons (cdr (vector->list *sequence*)) *answer*))
#t)
((and (= 1 (vector-ref *board* (vector-ref *a* i)))
(= 1 (vector-ref *board* (vector-ref *b* i)))
(= 0 (vector-ref *board* (vector-ref *c* i))))
(vector-set! *board* (vector-ref *a* i) 0)
(vector-set! *board* (vector-ref *b* i) 0)
(vector-set! *board* (vector-ref *c* i) 1)
(vector-set! *sequence* depth i)
(do ((j 0 (+ j 1))
(depth (+ depth 1)))
((or (= j 36) (attempt j depth)) #f))
(vector-set! *board* (vector-ref *a* i) 1)
(vector-set! *board* (vector-ref *b* i) 1)
(vector-set! *board* (vector-ref *c* i) 0) #f)
(else #f)))
(define (test i depth)
(set! *answer* '())
(attempt i depth)
(car *answer*))
(define (main . args)
(run-benchmark
"triangl"
triangl-iters
(lambda (result) (equal? result '(22 34 31 15 7 1 20 17 25 6 5 13 32)))
(lambda (i depth) (lambda () (test i depth)))
22
1))

43
benchmarks/new/r6rs-benchmarks/todo-src/wc.scm Normal file
View File

@ -0,0 +1,43 @@
;;; WC -- One of the Kernighan and Van Wyk benchmarks.
(define inport #f)
(define nl #f)
(define nw #f)
(define nc #f)
(define inword #f)
(define (wcport port)
(let ((x (read-char port)))
(if (eof-object? x)
(begin
(list nl nw nc))
(begin
(set! nc (+ nc 1))
(if (char=? x #\newline)
(set! nl (+ nl 1)))
(if (or (char=? x #\space)
(char=? x #\newline))
(set! inword #f)
(if (not inword)
(begin
(set! nw (+ nw 1))
(set! inword #t))))
(wcport port)))))
(define (go)
(set! inport (open-input-file "../../src/bib"))
(set! nl 0)
(set! nw 0)
(set! nc 0)
(set! inword #f)
(let ((result (wcport inport)))
(close-input-port inport)
result))
(define (main . args)
(run-benchmark
"wc"
wc-iters
(lambda (result) (equal? result '(31102 851820 4460056)))
(lambda () (lambda () (go)))))

449
benchmarks/results.Larceny-r6rs
View File

@ -5560,3 +5560,452 @@ Words allocated: 0
Words reclaimed: 0
Elapsed time...: 1795 ms (User: 1781 ms; System: 4 ms)
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 10:36:59 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing cat under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 0
Words reclaimed: 0
Elapsed time...: 545 ms (User: 375 ms; System: 131 ms)
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 11:02:20 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing dynamic under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 14942078
Words reclaimed: 0
Elapsed time...: 782 ms (User: 716 ms; System: 63 ms)
Elapsed GC time: 191 ms (CPU: 192 in 57 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 11:04:14 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing earley under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 123206268
Words reclaimed: 0
Elapsed time...: 2057 ms (User: 1947 ms; System: 96 ms)
Elapsed GC time: 583 ms (CPU: 586 in 470 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 11:56:08 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing gcbench under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
> The garbage collector should touch about 32 megabytes of heap storage.
The use of more or less memory will skew the results.
Garbage Collector Test
Stretching memory with a binary tree of depth 18
Total memory available= ???????? bytes Free memory= ???????? bytes
GCBench: Main
Creating a long-lived binary tree of depth 16
Creating a long-lived array of 524284 inexact reals
Total memory available= ???????? bytes Free memory= ???????? bytes
Creating 33824 trees of depth 4
GCBench: Top down construction
GCBench: Bottom up construction
Creating 8256 trees of depth 6
GCBench: Top down construction
GCBench: Bottom up construction
Creating 2052 trees of depth 8
GCBench: Top down construction
GCBench: Bottom up construction
Creating 512 trees of depth 10
GCBench: Top down construction
GCBench: Bottom up construction
Creating 128 trees of depth 12
GCBench: Top down construction
GCBench: Bottom up construction
Creating 32 trees of depth 14
GCBench: Top down construction
GCBench: Bottom up construction
Creating 8 trees of depth 16
GCBench: Top down construction
GCBench: Bottom up construction
Total memory available= ???????? bytes Free memory= ???????? bytes
Words allocated: 94867544
Words reclaimed: 0
Elapsed time...: 1890 ms (User: 1598 ms; System: 261 ms)
Elapsed GC time: 1163 ms (CPU: 1143 in 360 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 12:52:42 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing graphs under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 157021446
Words reclaimed: 0
Elapsed time...: 1666 ms (User: 1632 ms; System: 26 ms)
Elapsed GC time: 271 ms (CPU: 273 in 599 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 12:54:37 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing lattice under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 19398398
Words reclaimed: 0
Elapsed time...: 1697 ms (User: 1683 ms; System: 6 ms)
Elapsed GC time: 26 ms (CPU: 23 in 74 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:01:48 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing matrix under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 87555006
Words reclaimed: 0
Elapsed time...: 1887 ms (User: 1862 ms; System: 16 ms)
Elapsed GC time: 129 ms (CPU: 121 in 334 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:03:31 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing gcold under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
> 25 megabytes
0 work units per step.
promotion ratio is 1:10
pointer mutation rate is 10
10000 steps
Allocating 76 trees.
(24902160 bytes)
(1245108 nodes)
Initialization complete...
Words allocated: 2754230651
Words reclaimed: 0
Elapsed time...: 25198 ms (User: 20937 ms; System: 4116 ms)
Elapsed GC time: 13601 ms (CPU: 13514 in 10508 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:11:26 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing mazefun under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 47447672
Words reclaimed: 0
Elapsed time...: 1311 ms (User: 1290 ms; System: 12 ms)
Elapsed GC time: 73 ms (CPU: 73 in 181 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:16:38 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing mbrot under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 551809449
Words reclaimed: 0
Elapsed time...: 2262 ms (User: 2231 ms; System: 21 ms)
Elapsed GC time: 767 ms (CPU: 768 in 2105 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:19:56 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing nbody under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
> bench DIED!
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:22:05 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing nboyer under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 50855620
Words reclaimed: 0
Elapsed time...: 1700 ms (User: 1609 ms; System: 83 ms)
Elapsed GC time: 427 ms (CPU: 431 in 194 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:24:45 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing nqueens under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 71302772
Words reclaimed: 0
Elapsed time...: 1610 ms (User: 1585 ms; System: 15 ms)
Elapsed GC time: 103 ms (CPU: 100 in 272 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:28:51 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing ntakl under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
bench DIED!
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:29:16 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing ntakl under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 0
Words reclaimed: 0
Elapsed time...: 909 ms (User: 901 ms; System: 3 ms)
Elapsed GC time: 0 ms (CPU: 0 in 0 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:32:53 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing paraffins under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 201324942
Words reclaimed: 0
Elapsed time...: 4357 ms (User: 3778 ms; System: 547 ms)
Elapsed GC time: 2476 ms (CPU: 2448 in 768 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:38:20 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing parsing under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 100923902
Words reclaimed: 0
Elapsed time...: 6664 ms (User: 6537 ms; System: 90 ms)
Elapsed GC time: 292 ms (CPU: 284 in 385 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:45:51 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing perm9 under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 27000532
Words reclaimed: 0
Elapsed time...: 1559 ms (User: 1337 ms; System: 211 ms)
Elapsed GC time: 1010 ms (CPU: 1005 in 103 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:51:36 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing pnpoly under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 72351712
Words reclaimed: 0
Elapsed time...: 1470 ms (User: 1454 ms; System: 6 ms)
Elapsed GC time: 105 ms (CPU: 102 in 276 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:53:57 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing peval under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
Words allocated: 34340444
Words reclaimed: 0
Elapsed time...: 1277 ms (User: 1257 ms; System: 11 ms)
Elapsed GC time: 58 ms (CPU: 54 in 131 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Jun 13 13:56:32 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
Testing pi under Larceny-r6rs
Compiling...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>
>
Running...
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
>

4
benchmarks/src/ntakl.scm
View File

@ -41,5 +41,5 @@
(run-benchmark
"ntakl"
takl-iters
(lambda () (mas l18 l12 l6))
(lambda (result) (equal? result '(7 6 5 4 3 2 1)))))
(lambda (result) (equal? result '(7 6 5 4 3 2 1)))
(lambda () (lambda () (mas l18 l12 l6)))))