Initial revision

diff --git a/v8/src/bench/fcomp.scm b/v8/src/bench/fcomp.scm
new file mode 100644 (file)
index 0000000..9710eff
--- /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))
+