From c94c77c06f69a1cf36825e421b5290762eec6b2e Mon Sep 17 00:00:00 2001 From: Stephen Adams <edu/mit/csail/zurich/adams> Date: Sun, 26 Mar 1995 16:49:13 +0000 Subject: [PATCH] Initial revision --- v8/src/bench/fcomp.scm | 217 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 217 insertions(+) create mode 100644 v8/src/bench/fcomp.scm 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)) + -- 2.25.1