DataMuseum.dk

top - metrics - download

    Length: 11988 (0x2ed4)
    Types: TextFile
    Names: »compiler.scm«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─⟦this⟧ »EUUGD11/gnu-31mar87/scheme/psets/compiler.scm« 

TextFile

;;; Simple SCHEME compiler

(define (compile exp)
  (compile-expression exp '() 'val 'return))

(define (compile-expression exp env target cont)
  (cond ((self-evaluating? exp)
	 (compile-constant exp target cont))
	((quoted? exp)
	 (compile-constant (text-of-quotation exp) target cont))
	((variable? exp)
	 (compile-variable-access exp env target cont))
	((assignment? exp)
	 (compile-assignment exp env target cont))
	((definition? exp)
	 (compile-definition exp env target cont))
	((lambda? exp)
	 (compile-lambda exp env target cont))
	((conditional? exp)
	 (compile-cond (clauses exp) env target cont))
	((no-args? exp)
	 (compile-no-args exp env target cont))
	((application? exp)
	 (compile-application exp env target cont))
	(else
	 (error "Unknown expression type -- compile" exp))))

(define (compile-constant constant target cont)
  (append-instruction-sequences
   (make-register-assignment target (make-constant constant))
   (continue-at cont)))

(define (compile-variable-access var env target cont)
  (append-instruction-sequences
   (make-register-assignment target (make-variable-access var env))
   (continue-at cont)))

(define (compile-assignment exp env target cont)
  (let ((target (if (null? target) 'val target)))
    (preserving 'env
		(compile-expression (assignment-value exp) env target 'next)
		(append-instruction-sequences
		 (make-variable-assignment (assignment-variable exp)
					   env
					   (make-fetch target))
		 (continue-at cont)))))

(define (compile-definition exp env target cont)
  (let ((target (if (null? target) 'val target)))
    (preserving 'env
     (compile-expression (definition-value exp)
			 (definition-env! (definition-variable exp)
			   env)
			 target
			 'next)
     (append-instruction-sequences
      (make-variable-definition (definition-variable exp)
				env
				(make-fetch target))
      (continue-at cont)))))
\f


(define (compile-lambda exp env target cont)
  (let ((entry (generate-new-name 'entry)))
    (append-instruction-sequences
     (make-register-assignment target (make-procedure-maker entry))
     (if (eq? cont 'next)
	 (let ((after-lambda (generate-new-name 'after-lambda)))
	   (append-instruction-sequences
	    (continue-at after-lambda)
	    (append-instruction-sequences
	     (compile-lambda-body exp env entry)
	     (make-labeled-point after-lambda))))
	 (append-instruction-sequences
	  (continue-at cont)
	  (compile-lambda-body exp env entry)))))) 

(define (compile-lambda-body exp env entry)
  (safe-instruction-sequence
   (append-instruction-sequences
    (make-labeled-point entry)
    (append-instruction-sequences
     (make-environment-switch (lambda-parameters exp))
     (compile-sequence (lambda-body exp)
		       (extend-compile-time-env (lambda-parameters exp)
						env)
		       'val
		       'return)))))

(define (make-environment-switch formals)
  (append-instruction-sequences
   (make-register-assignment 'env
			     (make-env-ref (make-fetch 'fun)))
   (make-register-assignment 'env
			     (make-bindings-maker formals
						  (make-fetch 'argl)
						  (make-fetch 'env)))))


(define (compile-cond clauses env target cont)
  (if (eq? cont 'next)
      (let ((end-of-cond (generate-new-name 'cond-end)))
	(append-instruction-sequences
	 (compile-clauses clauses env target end-of-cond)
	 (make-labeled-point end-of-cond)))	;Output label
      (compile-clauses clauses env target cont)))

(define (compile-clauses clauses env target cont)
  (if (no-clauses? clauses)
      (continue-at cont)
      (let ((fc (first-clause clauses)))
        (if (else-clause? fc)
            (compile-sequence (action-sequence fc) env target cont)
	    (let ((ift (generate-new-name 'true-branch)))
	      (preserving 'env
	       (compile-expression (predicate fc) env 'val 'next)
	       (append-instruction-sequences
		(make-branch (make-fetch 'val) ift)
		(join-instruction-sequences
		 (compile-clauses (rest-clauses clauses) env target cont)
		 (append-instruction-sequences
		  (make-labeled-point ift)
		  (compile-sequence (action-sequence fc) env target cont))))))))))
\f


(define (compile-sequence seq env target cont)
  (if (last-exp? seq)
      (compile-expression (first-exp seq) env target cont)
       (preserving 'env
		   (compile-expression (first-exp seq) env 'nil 'next)
		   (compile-sequence (rest-exps seq) env target cont))))


(define (compile-no-args app env target cont)
  (append-instruction-sequences
   (compile-expression (operator app) env 'fun 'next)
   (append-instruction-sequences
    (make-register-assignment 'argl (make-empty-arglist))
    (make-call target cont))))


(define (compile-application app env target cont)
  (preserving 'env
	      (compile-expression (operator app) env 'fun 'next)
	      (preserving 'fun
			  (compile-operands (operands app) env)
			  (make-call target cont))))

(define (compile-operands rands env)
  (let ((fo (compile-first-operand rands env)))
    (if (last-operand? rands)
	fo
	(preserving 'env
		    fo
		    (compile-rest-operands (rest-operands rands) env)))))

(define (compile-first-operand rands env)
  (append-instruction-sequences
   (compile-expression (first-operand rands) env 'val 'next)
   (make-register-assignment 'argl
			     (make-singleton-arglist (make-fetch 'val)))))

(define (compile-rest-operands rands env)
  (let ((no (compile-next-operand rands env)))
    (if (last-operand? rands)
	no
	(preserving 'env
		    no
		    (compile-rest-operands (rest-operands rands) env)))))

(define (compile-next-operand rands env)
  (preserving 'argl
	      (compile-expression (first-operand rands) env 'val 'next)
	      (make-register-assignment 'argl
		 (make-addition-to-arglist (make-fetch 'val)
					   (make-fetch 'argl)))))
\f


(define (make-call target cont)
  (let ((cc (make-call-result-in-val cont)))
    (if (eq? target 'val)
	cc
	(append-instruction-sequences
	 cc
	 (make-register-assignment target (make-fetch 'val))))))

(define (make-call-result-in-val cont)
  (cond ((eq? cont 'return)
	 (make-transfer-to-procedure-applicator))
	((eq? cont 'next)
	 (let ((after-call (generate-new-name 'after-call)))
	   (append-instruction-sequences
	    (make-call-return-to after-call)
	    (make-labeled-point after-call))))
	(else
	 (make-call-return-to cont))))			;A label

(define (make-call-return-to retlabel)
  (append-instruction-sequences
   (append-instruction-sequences
    (make-register-assignment 'continue retlabel)
    (make-save 'continue))
   (make-transfer-to-procedure-applicator)))

(define (continue-at continuation)
  (cond ((eq? continuation 'return)
	 (append-instruction-sequences
	  (make-restore 'continue)
	  (make-goto-instruction (make-fetch 'continue))))
	((eq? continuation 'next)
	 (the-empty-instruction-sequence))
	(else
	 (make-goto-instruction continuation))))



(define (append-instruction-sequences s1 s2)
  (make-seq (set-union (needs-list s1)
		       (set-difference (needs-list s2)
				       (mung-list s1)))
	    (set-union (mung-list s1) (mung-list s2))
	    (append (statements s1) (statements s2))))

(define (preserving reg seq1 seq2)
  (if (and (memq reg (needs-list seq2))
	   (memq reg (mung-list seq1)))
      (append-instruction-sequences
       (make-seq (needs-list seq1)
		 (set-difference (mung-list seq1) (list reg))
		 (append (statements (make-save reg))
			 (statements seq1)
			 (statements (make-restore reg))))
       seq2)
      (append-instruction-sequences seq1 seq2)))

(define (join-instruction-sequences s1 s2)
  (make-seq (set-union (needs-list s1) (needs-list s2))
	    (set-union (mung-list s1) (mung-list s2))
	    (append (statements s1) (statements s2))))

(define (safe-instruction-sequence seq)
  (make-seq '() '() (statements seq)))
\f


;;; Nothing above this line knows the format of
;;;  an "assembly-language" instruction.

(define (make-goto-instruction continuation)
  (make-instruction (needs-list continuation)
		    '()
		    (list 'goto (value-of continuation))))

(define (make-branch predicate if-true-label)
  (make-instruction (needs-list predicate)
		    '()
		    (list 'branch
			  (value-of predicate)
			  if-true-label)))

(define (make-transfer-to-procedure-applicator)
  (make-instruction '(fun argl) all '(goto apply-dispatch)))

(define (make-labeled-point label)
  (make-instruction '() '() label))

(define (make-register-assignment reg val)
  (cond ((not (null? reg))
	 (make-instruction (needs-list val)
			   (list reg)
			   (list 'assign reg (value-of val))))
	(else
	 (the-empty-instruction-sequence))))

(define (make-fetch reg)
  (make-value (list reg) (list 'fetch reg)))

(define (make-save reg)
  (make-instruction '() '() (list 'save reg)))

(define (make-restore reg)
  (make-instruction '() '() (list 'restore reg)))

(define (make-constant x)
  (make-value '() (list 'quote x)))

(define (make-variable-access var compilation-env)
  (make-value '(env)
	      (list 'lookup-variable-value
		    (list 'quote var)
		    (value-of (make-fetch 'env)))))

(define (make-variable-assignment var compilation-env val)
  (make-instruction (set-union '(env) (needs-list val))
		    '()
		    (list 'perform
			  (list 'set-variable-value!
				(list 'quote var)
				(value-of val)
				(value-of (make-fetch 'env))))))

(define (make-variable-definition var compilation-env val)
  (make-instruction (set-union '(env) (needs-list val))
		    '()
		    (list 'perform
			  (list 'define-variable!
				(list 'quote var)
				(value-of val)
				(value-of (make-fetch 'env))))))
\f


(define (make-bindings-maker vars args env)
  (make-value (list (needs-list args) (needs-list env)) 
	      (list 'extend-environment
		    (list 'quote (reverse vars))
		    (value-of args)
		    (value-of env))))

(define (make-procedure-maker entry)
  (make-value '(env)
	      (list 'make-compiled-procedure
		    entry
		    (value-of (make-fetch 'env)))))

(define (make-env-ref fun)
  (make-value (needs-list fun)
	      (list 'env-of-compiled-procedure
		    (value-of fun))))

(define (make-empty-arglist)
  (make-value '() '()))

(define (make-singleton-arglist val)
  (make-value (needs-list val)
	      (list 'cons (value-of val) '())))

(define (make-addition-to-arglist val args)
  (make-value (set-union (needs-list val) (needs-list args))
	      (list 'cons (value-of val) (value-of args))))


;; From here on down is internal compiler data structure stuff:

(define (make-value needed-regs expression)
  (list needed-regs expression))

(define (needs-list value)
  (if (symbol? value)			; Label
      '()
      (car value)))

(define (value-of value)
  (if (symbol? value)
      value
      (cadr value)))

(define (make-instruction needs mungs code)
  (make-seq needs mungs (list code)))

(define (make-seq needs mungs seq)
  (list needs mungs seq))

(define (the-empty-instruction-sequence)
  (list '() '() '()))
  
;;;NEEDS-LIST already defined above.
(define (mung-list seq) (cadr seq))
(define (statements seq) (caddr seq))

(define (set-union x y)
  (cond ((null? x) y)
	((memq (car x) y) (set-union (cdr x) y))
	(else (cons (car x) (set-union (cdr x) y)))))

(define (set-difference x y)
  (cond ((null? x) '())
	((memq (car x) y)
	 (set-difference (cdr x) y))
	(else
	 (cons (car x)
	       (set-difference (cdr x) y)))))

(define (extend-compile-time-env frame env)
  (cons (reverse frame) env))   ;;note reversal to match interpreter's
                                ;;make-bindings 

(define (definition-env! var env)
  (if (and (not (null? env))
	   (not (memq var (car env))))
      (set-car! env (cons var env)))
  env)


(define (given-new-definition var env)
  (if (null? env)					;global?
      env						;no nothing.
      (cons (cons var (car env))			;add to top frame
	    (cdr env))))

(sequence
 (enable-language-features)
 (define generate-new-name
   (access generate-uninterned-symbol '()))
 (disable-language-features))

(define all '(env argl val fun continue))


;; Syntax extras

(define (lambda-parameters exp) (cadr exp))

(define (lambda-body exp) (cddr exp))