From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Sun, 26 Mar 1995 16:49:13 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~6510
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c94c77c06f69a1cf36825e421b5290762eec6b2e;p=mit-scheme.git

Initial revision
---

diff --git a/v8/src/bench/fcomp.scm b/v8/src/bench/fcomp.scm
new file mode 100644
index 000000000..9710effcd
--- /dev/null
+++ b/v8/src/bench/fcomp.scm
@@ -0,0 +1,217 @@
+(declare (usual-integrations))
+
+(define (compile exp)
+  (compile-expr exp #F))
+
+(define (compile-expr exp s-env)
+  (let ((exp (macro-expand exp)))
+    (cond ((symbol? exp)
+	   (compile-lookup exp s-env))
+	  ((not (pair? exp))
+	   (compile-constant exp s-env))
+	  ((eq? (car exp) 'QUOTE)
+	   (compile-constant (second exp) s-env))
+	  ((eq? (car exp) 'SET!)
+	   (compile-set! (second exp) (third exp) s-env))
+	  ((eq? (car exp) 'BEGIN)
+	   (compile-sequence (cdr exp) s-env))
+	  ((eq? (car exp) 'LAMBDA)
+	   (compile-lambda (second exp) (cddr exp) s-env))
+	  ((eq? (car exp) 'IF)
+	   (compile-if exp s-env))
+	  (else
+	   (compile-combination exp s-env)))))
+
+(define (macro-expand exp)
+  (cond ((not (pair? exp))
+	 exp)
+	((eq? (car exp) 'LET)
+	 `((LAMBDA ,(map first (second exp)) ,@(cddr exp))
+	   ,@(map second (second exp))))
+	((eq? (car exp) 'LETREC)
+	 (let ((names  (map car (second exp)))
+	       (values (map cadr (second exp)))
+	       (body   (cddr exp)))
+	   `((LAMBDA ,names
+	       ,@(map (lambda (n v) `(SET! ,n ,v)) names values)
+	       ,@body)
+	     ,@(make-list (length names) '(quote undefined)))))
+	(else exp)))
+
+(define (compile-constant cst s-env)
+  s-env
+  (let ((place? (assoc cst *common-constants*)))
+    (if place?
+	(cdr place?)
+	(lambda (d-env) cst))))
+
+(define *common-constants*
+  (list (cons '0  (lambda (d) 0))
+	(cons '1  (lambda (d) 1))
+	(cons '2  (lambda (d) 2))
+	(cons '() (lambda (d) '()))
+	(cons #T  (lambda (d) #T))
+	(cons #F  (lambda (d) #F))))
+	
+(define *global-env*
+  (list 'global-environment
+	(cons '+ +)
+	(cons '- -)
+	(cons '* *)
+	(cons '< <)
+	(cons 'list list)
+	(cons 'cons  (lambda (u v) (cons u v)))
+	(cons 'car   (lambda (p) (car p)))
+	(cons 'cdr   (lambda (p) (cdr p)))
+	(cons 'null? (lambda (x) (null? x)))
+	(cons 'display display)))
+
+(define (var->path var s-env)
+  ;; returns an access path, either pair from the global env or a
+  ;; (spine-index.frame-index) pair
+  (let frame-loop ((frame s-env) (spine-index 0))
+    (cond ((not frame)
+	   (or (assq var (cdr *global-env*))
+	       (let ((pair (cons var 'uninitialized)))
+		 (set-cdr! *global-env* (cons pair (cdr *global-env*)))
+		 pair)))
+	  ((let loop ((bindings  (cdr frame)) (index 1))
+	     (cond ((pair? bindings)
+		    (if (eq? (car bindings) var)
+			(cons spine-index index)
+			(loop (cdr bindings) (+ index 1))))
+		   ((null? bindings)
+		    #F)
+		   (else ;; rest arg
+		    (if (eq? bindings var)
+			(cons spine-index index)
+			#F)))))
+	  (else
+	   (frame-loop (car frame) (+ spine-index 1))))))
+
+(define (compile-lookup var s-env)
+  (let ((path  (var->path var s-env)))
+    (if (symbol? (car path))
+	(lambda (d-env) d-env (cdr path))
+	(let loop ((ups  (car path)))
+	  (if (zero? ups)
+	      (compile-frame-ref (cdr path))
+	      (let ((ups*  (loop (- ups 1))))
+		(lambda (d-env) (ups* (vector-ref d-env 0)))))))))
+
+(define (compile-set! var exp s-env)
+  (let* ((path (var->path var s-env))
+	 (frame (car path))
+	 (index (cdr path)))
+    (let ((exp* (compile-expr exp s-env)))
+      (if (symbol? frame)
+	  (lambda (d-env) (set-cdr! path (exp* d-env)) unspecific)
+	  (let loop ((ups  frame))
+	    (if (zero? ups)
+		(lambda (d-env) (vector-set! d-env index (exp* d-env)))
+		(let ((ups*  (loop (- ups 1))))
+		  (lambda (d-env) (ups* (vector-ref d-env 0))))))))))
+
+(define (compile-global-access place)
+  (lambda (d-env) d-env (cdr place)))
+	
+(define (compile-frame-ref index)
+  (case index
+    ((0)  (lambda (d-env) (vector-ref d-env 0)))
+    ((1)  (lambda (d-env) (vector-ref d-env 1)))
+    ((2)  (lambda (d-env) (vector-ref d-env 2)))
+    ((3)  (lambda (d-env) (vector-ref d-env 3)))
+    ((4)  (lambda (d-env) (vector-ref d-env 4)))
+    (else (lambda (d-env) (vector-red d-env index)))))
+
+(define (compile-lambda args sequence s-env)
+  (let ((body (compile-sequence sequence (cons s-env args))))
+    (cond ((null? args)
+	   (lambda (d-env)
+	     (lambda () (body (vector d-env)))))
+	  ((symbol? args)
+	   (lambda (d-env)
+	     (lambda args (body (vector d-env args)))))
+	  ((null? (cdr args))
+	   (lambda (d-env)
+	     (lambda (arg1) (body (vector d-env arg1)))))
+	  ((symbol? (cdr args))
+	   (lambda (d-env)
+	     (lambda (arg1 . rest) (body (vector d-env arg1 rest)))))
+	  ((null? (cddr args))
+	   (lambda (d-env)
+	     (lambda (arg1 arg2) (body (vector d-env arg1 arg2)))))
+	  ((symbol? (cddr args))
+	   (lambda (d-env)
+	     (lambda (arg1 arg2 . rest) (body (vector d-env arg1 arg2 rest)))))
+	  ((null? (cdr (last-pair args)))
+	   (lambda (d-env)
+	     (lambda args (body (list->vector (cons d-env args))))))
+	  (else (error "Illegal or unimplemented lambda list" args)))))
+
+(define (compile-sequence seq s-env)
+  (cond ((null? seq) (error "Null sequence"))
+	((null? (cdr seq))
+	 (compile-expr (car seq) s-env))
+	(else
+	 (let ((this  (compile-expr (car seq) s-env))
+	       (rest  (compile-sequence (cdr seq) s-env)))
+	   (lambda (d-env)
+	     (this d-env)
+	     (rest d-env))))))
+
+(define (compile-if exp s-env)
+  (let ((pred (compile-expr (second exp) s-env))
+	(conseq (compile-expr (third exp) s-env)))
+    (if (null? (cdddr exp))
+	(lambda (d-env)
+	  (if (pred d-env) (conseq d-env) unspecific))
+	(let ((alt  (compile-expr (fourth exp) s-env)))
+	  (lambda (d-env)
+	    (if (pred d-env) (conseq d-env) (alt d-env)))))))
+
+(define (compile-combination exps s-env)
+  (let ((rator  (compile-expr (car exps) s-env))
+	(rands  (map (lambda (e) (compile-expr e s-env)) (cdr exps))))
+    (case (length rands)
+      ((0)  (lambda (d-env) ((rator d-env))))
+      ((1)  (let ((rand1 (first rands)))
+	      (lambda (d-env) ((rator d-env) (rand1 d-env)))))
+      ((2)  (let ((rand1 (first rands))
+		  (rand2 (second rands)))
+	      (lambda (d-env) ((rator d-env) (rand1 d-env) (rand2 d-env)))))
+      ((3)  (let ((rand1 (first rands))
+		  (rand2 (second rands))
+		  (rand3 (third rands)))
+	      (lambda (d-env)
+		((rator d-env) (rand1 d-env) (rand2 d-env)  (rand3 d-env)))))
+      ((4)  (let ((rand1 (first rands))
+		  (rand2 (second rands))
+		  (rand3 (third rands))
+		  (rand4 (fourth rands)))
+	      (lambda (d-env)
+		((rator d-env)
+		 (rand1 d-env) (rand2 d-env) (rand3 d-env) (rand4 d-env)))))
+      (else
+       (lambda (d-env)
+	 (apply (rator d-env) (map (lambda (f) (f d-env)) rands)))))))
+
+(define bench1
+  `(begin
+     (set! fib
+	   (lambda (n)
+	     (if (< n 2)
+		 n
+		 (+ (fib (- n 1)) (fib (- n 2))))))
+     (fib 20)))
+
+(define (go)
+  ((compile bench1) #F)
+  ((compile bench1) #F)
+  ((compile bench1) #F)
+  ((compile bench1) #F)
+  ((compile bench1) #F))
+
+
+(lambda () (go))
+