add some interpreter vs. closure compiler benchmarks
Mostly for amusement, including the contrast between the benefits of closure compilation for a host interpreter versus the benefits for a host compiler.
This commit is contained in:
Matthew Flatt
parent
829820e458
commit
6e42c92a50
|
|
@ -549,6 +549,8 @@ exec racket -qu "$0" ${1+"$@"}
|
|||
sboyer
|
||||
scheme
|
||||
scheme2
|
||||
scheme-i
|
||||
scheme-c
|
||||
sort1
|
||||
tak
|
||||
takl
|
||||
|
|
@ -558,7 +560,9 @@ exec racket -qu "$0" ${1+"$@"}
|
|||
|
||||
(define extra-benchmarks
|
||||
'(kanren
|
||||
psyntax))
|
||||
psyntax
|
||||
scheme-i2
|
||||
scheme-c2))
|
||||
|
||||
(define (run-benchmark impl bm)
|
||||
(let ([i (ormap (lambda (i)
|
||||
|
|
|
|||
|
|
@ -2,5 +2,5 @@
|
|||
|
||||
(define name (vector-ref (current-command-line-arguments) 0))
|
||||
|
||||
(system (format "csc -no-warnings -no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift ~a.sch"
|
||||
(system (format "csc -no-warnings -no-trace -no-lambda-info -optimize-level 3 -block ~a.sch"
|
||||
name))
|
||||
|
|
|
|||
1
collects/tests/racket/benchmarks/common/scheme-c.rkt
Normal file
1
collects/tests/racket/benchmarks/common/scheme-c.rkt
Normal file
|
|
@ -0,0 +1 @@
|
|||
(module scheme-c "wrap.rkt" r5rs)
|
||||
397
collects/tests/racket/benchmarks/common/scheme-c.sch
Normal file
397
collects/tests/racket/benchmarks/common/scheme-c.sch
Normal file
|
|
@ -0,0 +1,397 @@
|
|||
;; The optimizing compiler from
|
||||
;; "Using closures for code generation", Feeley & Lapalme,
|
||||
;; Computer Languages, 12(1):47-66, 1987.
|
||||
|
||||
(define (compile expr)
|
||||
((gen expr '() #f)))
|
||||
|
||||
(define (gen expr env term)
|
||||
(cond ((symbol? expr)
|
||||
(ref (variable expr env) term))
|
||||
((not (pair? expr))
|
||||
(cst expr term))
|
||||
((eq? (car expr) 'quote)
|
||||
(cst (cadr expr) term))
|
||||
((eq? (car expr) 'set!)
|
||||
(set (variable (cadr expr) env) (gen (caddr expr) env #f) term))
|
||||
((eq? (car expr) 'if)
|
||||
(gen-tst (gen (cadr expr) env #f)
|
||||
(gen (caddr expr) env term)
|
||||
(gen (cadddr expr) env term)))
|
||||
((eq? (car expr) 'lambda)
|
||||
(let ((p (cadr expr)))
|
||||
(prc p (gen (caddr expr) (allocate p env) #t) term)))
|
||||
(else
|
||||
(let ((args (map (lambda (x) (gen x env #f)) (cdr expr))))
|
||||
(let ((var (and (symbol? (car expr)) (variable (car expr) env))))
|
||||
(if (global? var)
|
||||
(app (cons var args) #t term)
|
||||
(app (cons (gen (car expr) env #f) args) #f term)))))))
|
||||
|
||||
(define (allocate parms env)
|
||||
(cond ((null? parms) env)
|
||||
((symbol? parms) (cons parms env))
|
||||
(else (cons (car parms) (allocate (cdr parms) env)))))
|
||||
|
||||
(define (variable symb env)
|
||||
(let ((x (memq symb env)))
|
||||
(if x
|
||||
(- (length env) (length x))
|
||||
(begin
|
||||
(if (not (assq symb *glo-env*)) (define-global symb 'undefined))
|
||||
(assq symb *glo-env*)))))
|
||||
|
||||
(define (global? var)
|
||||
(pair? var))
|
||||
|
||||
(define (cst val term)
|
||||
(cond ((eqv? val 1) ((if term gen-1* gen-1 ) ))
|
||||
((eqv? val 2) ((if term gen-2* gen-2 ) ))
|
||||
((eqv? val '()) ((if term gen-null* gen-null) ))
|
||||
(else ((if term gen-cst* gen-cst ) val))))
|
||||
|
||||
(define (ref var term)
|
||||
(cond ((global? var) ((if term gen-ref-glo* gen-ref-glo ) var))
|
||||
((= var 0) ((if term gen-ref-loc-1* gen-ref-loc-1) ))
|
||||
((= var 1) ((if term gen-ref-loc-2* gen-ref-loc-2) ))
|
||||
((= var 2) ((if term gen-ref-loc-3* gen-ref-loc-3) ))
|
||||
(else ((if term gen-ref* gen-ref ) var))))
|
||||
|
||||
(define (set var val term)
|
||||
(cond ((global? var) ((if term gen-set-glo* gen-set-glo ) var val))
|
||||
((= var 0) ((if term gen-set-loc-1* gen-set-loc-1) val))
|
||||
((= var 1) ((if term gen-set-loc-2* gen-set-loc-2) val))
|
||||
((= var 2) ((if term gen-set-loc-3* gen-set-loc-3) val))
|
||||
(else ((if term gen-set* gen-set ) var val))))
|
||||
|
||||
(define (prc parms body term)
|
||||
((cond ((null? parms) (if term gen-prc0* gen-prc0 ))
|
||||
((symbol? parms) (if term gen-prc1/rest* gen-prc1/rest))
|
||||
((null? (cdr parms)) (if term gen-prc1* gen-prc1 ))
|
||||
((symbol? (cdr parms)) (if term gen-prc2/rest* gen-prc2/rest))
|
||||
((null? (cddr parms)) (if term gen-prc2* gen-prc2 ))
|
||||
((symbol? (cddr parms)) (if term gen-prc3/rest* gen-prc3/rest))
|
||||
((null? (cdddr parms)) (if term gen-prc3* gen-prc3 ))
|
||||
(else (error "too many parameters")))
|
||||
body))
|
||||
|
||||
(define (app vals glo term)
|
||||
(apply (case (length vals)
|
||||
((1) (if glo (if term gen-ap0-glo* gen-ap0-glo)
|
||||
(if term gen-ap0* gen-ap0)))
|
||||
((2) (if glo (if term gen-ap1-glo* gen-ap1-glo)
|
||||
(if term gen-ap1* gen-ap1)))
|
||||
((3) (if glo (if term gen-ap2-glo* gen-ap2-glo)
|
||||
(if term gen-ap2* gen-ap2)))
|
||||
((4) (if glo (if term gen-ap3-glo* gen-ap3-glo)
|
||||
(if term gen-ap3* gen-ap3)))
|
||||
(else (error "too many arguments")))
|
||||
vals))
|
||||
|
||||
;- -- code generation procedures for non-terminal evaluations ---
|
||||
|
||||
;- -- code generation for constants ---
|
||||
|
||||
(define (gen-cst a) ; any constant
|
||||
(lambda () a))
|
||||
|
||||
(define (gen-1) ;f or constant 1
|
||||
(lambda () 1))
|
||||
|
||||
(define (gen-2) ;f or constant 2
|
||||
(lambda () 2))
|
||||
|
||||
(define (gen-null) ;f or constant ()
|
||||
(lambda () '()))
|
||||
|
||||
;- -- code generation for variable references ---
|
||||
|
||||
(define (gen-ref-glo a) ; for a global variable
|
||||
(lambda () (cdr a)))
|
||||
|
||||
(define (gen-ref a) ;f or any non-global variable
|
||||
(lambda () (do ((i 0 (+ i 1)) (env (cdr *env*) (cdr env)))
|
||||
((= i a) (car env)))))
|
||||
|
||||
(define (gen-ref-loc-1) ; for first local variable
|
||||
(lambda () (cadr *env*)))
|
||||
|
||||
(define (gen-ref-loc-2) ; for second local variable
|
||||
(lambda () (caddr *env*)))
|
||||
|
||||
(define (gen-ref-loc-3) ; for third local variable
|
||||
(lambda () (cadddr *env*)))
|
||||
|
||||
;- -- code generation for assignments ---
|
||||
|
||||
(define (gen-set-glo a b) ; for a global variable
|
||||
(lambda () (set-cdr! a (b))))
|
||||
|
||||
(define (gen-set a b) ;f or any non-global variable
|
||||
(lambda () (do ((i 0 (+ i 1)) (env (cdr *env*) (cdr env)))
|
||||
((= i a) (set-car! env (b))))))
|
||||
|
||||
(define (gen-set-loc-1 a) ; for first local variable
|
||||
(lambda () (set-car! (cdr *env*) (a))))
|
||||
|
||||
(define (gen-set-loc-2 a) ; for second local variable
|
||||
(lambda () (set-car! (cddr *env*) (a))))
|
||||
|
||||
(define (gen-set-loc-3 a) ; for third local variable
|
||||
(lambda () (set-car! (cdddr *env*) (a))))
|
||||
|
||||
;- -- code generation for 'if' special form ---
|
||||
|
||||
(define (gen-tst a b c)
|
||||
(lambda () (if (a) (b) (c))))
|
||||
|
||||
;- -- code generation for procedure application ---
|
||||
|
||||
(define (gen-ap0 a) ;a ny application (of 0 to 3 arguments)
|
||||
(lambda () ((a))))
|
||||
|
||||
(define (gen-ap1 a b)
|
||||
(lambda () ((a) (b))))
|
||||
|
||||
(define (gen-ap2 a b c)
|
||||
(lambda () ((a) (b) (c))))
|
||||
|
||||
(define (gen-ap3 a b c d)
|
||||
(lambda () ((a) (b) (c) (d))))
|
||||
|
||||
(define (gen-ap0-glo a) ; application with global variable as operator
|
||||
(lambda () ((cdr a))))
|
||||
|
||||
(define (gen-ap1-glo a b)
|
||||
(lambda () ((cdr a) (b))))
|
||||
|
||||
(define (gen-ap2-glo a b c)
|
||||
(lambda () ((cdr a) (b) (c))))
|
||||
|
||||
(define (gen-ap3-glo a b c d)
|
||||
(lambda () ((cdr a) (b) (c) (d))))
|
||||
|
||||
;- -- code generation for 'lambda' special form ---
|
||||
|
||||
|
||||
(define (gen-prc0 a) ;nor est parameter (0 to 3 parameters)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(lambda ()
|
||||
(set! *env* (cons *env* def))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc1 a)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(lambda (x)
|
||||
(set! *env* (cons *env* (cons x def)))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc2 a)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(lambda (x y)
|
||||
(set! *env* (cons *env* (cons x (cons y def))))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc3 a)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(lambda (x y z)
|
||||
(set! *env* (cons *env* (cons x (cons y (cons z def)))))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc1/rest a) ; when a rest parameter is present
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(lambda x
|
||||
(set! *env* (cons *env* (cons x def)))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc2/rest a)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(lambda (x . y)
|
||||
(set! *env* (cons *env* (cons x (cons y def))))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc3/rest a)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(lambda (x y . z)
|
||||
(set! *env* (cons *env* (cons x (cons y (cons z def)))))
|
||||
(a)))))
|
||||
|
||||
;- -- code generation procedures for terminal evaluations ---
|
||||
|
||||
;- -- code generation for constants ---
|
||||
|
||||
(define (gen-cst* a) ; any constant
|
||||
(lambda () (set! *env* (car *env*)) a))
|
||||
|
||||
(define (gen-1*) ;f or constant 1
|
||||
(lambda () (set! *env* (car *env*)) 1))
|
||||
|
||||
(define (gen-2*) ;f or constant 2
|
||||
(lambda () (set! *env* (car *env*)) 2))
|
||||
|
||||
(define (gen-null*) ;f or constant ()
|
||||
(lambda () (set! *env* (car *env*)) '()))
|
||||
|
||||
;- -- code generation for variable references ---
|
||||
|
||||
(define (gen-ref-glo* a) ; for a global variable
|
||||
(lambda () (set! *env* (car *env*)) (cdr a)))
|
||||
|
||||
(define (gen-ref* a) ;f or any non-global variable
|
||||
(lambda () (do ((i 0 (+ i 1)) (env (cdr *env*) (cdr env)))
|
||||
((= i a) (set! *env* (car *env*)) (car env)))))
|
||||
|
||||
(define (gen-ref-loc-1*) ; for first local variable
|
||||
(lambda () (let ((val (cadr *env*))) (set! *env* (car *env*)) val)))
|
||||
|
||||
(define (gen-ref-loc-2*) ; for second local variable
|
||||
(lambda () (let ((val (caddr *env*))) (set! *env* (car *env*)) val)))
|
||||
|
||||
(define (gen-ref-loc-3*) ; for third local variable
|
||||
(lambda () (let ((val (cadddr *env*))) (set! *env* (car *env*)) val)))
|
||||
|
||||
;- -- code generation for assignments ---
|
||||
|
||||
(define (gen-set-glo* a b) ; for a global variable
|
||||
(lambda () (set! *env* (car *env*)) (set-cdr! a (b))))
|
||||
|
||||
(define (gen-set* a b) ;f or any non-global variable
|
||||
(lambda () (do ((i 0 (+ i 1)) (env (cdr *env*) (cdr env)))
|
||||
((= i a) (set-car! env (b)) (set! *env* (car *env*))))))
|
||||
|
||||
(define (gen-set-loc-1* a) ; for first local variable
|
||||
(lambda () (set-car! (cdr *env*) (a)) (set! *env* (car *env*))))
|
||||
|
||||
(define (gen-set-loc-2* a) ; for second local variable
|
||||
(lambda () (set-car! (cddr *env*) (a)) (set! *env* (car *env*))))
|
||||
|
||||
(define (gen-set-loc-3* a) ; for third local variable
|
||||
(lambda () (set-car! (cdddr *env*) (a)) (set! *env* (car *env*))))
|
||||
|
||||
;- -- code generation for procedure application ---
|
||||
|
||||
(define (gen-ap0* a) ;a ny application (of 0 to 3 arguments)
|
||||
(lambda () (let ((w (a)))
|
||||
(set! *env* (car *env*))
|
||||
(w))))
|
||||
|
||||
(define (gen-ap1* a b)
|
||||
(lambda () (let ((w (a)) (x (b)))
|
||||
(set! *env* (car *env*))
|
||||
(w x))))
|
||||
|
||||
(define (gen-ap2* a b c)
|
||||
(lambda () (let ((w (a)) (x (b)) (y (c)))
|
||||
(set! *env* (car *env*))
|
||||
(w x y))))
|
||||
|
||||
(define (gen-ap3* a b c d)
|
||||
(lambda () (let ((w (a)) (x (b)) (y (c)) (z (d)))
|
||||
(set! *env* (car *env*))
|
||||
(w x y z))))
|
||||
|
||||
(define (gen-ap0-glo* a) ; application with global variable as operator
|
||||
(lambda ()
|
||||
(set! *env* (car *env*))
|
||||
((cdr a))))
|
||||
|
||||
(define (gen-ap1-glo* a b)
|
||||
(lambda () (let ((x (b)))
|
||||
(set! *env* (car *env*))
|
||||
((cdr a) x))))
|
||||
|
||||
(define (gen-ap2-glo* a b c)
|
||||
(lambda () (let ((x (b)) (y (c)))
|
||||
(set! *env* (car *env*))
|
||||
((cdr a) x y))))
|
||||
|
||||
(define (gen-ap3-glo* a b c d)
|
||||
(lambda () (let ((x (b)) (y (c)) (z (d)))
|
||||
(set! *env* (car *env*))
|
||||
((cdr a) x y z))))
|
||||
|
||||
;- -- code generation for 'lambda' special form ---
|
||||
|
||||
(define (gen-prc0* a) ;nor est parameter (0 to 3 parameters)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(set! *env* (car *env*))
|
||||
(lambda ()
|
||||
(set! *env* (cons *env* def))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc1* a)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(set! *env* (car *env*))
|
||||
(lambda (x)
|
||||
(set! *env* (cons *env* (cons x def)))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc2* a)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(set! *env* (car *env*))
|
||||
(lambda (x y)
|
||||
(set! *env* (cons *env* (cons x (cons y def))))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc3* a)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(set! *env* (car *env*))
|
||||
(lambda (x y z)
|
||||
(set! *env* (cons *env* (cons x (cons y (cons z def)))))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc1/rest* a) ; when a rest parameter is present
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(set! *env* (car *env*))
|
||||
(lambda x
|
||||
(set! *env* (cons *env* (cons x def)))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc2/rest* a)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(set! *env* (car *env*))
|
||||
(lambda (x . y)
|
||||
(set! *env* (cons *env* (cons x (cons y def))))
|
||||
(a)))))
|
||||
|
||||
(define (gen-prc3/rest* a)
|
||||
(lambda () (let ((def (cdr *env*)))
|
||||
(set! *env* (car *env*))
|
||||
(lambda (x y . z)
|
||||
(set! *env* (cons *env* (cons x (cons y (cons z def)))))
|
||||
(a)))))
|
||||
|
||||
;- -- global variable definition ---
|
||||
|
||||
(define (define-global var val)
|
||||
(if (assq var *glo-env*)
|
||||
(set-cdr! (assq var *glo-env*) val)
|
||||
(set! *glo-env* (cons (cons var val) *glo-env*))))
|
||||
|
||||
(define *glo-env* (list (cons 'define define-global)))
|
||||
(define-global 'cons cons )
|
||||
(define-global 'car car )
|
||||
(define-global 'cdr cdr )
|
||||
(define-global 'null? null?)
|
||||
(define-global 'not not )
|
||||
(define-global '< <)
|
||||
(define-global '+ +)
|
||||
(define-global '- -)
|
||||
|
||||
;- -- to evaluate an expression we compile it and then call the result ---
|
||||
|
||||
(define (evaluate expr)
|
||||
((compile (list 'lambda '() expr))))
|
||||
|
||||
(define *env* '(dummy)) ; current environment
|
||||
|
||||
|
||||
|
||||
(evaluate '(define 'fib
|
||||
(lambda (x)
|
||||
(if (< x 2)
|
||||
1
|
||||
(+ (fib (- x 1))
|
||||
(fib (- x 2)))))))
|
||||
(display (time (evaluate '(fib 30))))
|
||||
(newline)
|
||||
1
collects/tests/racket/benchmarks/common/scheme-c2.rkt
Normal file
1
collects/tests/racket/benchmarks/common/scheme-c2.rkt
Normal file
|
|
@ -0,0 +1 @@
|
|||
(module scheme-c2 "wrap.rkt")
|
||||
81
collects/tests/racket/benchmarks/common/scheme-c2.sch
Normal file
81
collects/tests/racket/benchmarks/common/scheme-c2.sch
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
;; A closure-compiling Scheme interpreter running
|
||||
;; a Y-combinator countdown
|
||||
|
||||
(define (find-pos a l)
|
||||
(cond
|
||||
((eq? a (car l)) 0)
|
||||
(else (+ 1 (find-pos a (cdr l))))))
|
||||
|
||||
(define (comp expr cenv)
|
||||
(cond
|
||||
((number? expr) (lambda (env) expr))
|
||||
((symbol? expr)
|
||||
(let ((pos (find-pos expr cenv)))
|
||||
(case pos
|
||||
((0) car)
|
||||
((1) cadr)
|
||||
(else
|
||||
(lambda (env)
|
||||
(list-ref env pos))))))
|
||||
(else
|
||||
(case (car expr)
|
||||
((+)
|
||||
(let ((a (comp (cadr expr) cenv))
|
||||
(b (comp (caddr expr) cenv)))
|
||||
(lambda (env) (+ (a env) (b env)))))
|
||||
((-)
|
||||
(let ((a (comp (cadr expr) cenv))
|
||||
(b (comp (caddr expr) cenv)))
|
||||
(lambda (env) (- (a env) (b env)))))
|
||||
((zero?)
|
||||
(let ((a (comp (cadr expr) cenv)))
|
||||
(lambda (env) (zero? (a env)))))
|
||||
((if)
|
||||
(let ((a (comp (cadr expr) cenv))
|
||||
(b (comp (caddr expr) cenv))
|
||||
(c (comp (cadddr expr) cenv)))
|
||||
(lambda (env)
|
||||
(if (a env)
|
||||
(b env)
|
||||
(c env)))))
|
||||
((let)
|
||||
(let ((rhs (comp (cadr (caadr expr)) cenv))
|
||||
(body (comp (caddr expr)
|
||||
(cons (car (caadr expr))
|
||||
cenv))))
|
||||
(lambda (env)
|
||||
(let ((rhs-val (rhs env)))
|
||||
(body (cons rhs-val env))))))
|
||||
((lambda)
|
||||
(let ((body (comp (caddr expr)
|
||||
(cons (caadr expr) cenv))))
|
||||
(lambda (env)
|
||||
(lambda (a)
|
||||
(body (cons a env))))))
|
||||
(else
|
||||
(let ((a (comp (car expr) cenv))
|
||||
(b (comp (cadr expr) cenv)))
|
||||
(lambda (env)
|
||||
(let ((clos (a env))
|
||||
(arg-val (b env)))
|
||||
(clos arg-val)))))))))
|
||||
|
||||
((comp '(let ((f (lambda (x)
|
||||
(lambda (y)
|
||||
(- y x)))))
|
||||
(+ ((f 10) 2) 3))
|
||||
'())
|
||||
'())
|
||||
|
||||
(time ((comp '(let ((Y (lambda (m)
|
||||
((lambda (f) (m (lambda (a) ((f f) a))))
|
||||
(lambda (f) (m (lambda (a) ((f f) a))))))))
|
||||
(let ((count
|
||||
(Y (lambda (count)
|
||||
(lambda (n)
|
||||
(if (zero? n)
|
||||
0
|
||||
(+ 1 (count (- n 1)))))))))
|
||||
(count 500000)))
|
||||
'())
|
||||
'()))
|
||||
1
collects/tests/racket/benchmarks/common/scheme-i.rkt
Normal file
1
collects/tests/racket/benchmarks/common/scheme-i.rkt
Normal file
|
|
@ -0,0 +1 @@
|
|||
(module scheme-i "wrap.rkt" r5rs)
|
||||
147
collects/tests/racket/benchmarks/common/scheme-i.sch
Normal file
147
collects/tests/racket/benchmarks/common/scheme-i.sch
Normal file
|
|
@ -0,0 +1,147 @@
|
|||
;; The interpreter from
|
||||
;; "Using closures for code generation", Feeley & Lapalme,
|
||||
;; Computer Languages, 12(1):47-66, 1987.
|
||||
|
||||
(define (interpret expr)
|
||||
(int expr *glo-env*))
|
||||
|
||||
(define (int expr env)
|
||||
(cond ((symbol? expr)
|
||||
(int-ref expr env))
|
||||
((not (pair? expr))
|
||||
(int-cst expr env))
|
||||
((eq? (car expr) 'quote)
|
||||
(int-cst (cadr expr) env))
|
||||
((eq? (car expr) 'set!)
|
||||
(int-set (cadr expr) (caddr expr) env))
|
||||
((eq? (car expr) 'if)
|
||||
(int-tst (cadr expr) (caddr expr) (cadddr expr) env))
|
||||
((eq? (car expr) 'lambda)
|
||||
(let ((p (cadr expr)))
|
||||
(cond ((null? p)
|
||||
(int-prc0 (caddr expr) env))
|
||||
((symbol? p)
|
||||
(int-prc1/rest (caddr expr) p env))
|
||||
((null? (cdr p))
|
||||
(int-prc1 (caddr expr) (car p) env))
|
||||
((symbol? (cdr p))
|
||||
(int-prc2/rest (caddr expr) (car p) (cdr p) env))
|
||||
((null? (cddr p))
|
||||
(int-prc2 (caddr expr) (car p) (cadr p) env))
|
||||
((symbol? (cddr p))
|
||||
(int-prc3/rest (caddr expr) (car p) (cadr p) (cddr p) env))
|
||||
((null? (cdddr p))
|
||||
(int-prc3 (caddr expr) (car p) (cadr p) (caddr p) env))
|
||||
(else
|
||||
(error "too many parameters")))))
|
||||
((null? (cdr expr))
|
||||
(int-ap0 (car expr) env))
|
||||
((null? (cddr expr))
|
||||
(int-ap1 (car expr) (cadr expr) env))
|
||||
((null? (cdddr expr))
|
||||
(int-ap2 (car expr) (cadr expr) (caddr expr) env))
|
||||
((null? (cddddr expr))
|
||||
(int-ap3 (car expr) (cadr expr) (caddr expr) (cadddr expr) env))
|
||||
(else
|
||||
(error "too many arguments"))))
|
||||
|
||||
;- -- interpretation of constants ---
|
||||
|
||||
(define (int-cst a env)
|
||||
a)
|
||||
|
||||
;- -- interpretation of variable references ---
|
||||
|
||||
(define (int-ref a env)
|
||||
(cdr (assq a env)))
|
||||
|
||||
;- -- interpretation of assignments ---
|
||||
|
||||
(define (int-set a b env)
|
||||
(set-cdr! (assq a env) (int b env)))
|
||||
|
||||
;- -- interpretation of 'if' special form ---
|
||||
|
||||
(define (int-tst a b c env)
|
||||
(if (int a env) (int b env) (int c env)))
|
||||
|
||||
;- -- interpretation of procedure application ---
|
||||
|
||||
(define (int-ap0 a env)
|
||||
((int a env)))
|
||||
|
||||
(define (int-ap1 a b env)
|
||||
((int a env) (int b env)))
|
||||
|
||||
(define (int-ap2 a b c env)
|
||||
((int a env) (int b env) (int c env)))
|
||||
|
||||
(define (int-ap3 a b c d env)
|
||||
((int a env) (int b env) (int c env) (int d env)))
|
||||
|
||||
;- -- interpretation of 'lambda' special form ---
|
||||
|
||||
(define (int-prc0 a env)
|
||||
(lambda ()
|
||||
(int a env)))
|
||||
|
||||
(define (int-prc1 a b env)
|
||||
(lambda (x)
|
||||
(int a (cons (cons b x) env))))
|
||||
|
||||
(define (int-prc2 a b c env)
|
||||
(lambda (x y)
|
||||
(int a (cons (cons b x) (cons (cons c y) env)))))
|
||||
|
||||
(define (int-prc3 a b c d env)
|
||||
(lambda (x y z)
|
||||
(int a (cons (cons b x) (cons (cons c y) (cons (cons d z) env))))))
|
||||
|
||||
(define (int-prc1/rest a b env)
|
||||
(lambda x
|
||||
(int a (cons (cons b x) env))))
|
||||
|
||||
(define (int-prc2/rest a b c env)
|
||||
(lambda (x . y)
|
||||
(int a (cons (cons b x) (cons (cons c y) env)))))
|
||||
|
||||
(define (int-prc3/rest a b c d env)
|
||||
(lambda (x y . z)
|
||||
(int a (cons (cons b x) (cons (cons c y) (cons (cons d z) env))))))
|
||||
|
||||
;- -- global variable definition ---
|
||||
|
||||
(define (define-global var val)
|
||||
(if (assq var *glo-env*)
|
||||
(set-cdr! (assq var *glo-env*) val)
|
||||
(begin
|
||||
(set-cdr! *glo-env* (cons (car *glo-env*) (cdr *glo-env*)))
|
||||
(set-car! *glo-env* (cons var val)))))
|
||||
|
||||
(define *glo-env* (list (cons 'define define-global)))
|
||||
(define-global 'cons cons )
|
||||
(define-global 'car car )
|
||||
(define-global 'cdr cdr )
|
||||
(define-global 'null? null?)
|
||||
(define-global 'not not )
|
||||
(define-global '< <)
|
||||
(define-global '+ +)
|
||||
(define-global '- -)
|
||||
|
||||
;- -- to evaluate an expression we call the interpreter ---
|
||||
|
||||
(define (evaluate expr)
|
||||
(interpret expr))
|
||||
|
||||
|
||||
(evaluate '(define 'fib
|
||||
(lambda (x)
|
||||
(if (< x 2)
|
||||
1
|
||||
(+ (fib (- x 1))
|
||||
(fib (- x 2)))))))
|
||||
(display (time (evaluate '(fib 30))))
|
||||
(newline)
|
||||
|
||||
|
||||
|
||||
1
collects/tests/racket/benchmarks/common/scheme-i2.rkt
Normal file
1
collects/tests/racket/benchmarks/common/scheme-i2.rkt
Normal file
|
|
@ -0,0 +1 @@
|
|||
(module scheme-i2 "wrap.rkt")
|
||||
58
collects/tests/racket/benchmarks/common/scheme-i2.sch
Normal file
58
collects/tests/racket/benchmarks/common/scheme-i2.sch
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
;; Yet another Scheme interpreter, this time running
|
||||
;; a Y-combinator countdown
|
||||
|
||||
(define (make-closure arg body env) (vector arg body env))
|
||||
(define (closure-arg v) (vector-ref v 0))
|
||||
(define (closure-body v) (vector-ref v 1))
|
||||
(define (closure-env v) (vector-ref v 2))
|
||||
|
||||
(define (interp expr env)
|
||||
(cond
|
||||
[(number? expr) expr]
|
||||
[(symbol? expr)
|
||||
(cdr (assq expr env))]
|
||||
[else
|
||||
(case (car expr)
|
||||
[(+)
|
||||
(+ (interp (cadr expr) env)
|
||||
(interp (caddr expr) env))]
|
||||
[(-)
|
||||
(- (interp (cadr expr) env)
|
||||
(interp (caddr expr) env))]
|
||||
[(zero?)
|
||||
(zero? (interp (cadr expr) env))]
|
||||
[(if)
|
||||
(if (interp (cadr expr) env)
|
||||
(interp (caddr expr) env)
|
||||
(interp (cadddr expr) env))]
|
||||
[(let)
|
||||
(let ([rhs-val
|
||||
(interp (cadr (caadr expr)) env)])
|
||||
(interp (caddr expr)
|
||||
(cons (cons (car (caadr expr))
|
||||
rhs-val)
|
||||
env)))]
|
||||
[(lambda)
|
||||
(make-closure (caadr expr)
|
||||
(caddr expr)
|
||||
env)]
|
||||
[else
|
||||
(let ([clos (interp (car expr) env)]
|
||||
[arg-val (interp (cadr expr) env)])
|
||||
(interp (closure-body clos)
|
||||
(cons
|
||||
(cons (closure-arg clos)
|
||||
arg-val)
|
||||
(closure-env clos))))])]))
|
||||
|
||||
(time (interp '(let ([Y (lambda (m)
|
||||
((lambda (f) (m (lambda (a) ((f f) a))))
|
||||
(lambda (f) (m (lambda (a) ((f f) a))))))])
|
||||
(let ([count
|
||||
(Y (lambda (count)
|
||||
(lambda (n)
|
||||
(if (zero? n)
|
||||
0
|
||||
(+ 1 (count (- n 1)))))))])
|
||||
(count 500000)))
|
||||
'()))
|
||||
Loading…
Reference in New Issue
Block a user