[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Scheme implementation techniques?

To: scheme@mc.lcs.mit.edu
Subject: Re: Scheme implementation techniques?
From: mailrus!jarvis.csri.toronto.edu!utgpu!utzoo!yunexus!oz@husc6.harvard.edu (Ozan Yigit)
Date: Sat ,25 Mar 89 18:16:59 EDT
Organization: York U. Computing Services - Magic Group
References: <1229@mina.liu.se>
Sender: scheme-request@mc.lcs.mit.edu
In article <1229@mina.liu.se> mikpe@mina.liu.se (Mikael Pettersson) writes:
>
>What are the approaches that have been used to implement interactive
>Scheme systems? I am more-or-less familiar with the following ones:
	... usual implementation techniques ... 
>
>Are there any other approaches worth considering?
>

There is one other way I know of, having gone thru most of the
material included in my bibliography. This method may be called (in
a very loose way) the "threaded code" technique, or enclosing
everything into a lambda closure. The technique is discussed in
detail in the following paper:

	%A Marc Feeley
	%A Guy LaPalme
	%T Using Cloures for Code Generation
	%J Journal of Computer Languages
	%V 12
	%N 1
	%P 47-66
	%I Pergamon Press
	%D 1987

Or, in a lot greater detail, including 68000 code generation, in the
following thesis:

	%A Marc Feeley
	%T Deux Approches a' L'implantation du Language Scheme
	%I M.Sc. Thesis, De'partement d'Informatique et de Recherche
	Ope'rationelle, University of Montreal
	%D May 1986

Here is the "optimizing compiler" from the first paper. It worked
for the example in the paper, so I think I typed it right.

;
; Optimizing scheme compiler
; supports quote, set!, if, lambda special forms,
; constant refs, variable refs and proc applications
;
; Using Clusures for Code Generation
; Marc Feeley and Guy LaPalme
; Computer Language, Vol. 12, No. 1, pp. 47-66
; 1987
;

(define (compile expr)
  ((gen expr nil #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 nil)
	 ((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-pr0* gen-pr0))
	((symbol? parms)
		(if term gen-pr1/rest* gen-pr1/rest))
	((null? (cdr parms))
		(if term gen-pr1* gen-pr1))
	((symbol? (cdr parms))
		(if term gen-pr2/rest* gen-pr2/rest))
	((null? (cddr parms))
		(if term gen-pr2* gen-pr2))
	((symbol? (cddr parms))
		(if term gen-pr3/rest* gen-pr3/rest))
	((null? (cdddr parms))
		(if term gen-pr3 gen-pr3))
	(else
		(error "too many parameters in a lambda-expression")))
	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 in a proc application")))
	vals))
;
; code generation for non-terminal evaluations
;

;
; constants
;

(define (gen-1)		(lambda () 1))
(define (gen-2)		(lambda () 2))
(define (gen-null) 	(lambda () #!null))
(define (gen-cst a)	(lambda () a))

;
; variable reference
;

(define (gen-ref-glo a)	(lambda () (cdr a)))		; global var
(define (gen-ref-loc-1)	(lambda () (cadr *env*)))	; first local var
(define (gen-ref-loc-2)	(lambda () (caddr *env*)))	; second local var
(define (gen-ref-loc-3)	(lambda () (cadddr *env*)))	; third local var
(define (gen-ref a)	(lambda () (do ((i 0 (1+ i))	; any non-global
					(env (cdr *env*) (cdr env)))
				       ((= i a) (car env)))))

;
; assignment
;

(define (gen-set-glo a b)	(lambda () (set-cdr! a (b))))
(define (gen-set-loc-1 a)	(lambda () (set-car! (cdr *env*) (a))))
(define (gen-set-loc-2 a)	(lambda () (set-car! (cddr *env*) (a))))
(define (gen-set-loc-3 a)	(lambda () (set-car! (cdddr *env*) (a))))
(define (gen-set a b)		(lambda () (do ((i 0 (1+ i))
						(env (cdr *env*) (cdr env)))
					       ((= i a) (set-car! env (b))))))

;
; conditional
;

(define (gen-tst a b c)		(lambda () (if (a) (b) (c))))

;
; procedure application
;

(define (gen-ap0-glo a)		(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))))

(define (gen-ap0 a)		(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))))

;
; lambda expressions
;

(define (gen-pr0 a)	; without "rest" parameter
  (lambda ()
    (let ((def (cdr *env*)))
      (lambda () 
	(set! *env* (cons *env* def))
	(a)))))

(define (gen-pr1 a)
  (lambda ()
    (let ((def (cdr *env*)))
      (lambda (x)
	(set! *env* (cons *env* (cons x def)))
	(a)))))

(define (gen-pr2 a)
  (lambda ()
    (let ((def (cdr *env*)))
      (lambda (x y)
	(set! *env* (cons *env* (cons x (cons y def))))
	(a)))))

(define (gen-pr3 a)
  (lambda ()
    (let ((def (cdr *env*)))
      (lambda (x y z)
	(set! *env* (cons *env* (cons x (cons y (cons z def)))))
	(a)))))

(define (gen-pr1/rest a)
  (lambda ()
    (let ((def (cdr *env*)))
      (lambda x
	(set! *env* (cons *env* (cons x def)))
	(a)))))

(define (gen-pr2/rest a)
  (lambda ()
    (let ((def (cdr *env*)))
      (lambda (x . y)
	(set! *env* (cons *env* (cons x (cons y def))))
	(a)))))

(define (gen-pr3/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 for terminal evaluations
;

;
; constants
;

(define (gen-1*)
  (lambda ()
    (set! *env* (car *env*))
    1))

(define (gen-2*)
  (lambda ()
    (set! *env* (car *env*))
    2))

(define (gen-null*)
  (lambda ()
    (set! *env* (car *env*))
    #!null))

(define (gen-cst* a)
  (lambda ()
    (set! *env* (car *env*))
    a))

;
; variable reference
;

(define (gen-ref-glo* a)
  (lambda ()
    (set! *env* (car *env*))
    (cdr a)))

(define (gen-ref-loc-1*)
  (lambda ()
    (let ((val (cadr *env*)))
      (set! *env* (car *env*))
      val)))

(define (gen-ref-loc-2*)
  (lambda ()
    (let ((val (caddr *env*)))
      (set! *env* (car *env*))
      val)))

(define (gen-ref-loc-3*)
  (lambda ()
    (let ((val (cadddr *env*)))
      (set! *env* (car *env*))
      val)))

(define (gen-ref* a)
  (lambda ()
    (do ((i 0 (1+ i))
	 (env (cdr *env*) (cdr env)))
	((= i a)
	 (set! *env* (car *env*))
	 (car env)))))

;
; assignment
;

(define (gen-set-glo* a b)
  (lambda ()
    (set! *env* (car *env*))
    (set-cdr! a (b))))

(define (gen-set-loc-1* a)
  (lambda ()
    (set! *env* (car *env*))
    (set-car! (cdr *env*) (a))))

(define (gen-set-loc-2* a)
  (lambda ()
    (set! *env* (car *env*))
    (set-car! (cddr *env*) (a))))

(define (gen-set-loc-3* a)
  (lambda ()
    (set! *env* (car *env*))
    (set-car! (cdddr *env*) (a))))

(define (gen-set* a b)
  (lambda ()
    (do ((i 0 (1+ i))
	 (env (cdr *env*) (cdr env)))
	((= i 0)
	 (set! *env* (car *env*))
	 (set-car! env (b))))))

;
; procedure application
;

(define (gen-ap0-glo* a)
  (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))))

(define (gen-ap0* a)
  (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))))

;
; lambda
;

(define (gen-pr0* a)
  (lambda ()
    (let ((def (cdr *env*)))
      (set! *env* (car *env*))
      (lambda ()
	(set! *env* (cons *env* def))
	(a)))))


(define (gen-pr1* a)
  (lambda ()
    (let ((def (cdr *env*)))
      (set! *env* (car *env*))
      (lambda (x)
	(set! *env* (cons *env* (cons x def)))
	(a)))))

(define (gen-pr2* 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-pr3* 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-pr1/rest* a)
  (lambda ()
    (let ((def (cdr *env*)))
      (set! *env* (car *env*))
      (lambda x
	(set! *env* (cons *env* (cons x def)))
	(a)))))

(define (gen-pr2/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-pr1/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 defs
;

(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 '-1+ -1+)
(define-global '+ +)
(define-global '- -)

;
; current environment
;

(define *env* '(dummy)))

;
; environment manipulation
;

(define (restore-env)
  (set! *env* (car *env*)))

;
; evaluator
;

(define (evaluate expr)
  ((compile (list 'lambda '() expr))))

; 
; (evaluate '(define 'fib
; 	     (lambda (x)
; 	       (if (< x 2)
; 		   x
; 		   (+ (fib (- x 1))
; 		      (fib (- x 2)))))))
; 
; 
-- 
... and I say to them, 	    		Usenet:    oz@nexus.yorku.ca
   `Where the hell were you        	......!uunet!utai!yunexus!oz
    when the page was blank?'		Bitnet: oz@[yulibra|yuyetti]
		Harlan Ellison  	Phonet: +1 416 736-5257x3976
References:
- Scheme implementation techniques?
  - From: mcvax!kth!draken!liuida!mikpe@uunet.uu.net (Mikael Pettersson)
Prev by Date: SPEED OF TI's PC-SCHEME, EXPANDED AND EXTENDED MEMORY VERSIONS
Next by Date: TI Scheme functions for MIT C-Scheme - 3 of 3
Previous by thread: Scheme implementation techniques?
Next by thread: SPEED OF TI's PC-SCHEME, EXPANDED AND EXTENDED MEMORY VERSIONS
Index(es):
- Date
- Thread