From e7423b9c7511bae38ed31b58a0433a64fa4bf67c Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Wed, 15 Feb 1995 13:07:53 +0000 Subject: [PATCH] Initial revision --- v8/src/bench/boyer.scm | 589 ++++++++++++++++++++++++++++++++++ v8/src/bench/browse.scm | 185 +++++++++++ v8/src/bench/conform.scm | 558 ++++++++++++++++++++++++++++++++ v8/src/bench/cpstak.scm | 41 +++ v8/src/bench/ctak.scm | 57 ++++ v8/src/bench/dderiv.scm | 91 ++++++ v8/src/bench/deriv.scm | 60 ++++ v8/src/bench/destruct.scm | 67 ++++ v8/src/bench/div.scm | 59 ++++ v8/src/bench/earley.scm | 650 ++++++++++++++++++++++++++++++++++++++ v8/src/bench/fib.scm | 9 + v8/src/bench/library.scm | 17 + v8/src/bench/matmul1.scm | 46 +++ v8/src/bench/matmul2.scm | 46 +++ v8/src/bench/peval.scm | 619 ++++++++++++++++++++++++++++++++++++ v8/src/bench/puzzle.scm | 168 ++++++++++ v8/src/bench/run.scm | 58 ++++ v8/src/bench/tak.scm | 30 ++ v8/src/bench/takl.scm | 49 +++ v8/src/bench/traverse.scm | 162 ++++++++++ v8/src/bench/triangle.scm | 78 +++++ 21 files changed, 3639 insertions(+) create mode 100644 v8/src/bench/boyer.scm create mode 100644 v8/src/bench/browse.scm create mode 100644 v8/src/bench/conform.scm create mode 100644 v8/src/bench/cpstak.scm create mode 100644 v8/src/bench/ctak.scm create mode 100644 v8/src/bench/dderiv.scm create mode 100644 v8/src/bench/deriv.scm create mode 100644 v8/src/bench/destruct.scm create mode 100644 v8/src/bench/div.scm create mode 100644 v8/src/bench/earley.scm create mode 100644 v8/src/bench/fib.scm create mode 100644 v8/src/bench/library.scm create mode 100644 v8/src/bench/matmul1.scm create mode 100644 v8/src/bench/matmul2.scm create mode 100644 v8/src/bench/peval.scm create mode 100644 v8/src/bench/puzzle.scm create mode 100644 v8/src/bench/run.scm create mode 100644 v8/src/bench/tak.scm create mode 100644 v8/src/bench/takl.scm create mode 100644 v8/src/bench/traverse.scm create mode 100644 v8/src/bench/triangle.scm diff --git a/v8/src/bench/boyer.scm b/v8/src/bench/boyer.scm new file mode 100644 index 000000000..0ac8a88a4 --- /dev/null +++ b/v8/src/bench/boyer.scm @@ -0,0 +1,589 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: boyer.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) +; Language: Scheme (but see note) +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Note: This benchmark uses property lists. The procedures that must +; be supplied are get and put, where (put x y z) is equivalent to Common +; Lisp's (setf (get x y) z). +; Note: The Common Lisp version of this benchmark returns the wrong +; answer because it uses the Common Lisp equivalent of memv instead of +; member in the falsep and truep procedures. (The error arose because +; memv is called member in Common Lisp. Don't ask what member is called, +; unless you want to learn about keyword arguments.) This Scheme version +; may run a few percent slower than it would if it were equivalent to +; the Common Lisp version, but it works. + +;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer. +;;; Fairly CONS intensive. + +(define get #F) +(define put #F) + +(let ((properties '())) + (define (our-get x y) + (let ((x-cut (assq x properties))) + (if x-cut + (let ((value (assq y (cdr x-cut)))) + (if value (cdr value) '())) + '()))) + (define (our-put x y z) + (let ((x-cut (assq x properties))) + (if x-cut + (let ((value (assq y (cdr x-cut)))) + (if value + (set-cdr! value z) + (set-cdr! x-cut (cons (cons y z) (cdr x-cut))))) + (set! properties `((,x . ((,y . ,z))) ,@properties)))) + 'OK) + (set! get our-get) + (set! put our-put)) + +(define unify-subst '()) +(define temp-temp '()) + +(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 (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 ((begin (set! temp-temp (assq term alist)) + temp-temp) + (cdr temp-temp)) + (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 '()) ;;; JSM: was #f + (one-way-unify1 term1 term2))) + +(define (one-way-unify1 term1 term2) + (cond ((not (pair? term2)) + (cond ((begin (set! temp-temp (assq term2 unify-subst)) + temp-temp) + (equal? term1 (cdr temp-temp))) + (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 ((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) + '() '())) ;;; JSM was two #Fs + +(define (test) + (define ans '#f) + (define term '#f) + (set! term + (apply-subst + (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))))) + (set! ans (tautp term)) + ans) + +(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))) + +(setup) + +;;; make sure you've run (setup) then call: (test) + +(lambda () (test)) diff --git a/v8/src/bench/browse.scm b/v8/src/bench/browse.scm new file mode 100644 index 000000000..8aa14491e --- /dev/null +++ b/v8/src/bench/browse.scm @@ -0,0 +1,185 @@ +(declare (usual-integrations)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: browse.sch +; Description: The BROWSE benchmark from the Gabriel tests +; Author: Richard Gabriel +; Created: 8-Apr-85 +; Modified: 14-Jun-85 18:44:49 (Bob Shaw) +; 16-Aug-87 (Will Clinger) +; 22-Jan-88 (Will Clinger) +; Language: Scheme (but see notes below) +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Note: This benchmark has been run only in implementations in which +; the empty list is the same as #f, and may not work if that is not true. +; Note: This benchmark uses property lists. The procedures that must +; be supplied are get and put, where (put x y z) is equivalent to Common +; Lisp's (setf (get x y) z). +; Note: The Common Lisp version assumes that eq works on characters, +; which is not a portable assumption but is true in most implementations. +; This translation makes the same assumption about eq?. +; Note: The gensym procedure was left as in Common Lisp. Most Scheme +; implementations have something similar internally. +; Note: The original benchmark took the car or cdr of the empty list +; 14,600 times. Before explicit tests were added to protect the offending +; calls to car and cdr, MacScheme was spending a quarter of its run time +; in the exception handler recovering from those errors. + +; The next few definitions should be omitted if the Scheme implementation +; already provides them. + +(define gensym generate-uninterned-symbol) +(define get 2d-get) +(define put 2d-put!) + +(define (append! x y) + (if (null? x) + y + (do ((a x b) + (b (cdr x) (cdr b))) + ((null? b) + (set-cdr! a y) + x)))) + +(define (copy-tree x) + (if (not (pair? x)) + x + (cons (copy-tree (car x)) + (copy-tree (cdr x))))) + +;;; BROWSE -- Benchmark to create and browse through +;;; an AI-like data base of units. + +;;; 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 (copy-tree 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 (gensym) (gensym)) + (a '())) + ((= n 0) a) + (set! a (cons name a)) + (do ((i i (- i 1))) + ((zero? i)) + (put name (gensym) '#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 (gensym) '#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 (match pat dat alist) + (cond ((null? pat) + (null? dat)) + ((null? dat) '()) + ((or (eq? (car pat) '?) + (eq? (car pat) + (car dat))) + (match (cdr pat) (cdr dat) alist)) + ((eq? (car pat) '*) + (or (match (cdr pat) dat alist) + (match (cdr pat) (cdr dat) alist) + (match pat (cdr dat) alist))) + (else (cond ((not (pair? (car pat))) + (cond ((eq? (string-ref (symbol->string (car pat)) 0) + #\?) + (let ((val (assv (car pat) alist))) + (cond (val (match (cons (cdr val) + (cdr pat)) + dat alist)) + (else (match (cdr pat) + (cdr dat) + (cons (cons (car pat) + (car dat)) + alist)))))) + ((eq? (string-ref (symbol->string (car pat)) 0) + #\*) + (let ((val (assv (car pat) alist))) + (cond (val (match (append (cdr val) + (cdr pat)) + dat alist)) + (else + (do ((l '() + (append! l + (cons (if (null? d) + '() + (car d)) + '()))) + (e (cons '() dat) (cdr e)) + (d dat (if (null? d) '() (cdr d)))) + ((or (null? e) + (match (cdr pat) + d + (cons + (cons (car pat) l) + alist))) + (if (null? e) '#f '#t))))))))) + (else (and + (pair? (car dat)) + (match (car pat) + (car dat) alist) + (match (cdr pat) + (cdr dat) alist))))))) + +(define (browse) + (investigate + (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)))) + '((*a ?b *b ?b a *a a *b *a) + (*a *b *b *a (*a) (*b)) + (? ? * (b a) * ? ?)))) + +(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)) + (match (car pats) (car p) '()))))) + +;;; call: (browse) + +(lambda () (browse)) diff --git a/v8/src/bench/conform.scm b/v8/src/bench/conform.scm new file mode 100644 index 000000000..18d57115b --- /dev/null +++ b/v8/src/bench/conform.scm @@ -0,0 +1,558 @@ +(declare (usual-integrations)) + +;;; Functional and unstable + +(define (vector-copy v) + (let* ((length (vector-length v)) + (result (make-vector length))) + (let loop ((n 0)) + (vector-set! result n (vector-ref v n)) + (if (= n length) + v + (loop (+ n 1)))))) + +(define (sort obj pred) + (define (loop l) + (if (and (pair? l) (pair? (cdr l))) + (split l '() '()) + l)) + + (define (split l one two) + (if (pair? l) + (split (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))))) + + (cond ((or (pair? obj) (null? obj)) + (loop obj)) + ((vector? obj) + (sort! (vector-copy obj) pred)) + (else + (error "sort: argument should be a list or vector" obj)))) + +;; This merge sort is stable for partial orders (for predicates like +;; <=, rather than like <). + +(define (sort! v pred) + (define (sort-internal! vec temp low high) + (if (< low high) + (let* ((middle (quotient (+ low high) 2)) + (next (+ middle 1))) + (sort-internal! temp vec low middle) + (sort-internal! temp vec next high) + (let loop ((p low) (p1 low) (p2 next)) + (if (not (> p high)) + (cond ((> p1 middle) + (vector-set! vec p (vector-ref temp p2)) + (loop (+ p 1) p1 (+ p2 1))) + ((or (> p2 high) + (pred (vector-ref temp p1) + (vector-ref temp p2))) + (vector-set! vec p (vector-ref temp p1)) + (loop (+ p 1) (+ p1 1) p2)) + (else + (vector-set! vec p (vector-ref temp p2)) + (loop (+ p 1) p1 (+ p2 1))))))))) + + (if (not (vector? v)) + (error "sort!: argument not a vector" v)) + + (sort-internal! v + (vector-copy v) + 0 + (- (vector-length v) 1)) + v) + +;; 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-structure +; (internal-node +; (print-procedure (unparser/standard-method +; 'graph-node +; (lambda (state node) +; (unparse-object state (internal-node-name node)))))) +; name +; (green-edges '()) +; (red-edges '()) +; blue-edges) + +; Above is MIT version; below is portable + +(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)) + +; End of portability stuff + +(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)) + (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) (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-structure +; (blue-edge +; (print-procedure +; (unparser/standard-method +; 'blue-edge +; (lambda (state edge) +; (unparse-object state (blue-edge-operation edge)))))) +; operation arg-node res-node) + +; Above is MIT version; below is portable + +(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)) + +; End of portability stuff + +; 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)))) + +; Add a (new) blue edge to a node + +; (define (adjoin-blue-edge! blue-edge node) +; (let ((current-one (lookup-op (operation blue-edge) node))) +; (cond ((null? current-one) +; (set-blue-edges! node +; (cons blue-edge (blue-edges node)))) +; ((and (eq? (arg-node current-one) (arg-node blue-edge)) +; (eq? (res-node current-one) (res-node blue-edge))) +; 'OK) +; (else (error "Two non-equivalent blue edges for op" +; blue-edge node))))) + +;; GRAPHS + +; (define-structure +; (internal-graph +; (print-procedure +; (unparser/standard-method 'graph +; (lambda (state edge) +; (unparse-object state (map name (internal-graph-nodes edge))))))) +; nodes already-met already-joined) + +; Above is MIT version; below is portable + +(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)) + +; End of portability stuff + +; 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. ) 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 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) (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 (reset) + (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) + (reset) + (map name + (graph-nodes (make-lattice (make-graph a b c d any-node none-node) '#f)))) + +(define (go) + (reset) + (test)) + +;;; call: (go) + +(lambda () (go)) diff --git a/v8/src/bench/cpstak.scm b/v8/src/bench/cpstak.scm new file mode 100644 index 000000000..39c4962dd --- /dev/null +++ b/v8/src/bench/cpstak.scm @@ -0,0 +1,41 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: cpstak.sch +; Description: continuation-passing version of TAK +; Author: Will Clinger +; Created: 20-Aug-87 +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; CPSTAK -- A continuation-passing version of the TAK benchmark. +;;; A good test of first class procedures and tail recursion. + +(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))) + +;;; call: (cpstak 18 12 6) + +(lambda () + (cpstak 18 12 6) + (cpstak 18 12 6) + (cpstak 18 12 6) + (cpstak 18 12 6) + (cpstak 18 12 6)) \ No newline at end of file diff --git a/v8/src/bench/ctak.scm b/v8/src/bench/ctak.scm new file mode 100644 index 000000000..5f04a9f5d --- /dev/null +++ b/v8/src/bench/ctak.scm @@ -0,0 +1,57 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: ctak.sch +; Description: The ctak benchmark +; Author: Richard Gabriel +; Created: 5-Apr-85 +; Modified: 10-Apr-85 14:53:02 (Bob Shaw) +; 24-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; The original version of this benchmark used a continuation mechanism that +; is less powerful than call-with-current-continuation and also relied on +; dynamic binding, which is not provided in standard Scheme. Since the +; intent of the benchmark seemed to be to test non-local exits, the dynamic +; binding has been replaced here by lexical binding. + +; For Scheme the comment that follows should read: +;;; CTAK -- A version of the TAK procedure that uses continuations. + +;;; CTAK -- A version of the TAK function that uses the CATCH/THROW facility. + +(define (ctak x y z) + (call-with-current-continuation + (lambda (k) + (ctak-aux k x y z)))) + +(define (ctak-aux k x y z) + (cond ((not (< y x)) ;xy + (k z)) + (else + (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))))))) + +;;; call: (ctak 18 12 6) + +(lambda () (ctak 18 12 6)) diff --git a/v8/src/bench/dderiv.scm b/v8/src/bench/dderiv.scm new file mode 100644 index 000000000..b5cf41e15 --- /dev/null +++ b/v8/src/bench/dderiv.scm @@ -0,0 +1,91 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: dderiv.sch +; Description: DDERIV benchmark from the Gabriel tests +; Author: Vaughan Pratt +; Created: 8-Apr-85 +; Modified: 10-Apr-85 14:53:29 (Bob Shaw) +; 23-Jul-87 (Will Clinger) +; 9-Feb-88 (Will Clinger) +; Language: Scheme (but see note below) +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Note: This benchmark uses property lists. The procedures that must +; be supplied are get and put, where (put x y z) is equivalent to Common +; Lisp's (setf (get x y) z). + +;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt. + +;;; This benchmark is a variant of the simple symbolic derivative program +;;; (DERIV). The main change is that it is `table-driven.' Instead of using a +;;; large COND that branches on the CAR of the expression, this program finds +;;; the code that will take the derivative on the property list of the atom in +;;; the CAR position. So, when the expression is (+ . ), the code +;;; stored under the atom '+ with indicator DERIV will take and +;;; return the derivative for '+. The way that MacLisp does this is with the +;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an +;;; atomic name in that it expects an argument list and the compiler compiles +;;; code, but the name of the function with that code is stored on the +;;; property list of FOO under the indicator BAR, in this case. You may have +;;; to do something like: + +;;; :property keyword is not Common Lisp. + +; Returns the wrong answer for quotients. +; Fortunately these aren't used in the benchmark. + +(define get 2d-get) +(define put 2d-put!) + +(define (dderiv-aux a) + (list '_/ (dderiv a) a)) + +(define (+dderiv a) + (cons '_+ (map dderiv a))) + +(define (-dderiv a) + (cons '_- (map dderiv a))) + +(define (*dderiv a) + (list '_* (cons '_* a) + (cons '_+ (map dderiv-aux a)))) + +(define (/dderiv a) + (list '_- + (list '_/ + (dderiv (car a)) + (cadr a)) + (list '_/ + (car a) + (list '_* + (cadr a) + (cadr a) + (dderiv (cadr a)))))) + +(define (dderiv a) + (cond + ((not (pair? a)) + (cond ((eq? a 'x) 1) (else 0))) + (else (let ((dderiv (get (car a) '_dderiv))) + (cond (dderiv (dderiv (cdr a))) + (else 'error)))))) + +(define (run) + (do ((i 0 (+ i 1))) + ((= i 1000)) + (dderiv '(_+ (_* 3 x x) (_* a x x) (_* b x) 5)) + (dderiv '(_+ (_* 3 x x) (_* a x x) (_* b x) 5)) + (dderiv '(_+ (_* 3 x x) (_* a x x) (_* b x) 5)) + (dderiv '(_+ (_* 3 x x) (_* a x x) (_* b x) 5)) + (dderiv '(_+ (_* 3 x x) (_* a x x) (_* b x) 5)))) + +(put '_+ '_dderiv +dderiv) +(put '_- '_dderiv -dderiv) +(put '_* '_dderiv *dderiv) +(put '_/ '_dderiv /dderiv) + +;;; call: (run) + +(lambda () (run)) diff --git a/v8/src/bench/deriv.scm b/v8/src/bench/deriv.scm new file mode 100644 index 000000000..14ee09988 --- /dev/null +++ b/v8/src/bench/deriv.scm @@ -0,0 +1,60 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: deriv.sch +; Description: The DERIV benchmark from the Gabriel tests. +; Author: Vaughan Pratt +; Created: 8-Apr-85 +; Modified: 10-Apr-85 14:53:50 (Bob Shaw) +; 23-Jul-87 (Will Clinger) +; 9-Feb-88 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt. +;;; It uses a simple subset of Lisp and does a lot of CONSing. + +; Returns the wrong answer for quotients. +; Fortunately these aren't used in the benchmark. + +(define (deriv-aux a) (list '/ (deriv a) a)) + +(define (deriv a) + (cond + ((not (pair? a)) + (cond ((eq? a 'x) 1) (else 0))) + ((eq? (car a) '+) + (cons '+ (map deriv (cdr a)))) + ((eq? (car a) '-) + (cons '- (map deriv + (cdr a)))) + ((eq? (car a) '*) + (list '* + a + (cons '+ (map deriv-aux (cdr a))))) + ((eq? (car a) '/) + (list '- + (list '/ + (deriv (cadr a)) + (caddr a)) + (list '/ + (cadr a) + (list '* + (caddr a) + (caddr a) + (deriv (caddr a)))))) + (else 'error))) + +(define (run) + (do ((i 0 (+ i 1))) + ((= i 1000)) + (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)) + (deriv '(+ (* 3 x x) (* a x x) (* b x) 5)))) + +;;; call: (run) + +(lambda () (run) (run) (run) (run) (run)) diff --git a/v8/src/bench/destruct.scm b/v8/src/bench/destruct.scm new file mode 100644 index 000000000..0de974138 --- /dev/null +++ b/v8/src/bench/destruct.scm @@ -0,0 +1,67 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: destruct.sch +; Description: DESTRUCTIVE benchmark from Gabriel tests +; Author: Bob Shaw, HPLabs/ATC +; Created: 8-Apr-85 +; Modified: 10-Apr-85 14:54:12 (Bob Shaw) +; 23-Jul-87 (Will Clinger) +; 22-Jan-88 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; append! is no longer a standard Scheme procedure, so it must be defined +; for implementations that don't already have it. + +(define (append! x y) + (if (null? x) + y + (do ((a x b) + (b (cdr x) (cdr b))) + ((null? b) + (set-cdr! a y) + x)))) + +;;; DESTRU -- Destructive operation benchmark + +(define (destructive n m) + (let ((l (do ((i 10 (- i 1)) + (a '() (cons '() a))) + ((= i 0) a)))) + (do ((i n (- i 1))) + ((= i 0)) + (cond ((null? (car l)) + (do ((l l (cdr l))) + ((null? l)) + (or (car l) + (set-car! l (cons '() '()))) + (append! (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)))))))))))) + +;;; call: (destructive 600 50) + +(lambda () + (destructive 1200 100)) diff --git a/v8/src/bench/div.scm b/v8/src/bench/div.scm new file mode 100644 index 000000000..c5e335497 --- /dev/null +++ b/v8/src/bench/div.scm @@ -0,0 +1,59 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: div.sch +; Description: DIV benchmarks +; Author: Richard Gabriel +; Created: 8-Apr-85 +; Modified: 19-Jul-85 18:28:01 (Bob Shaw) +; 23-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s. +;;; This file contains a recursive as well as an iterative test. + +(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 (recursive-div2 l) + (cond ((null? l) '()) + (else (cons (car l) (recursive-div2 (cddr l)))))) + +(define (test-1 l) + (do ((i 300 (- i 1))) + ((= i 0)) + (iterative-div2 l) + (iterative-div2 l) + (iterative-div2 l) + (iterative-div2 l))) + +(define (test-2 l) + (do ((i 300 (- i 1))) + ((= i 0)) + (recursive-div2 l) + (recursive-div2 l) + (recursive-div2 l) + (recursive-div2 l))) + +;;; for the iterative test call: (test-1 *ll*) +;;; for the recursive test call: (test-2 *ll*) + +(lambda () (begin (test-1 *ll*) (test-2 *ll*))) + +(lambda () + (do ((i 10 (- i 1))) + ((= i 0)) + (test-1 *ll*) + (test-2 *ll*))) + diff --git a/v8/src/bench/earley.scm b/v8/src/bench/earley.scm new file mode 100644 index 000000000..08d8af4cd --- /dev/null +++ b/v8/src/bench/earley.scm @@ -0,0 +1,650 @@ +(declare (usual-integrations)) + +; File: "earley.scm" (c) 1990, Marc Feeley + +; Earley parser. + +; (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 (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) + +(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 (index 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 (index 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 (index nt nts)) + (add-conf conf nt nts predictors) + (loop (cdr l) (+ conf 1))) + (begin + (vector-set! steps conf (- (index 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 (index 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 (index (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* (index 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* (index 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* (index 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))))) + +(lambda () (test)) diff --git a/v8/src/bench/fib.scm b/v8/src/bench/fib.scm new file mode 100644 index 000000000..b13cdec71 --- /dev/null +++ b/v8/src/bench/fib.scm @@ -0,0 +1,9 @@ +(declare (usual-integrations)) + +(define (fib n) + (if (< n 2) + n + (+ (fib (- n 1)) + (fib (- n 2))))) + +(lambda () (fib 30)) diff --git a/v8/src/bench/library.scm b/v8/src/bench/library.scm new file mode 100644 index 000000000..4dfb01ccb --- /dev/null +++ b/v8/src/bench/library.scm @@ -0,0 +1,17 @@ +(declare (usual-integrations)) + + +(define assq/1 + (named-lambda (assq key alist) + (let loop ((alist* alist)) + (if (pair? alist*) + (begin + (if (not (pair? (car alist*))) + (error:wrong-type-argument alist "alist" 'assq)) + (if (eq? (car (car alist*)) key) + (car alist*) + (loop (cdr alist*)))) + (begin + (if (not (null? alist*)) + (error:wrong-type-argument alist "alist" 'assq)) + #F))))) diff --git a/v8/src/bench/matmul1.scm b/v8/src/bench/matmul1.scm new file mode 100644 index 000000000..ad3187d5a --- /dev/null +++ b/v8/src/bench/matmul1.scm @@ -0,0 +1,46 @@ +;; +;; Matrix multiply using matrices represented as vectors of vectors +;; matmul1 - integer matrix + +(declare (usual-integrations)) + +(define (make-initialized-vector length initialization) + (let ((vector (make-vector length))) + (let loop ((index 0)) + (if (< index length) + (begin + (vector-set! vector index (initialization index)) + (loop (1+ index))))) + vector)) + +(define (make-identity-matrix n) + (make-initialized-vector n + (lambda (i) + (make-initialized-vector n + (lambda (j) (if (= i j) 1 0)))))) + +(define (matmul-1 m1 m2) + (let ((p (vector-length m1)) + (q1 (vector-length (vector-ref m1 0))) + (q2 (vector-length m2)) + (r (vector-length (vector-ref m2 0)))) + (if (not (= q1 q2)) + (error "size mismatch" p q1 q2 r)) + + (make-initialized-vector p + (lambda (i) + (make-initialized-vector r + (lambda (k) + (let loop ((sum 0) (j 0)) + (if (< j q2) + (loop (+ (* (vector-ref (vector-ref m1 i) j) + (vector-ref (vector-ref m2 j) k)) + sum) + (+ j 1)) + sum)))))))) + +(define (test1 n) + (let ((id (make-identity-matrix n))) + (matmul-1 id id))) + +(lambda () (test1 100) #T) \ No newline at end of file diff --git a/v8/src/bench/matmul2.scm b/v8/src/bench/matmul2.scm new file mode 100644 index 000000000..b0f5c5a29 --- /dev/null +++ b/v8/src/bench/matmul2.scm @@ -0,0 +1,46 @@ +;; +;; Matrix multiply using matrices represented as vectors of vectors +;; matmul1 - float matrix + +(declare (usual-integrations)) + +(define (make-initialized-vector length initialization) + (let ((vector (make-vector length))) + (let loop ((index 0)) + (if (< index length) + (begin + (vector-set! vector index (initialization index)) + (loop (1+ index))))) + vector)) + +(define (make-identity-matrix n) + (make-initialized-vector n + (lambda (i) + (make-initialized-vector n + (lambda (j) (if (= i j) 1.0 0.0)))))) + +(define (matmul-1 m1 m2) + (let ((p (vector-length m1)) + (q1 (vector-length (vector-ref m1 0))) + (q2 (vector-length m2)) + (r (vector-length (vector-ref m2 0)))) + (if (not (= q1 q2)) + (error "size mismatch" p q1 q2 r)) + + (make-initialized-vector p + (lambda (i) + (make-initialized-vector r + (lambda (k) + (let loop ((sum 0) (j 0)) + (if (< j q2) + (loop (+ (* (vector-ref (vector-ref m1 i) j) + (vector-ref (vector-ref m2 j) k)) + sum) + (+ j 1)) + sum)))))))) + +(define (test1 n) + (let ((id (make-identity-matrix n))) + (matmul-1 id id))) + +(lambda () (test1 100) #T) \ No newline at end of file diff --git a/v8/src/bench/peval.scm b/v8/src/bench/peval.scm new file mode 100644 index 000000000..a84d4b9ef --- /dev/null +++ b/v8/src/bench/peval.scm @@ -0,0 +1,619 @@ +(declare (usual-integrations)) + +;------------------------------------------------------------------------------ +; +; A simple partial evaluator +; +; Marc Feeley (05/15/88) +; +;------------------------------------------------------------------------------ + +; 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 (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 + (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 + (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! (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 (apply + args))))) + (cons '* (lambda (args) + (and (every? number? args) (quot (apply * args))))) + (cons '- (lambda (args) + (and (> (length args) 0) + (every? number? args) + (quot (apply - args))))) + (cons '/ (lambda (args) + (and (> (length args) 1) + (every? number? args) + (quot (apply / 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 '> (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)))))) + (cons 'length (lambda (args) + (and (= (length args) 1) + (proper-list? (car args)) + (quot (length (car args)))))) + ) +) + +(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 proc args) + (partial-evaluate proc args)) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define example1 + '(lambda (a b c) + (if (null? a) b (+ (car a) c)))) + +;(try 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 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 example3 (list not-constant '1)) + +;(try 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 example4 (list 'x not-constant)) + +;(try 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 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 example6 '()) + +; . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +(define example7 + '(lambda (input) + (letrec ((copy (lambda (in) + (if (pair? in) + (cons (copy (car in)) + (copy (cdr in))) + in)))) + (copy input)))) + +;(try 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 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) + (list (try example1 (list '(10 11) not-constant '1)) + (try example2 (list not-constant '1)) + (try example3 (list not-constant '1)) + (try example3 (list '(1 2 3) not-constant)) + (try example4 (list 'x not-constant)) + (try example4 (list '(f 1 2 3) not-constant)) + (try example5 (list '5 not-constant)) + (try example6 '()) + (try 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 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))))) + +(lambda () (test)) diff --git a/v8/src/bench/puzzle.scm b/v8/src/bench/puzzle.scm new file mode 100644 index 000000000..0aee13448 --- /dev/null +++ b/v8/src/bench/puzzle.scm @@ -0,0 +1,168 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: puzzle.sch +; Description: PUZZLE benchmark +; Author: Richard Gabriel, after Forrest Baskett +; Created: 12-Apr-85 +; Modified: 12-Apr-85 14:20:23 (Bob Shaw) +; 11-Aug-87 (Will Clinger) +; 22-Jan-88 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (iota n) + (do ((n n (- n 1)) + (list '() (cons (- n 1) list))) + ((zero? n) list))) + +;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal. + +(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))) + ; (newline) + ; (display "*Puzzle* filled") + (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)) + ;(trial-output (+ i 1) (+ k 1)) + (set! *kount* (+ *kount* 1)) + (return '#t)) + (else (puzzle-remove i j)))))))))))) + +(define (trial-output x y) + (newline) + (display (string-append "Piece " + (number->string x) + " at " + (number->string y) + "."))) + +(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) + (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.")))) + (cond ((trial n) + (begin (newline) + (display "Success in ") + (write *kount*) + (display " trials."))) + (else (begin (newline) (display "Failure.")))))) + +(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1)))) + (iota (+ typemax 1))) + +;;; call: (start) + +(lambda () (start)) diff --git a/v8/src/bench/run.scm b/v8/src/bench/run.scm new file mode 100644 index 000000000..5bf7129a6 --- /dev/null +++ b/v8/src/bench/run.scm @@ -0,0 +1,58 @@ +(define (time-command thunk-maker) + (define (say . stuff) (for-each display stuff)) + (let ((n 5)) + (let loop ((i n) (times '()) (value '?)) + (if (> i 0) + (let ((thunk (thunk-maker))) + (let ((start (runtime))) ; process time - gc process time + (let ((value (thunk))) + (let ((end (runtime))) + (loop (- i 1) (cons (- end start) times) value))))) + (fluid-let ((flonum-unparser-cutoff '(absolute 3))) + (let* ((sum (reduce + 0 times)) + (mean (/ sum n)) + (serr (reduce + 0 (map (lambda (x) (abs (- mean x))) + times))) + (merr (/ serr n))) + (say "\nTime: " mean " mean error " merr) + (say " (" (round->exact (* 100 (/ merr (+ mean 1e-6)))) "%)") + (say "\nTimes: " times) + value)))))) + +(define (make-env) + (the-environment)) + +(define (benchmark-file file-name) + (newline) + (display "Benchmark: ") + (display file-name) + (write-line (time-command (lambda () + (fluid-let ((load/suppress-loading-message? #f)) + (let ((env (make-env))) + (load "library" env) + (load file-name env)))))) + (newline)) + +(print-gc-statistics) + +(for-each benchmark-file + '("boyer" + "browse" + "conform" + "cpstak" + "ctak" + "dderiv" + "deriv" + "destruct" + "div" + ;;"earley" + "fib" + ;;"flatten" + "matmul1" + "matmul2" + "peval" + "puzzle" + "tak" + "takl" + "traverse" + "triangle")) diff --git a/v8/src/bench/tak.scm b/v8/src/bench/tak.scm new file mode 100644 index 000000000..62d9371dc --- /dev/null +++ b/v8/src/bench/tak.scm @@ -0,0 +1,30 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: tak.sch +; Description: TAK benchmark from the Gabriel tests +; Author: Richard Gabriel +; Created: 12-Apr-85 +; Modified: 12-Apr-85 09:58:18 (Bob Shaw) +; 22-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; 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)))) + +;;; call: (tak 18 12 6) + +(lambda () + (list (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) + (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) + (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) + (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) + (tak 18 12 6) (tak 18 12 6) (tak 18 12 6) (tak 18 12 6))) diff --git a/v8/src/bench/takl.scm b/v8/src/bench/takl.scm new file mode 100644 index 000000000..413757c82 --- /dev/null +++ b/v8/src/bench/takl.scm @@ -0,0 +1,49 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: takl.sch +; Description: TAKL benchmark from the Gabriel tests +; Author: Richard Gabriel +; Created: 12-Apr-85 +; Modified: 12-Apr-85 10:07:00 (Bob Shaw) +; 22-Jul-87 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; TAKL -- The TAKeuchi function using lists as counters. + +(define (listn n) + (if (not (= 0 n)) + (cons n (listn (- n 1))) + '())) + +(define _18l (listn 18)) +(define _12l (listn 12)) +(define _6l (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) + (if (null? y) + #f + (or (null? x) + (shorterp (cdr x) + (cdr y))))) + +;;; call: (mas _18l _12l _6l) + +(lambda () + (mas _18l _12l _6l) + (mas _18l _12l _6l) + (mas _18l _12l _6l) + (mas _18l _12l _6l) + (mas _18l _12l _6l)) \ No newline at end of file diff --git a/v8/src/bench/traverse.scm b/v8/src/bench/traverse.scm new file mode 100644 index 000000000..71b0ee318 --- /dev/null +++ b/v8/src/bench/traverse.scm @@ -0,0 +1,162 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: traverse.sch +; Description: TRAVERSE benchmark +; Author: Richard Gabriel +; Created: 12-Apr-85 +; Modified: 12-Apr-85 10:24:04 (Bob Shaw) +; 9-Aug-87 (Will Clinger) +; Language: Scheme (but see note) +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Note: This benchmark may depend upon the empty list being the same +; as #f. + +;;; TRAVERSE -- Benchmark which creates and traverses a tree structure. + +(define (make-node) + (let ((node (make-vector 11))) + (let loop ((i 10)) (if (> i 0) + (begin (vector-set! node i '#f) (loop (- i 1))))) + (vector-set! node 0 'node) + (vector-set! node 1 '()) + (vector-set! node 2 '()) + (vector-set! node 3 (snb)) + node)) + +(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) + +(lambda () (begin (init-traverse) (run-traverse))) diff --git a/v8/src/bench/triangle.scm b/v8/src/bench/triangle.scm new file mode 100644 index 000000000..97418177e --- /dev/null +++ b/v8/src/bench/triangle.scm @@ -0,0 +1,78 @@ +(declare (usual-integrations)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; File: triangle.sch +; Description: TRIANGLE benchmark +; Author: Richard Gabriel +; Created: 12-Apr-85 +; Modified: 12-Apr-85 10:30:32 (Bob Shaw) +; 11-Aug-87 (Will Clinger) +; 22-Jan-88 (Will Clinger) +; Language: Scheme +; Status: Public Domain +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; TRIANG -- 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 *final* '()) + +(define (last-position) + (do ((i 1 (+ i 1))) + ((or (= i 16) (= 1 (vector-ref *board* i))) + (if (= i 16) 0 i)))) + +(define (try i depth) + (cond ((= depth 14) + (let ((lp (last-position))) + (if (not (member lp *final*)) + (set! *final* (cons lp *final*)))) + (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) (try 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 (gogogo i) + (let ((*answer* '()) + (*final* '())) + (try i 1))) + +;;; call: (gogogo 22)) + +(lambda () (gogogo 22)) -- 2.25.1