394 lines
13 KiB
Scheme
394 lines
13 KiB
Scheme
;;;;COMPILER FROM SECTION 5.5 OF
|
|
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
|
|
|
;;;;Matches code in ch5.scm
|
|
|
|
;;;;This file can be loaded into Scheme as a whole.
|
|
;;;;**NOTE**This file loads the metacircular evaluator's syntax procedures
|
|
;;;; from section 4.1.2
|
|
;;;; You may need to change the (load ...) expression to work in your
|
|
;;;; version of Scheme.
|
|
|
|
;;;;Then you can compile Scheme programs as shown in section 5.5.5
|
|
|
|
;;**implementation-dependent loading of syntax procedures
|
|
(load "shared/sicp-syntax.scm") ;section 4.1.2 syntax procedures
|
|
|
|
|
|
;;;SECTION 5.5.1
|
|
|
|
(define (compile exp target linkage)
|
|
(cond ((self-evaluating? exp)
|
|
(compile-self-evaluating exp target linkage))
|
|
((quoted? exp) (compile-quoted exp target linkage))
|
|
((variable? exp)
|
|
(compile-variable exp target linkage))
|
|
((assignment? exp)
|
|
(compile-assignment exp target linkage))
|
|
((definition? exp)
|
|
(compile-definition exp target linkage))
|
|
((if? exp) (compile-if exp target linkage))
|
|
((lambda? exp) (compile-lambda exp target linkage))
|
|
((begin? exp)
|
|
(compile-sequence (begin-actions exp)
|
|
target
|
|
linkage))
|
|
((cond? exp) (compile (cond->if exp) target linkage))
|
|
((primitive-procedure? exp)
|
|
(compile-primitive exp target linkage))
|
|
((application? exp)
|
|
(compile-application exp target linkage))
|
|
(else
|
|
(error "Unknown expression type -- COMPILE" exp))))
|
|
|
|
|
|
(define (make-instruction-sequence needs modifies statements)
|
|
(list needs modifies statements))
|
|
|
|
(define (empty-instruction-sequence)
|
|
(make-instruction-sequence '() '() '()))
|
|
|
|
;; Implemented in 5.38.
|
|
(define (primitive-procedure? exp) #f)
|
|
|
|
;;;SECTION 5.5.2
|
|
|
|
;;;linkage code
|
|
|
|
(define (compile-linkage linkage)
|
|
(cond ((eq? linkage 'return)
|
|
(make-instruction-sequence '(continu) '()
|
|
'((" goto *continu;"))))
|
|
((eq? linkage 'next)
|
|
(empty-instruction-sequence))
|
|
(else
|
|
(make-instruction-sequence '() '()
|
|
`((" goto " ,linkage ";"))))))
|
|
|
|
(define (end-with-linkage linkage instruction-sequence)
|
|
(preserving '(continu)
|
|
instruction-sequence
|
|
(compile-linkage linkage)))
|
|
|
|
|
|
;;;simple expressions
|
|
|
|
(define (compile-self-evaluating exp target linkage)
|
|
(cond ((number? exp)
|
|
(end-with-linkage linkage
|
|
(make-instruction-sequence '() (list target)
|
|
`((" " ,target " = const_i32(" ,exp ");")))))
|
|
(else (error "SELF-EVAL -- unsupported type" exp))))
|
|
|
|
(define (compile-quoted exp target linkage)
|
|
(end-with-linkage linkage
|
|
(make-instruction-sequence '() (list target)
|
|
`((assign ,target (const ,(text-of-quotation exp)))))))
|
|
|
|
(define (compile-variable exp target linkage)
|
|
(end-with-linkage linkage
|
|
(make-instruction-sequence '(env) (list target)
|
|
`((" "
|
|
,target " " = " " lookup_variable_value
|
|
"(" "\"" ,exp "\"" ", " env ");")))))
|
|
|
|
(define (compile-assignment exp target linkage)
|
|
(let ((var (assignment-variable exp))
|
|
(get-value-code
|
|
(compile (assignment-value exp) 'val 'next)))
|
|
(end-with-linkage linkage
|
|
(preserving '(env)
|
|
get-value-code
|
|
(make-instruction-sequence '(env val) (list target)
|
|
`((perform (op set-variable-value!)
|
|
(const ,var)
|
|
(reg val)
|
|
(reg env))
|
|
(assign ,target (const ok))))))))
|
|
|
|
(define (compile-definition exp target linkage)
|
|
(let ((var (definition-variable exp))
|
|
(get-value-code
|
|
(compile (definition-value exp) 'val 'next)))
|
|
(end-with-linkage linkage
|
|
(preserving '(env)
|
|
get-value-code
|
|
(make-instruction-sequence '(env val) (list target)
|
|
`((" " ,target " = define_variable(\"" ,var "\", val, env);")
|
|
))))))
|
|
|
|
|
|
;;;conditional expressions
|
|
|
|
;;;labels (from footnote)
|
|
(define label-counter 0)
|
|
|
|
(define (new-label-number)
|
|
(set! label-counter (+ 1 label-counter))
|
|
label-counter)
|
|
|
|
(define (make-label name)
|
|
(string->symbol
|
|
(string-append (symbol->string name)
|
|
(number->string (new-label-number)))))
|
|
;; end of footnote
|
|
|
|
(define (compile-if exp target linkage)
|
|
(let ((t-branch (make-label 'truebranch))
|
|
(f-branch (make-label 'falsebranch))
|
|
(after-if (make-label 'afterif)))
|
|
(let ((consequent-linkage
|
|
(if (eq? linkage 'next) after-if linkage)))
|
|
(let ((p-code (compile (if-predicate exp) 'val 'next))
|
|
(c-code
|
|
(compile
|
|
(if-consequent exp) target consequent-linkage))
|
|
(a-code
|
|
(compile (if-alternative exp) target linkage)))
|
|
(preserving '(env continu)
|
|
p-code
|
|
(append-instruction-sequences
|
|
(make-instruction-sequence '(val) '()
|
|
`((" if(is_false(val))")
|
|
(" goto " ,f-branch ";")
|
|
(" goto " ,t-branch ";")
|
|
))
|
|
(parallel-instruction-sequences
|
|
(append-instruction-sequences
|
|
(make-instruction-sequence '() '() `((,t-branch ":")))
|
|
c-code)
|
|
(append-instruction-sequences
|
|
(make-instruction-sequence '() '() `((,f-branch ":")))
|
|
a-code))
|
|
(make-instruction-sequence '() '() `((,after-if ":")))
|
|
))))))
|
|
|
|
;;; sequences
|
|
|
|
(define (compile-sequence seq target linkage)
|
|
(if (last-exp? seq)
|
|
(compile (first-exp seq) target linkage)
|
|
(preserving '(env continu)
|
|
(compile (first-exp seq) target 'next)
|
|
(compile-sequence (rest-exps seq) target linkage))))
|
|
|
|
;;;lambda expressions
|
|
|
|
(define (compile-lambda exp target linkage)
|
|
(let ((proc-entry (make-label 'entry))
|
|
(after-lambda (make-label 'afterlambda)))
|
|
(let ((lambda-linkage
|
|
(if (eq? linkage 'next) after-lambda linkage)))
|
|
(append-instruction-sequences
|
|
(tack-on-instruction-sequence
|
|
(end-with-linkage lambda-linkage
|
|
(make-instruction-sequence '(env) (list target)
|
|
`((" " ,target " = make_compiled_proc(&&" ,proc-entry ", env);"))))
|
|
(compile-lambda-body exp proc-entry))
|
|
(make-instruction-sequence '() '() `((,after-lambda ":")))))))
|
|
|
|
(define (compile-lambda-body exp proc-entry)
|
|
(define (formals-to-string formals)
|
|
(if (null? formals)
|
|
""
|
|
(string-append
|
|
"\""
|
|
(string-append
|
|
(symbol->string (car formals))
|
|
(string-append
|
|
"\", "
|
|
(formals-to-string (cdr formals)))))))
|
|
(let ((formals (lambda-parameters exp))
|
|
(argv (make-label 'argv)))
|
|
(append-instruction-sequences
|
|
(make-instruction-sequence '(env proc argl) '(env)
|
|
`(
|
|
(,proc-entry ":")
|
|
(" env = proc->env;")
|
|
(" const char *" ,argv "[] = {" ,(formals-to-string formals) "};")
|
|
(" env = extend_environment(" ,argv ", argl, env);")
|
|
))
|
|
;(" env = extend_environment(" (const ,formals) ", argl, env);")))
|
|
(compile-sequence (lambda-body exp) 'val 'return))))
|
|
|
|
|
|
;;;SECTION 5.5.3
|
|
|
|
;;;combinations
|
|
|
|
(define (compile-application exp target linkage)
|
|
(let ((proc-code (compile (operator exp) 'proc 'next))
|
|
(operand-codes
|
|
(map (lambda (operand) (compile operand 'val 'next))
|
|
(operands exp))))
|
|
(preserving '(env continu)
|
|
proc-code
|
|
(preserving '(proc continu)
|
|
(construct-arglist operand-codes)
|
|
(compile-procedure-call target linkage)))))
|
|
|
|
(define (construct-arglist operand-codes)
|
|
(let ((operand-codes (reverse operand-codes)))
|
|
(if (null? operand-codes)
|
|
(make-instruction-sequence '() '(argl)
|
|
'((" argl = NULL;")))
|
|
(let ((code-to-get-last-arg
|
|
(append-instruction-sequences
|
|
(car operand-codes)
|
|
(make-instruction-sequence '(val) '(argl)
|
|
'((" argl = cons(val, NULL);"))))))
|
|
(if (null? (cdr operand-codes))
|
|
code-to-get-last-arg
|
|
(preserving '(env)
|
|
code-to-get-last-arg
|
|
(code-to-get-rest-args
|
|
(cdr operand-codes))))))))
|
|
|
|
(define (code-to-get-rest-args operand-codes)
|
|
(let ((code-for-next-arg
|
|
(preserving '(argl)
|
|
(car operand-codes)
|
|
(make-instruction-sequence '(val argl) '(argl)
|
|
`((" argl = cons(val, argl);"))))))
|
|
(if (null? (cdr operand-codes))
|
|
code-for-next-arg
|
|
(preserving '(env)
|
|
code-for-next-arg
|
|
(code-to-get-rest-args (cdr operand-codes))))))
|
|
|
|
;;;applying procedures
|
|
|
|
(define (compile-procedure-call target linkage)
|
|
(let ((primitive-branch (make-label 'primitivebranch))
|
|
(compiled-branch (make-label 'compiledbranch))
|
|
(after-call (make-label 'aftercall)))
|
|
(let ((compiled-linkage
|
|
(if (eq? linkage 'next) after-call linkage)))
|
|
(append-instruction-sequences
|
|
(make-instruction-sequence '(proc) '()
|
|
`((" if (" primitive_procedure "(proc) == 1)")
|
|
(" goto " ,primitive-branch ";")
|
|
(" goto " ,compiled-branch ";")))
|
|
(parallel-instruction-sequences
|
|
(append-instruction-sequences
|
|
(make-instruction-sequence '() '() `((,compiled-branch ":")))
|
|
(compile-proc-appl target compiled-linkage))
|
|
(append-instruction-sequences
|
|
(make-instruction-sequence '() '() `((,primitive-branch ":")))
|
|
(end-with-linkage linkage
|
|
(make-instruction-sequence '(proc argl)
|
|
(list target)
|
|
`((" val = (*proc->primitive_procedure)(argl);"))))))
|
|
(make-instruction-sequence '() '() `((,after-call ":")))))))
|
|
|
|
;;;applying compiled procedures
|
|
|
|
(define (compile-proc-appl target linkage)
|
|
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
|
|
(make-instruction-sequence '(proc) all-regs
|
|
`((" continu = &&" ,linkage ";")
|
|
(" " entry " = " compiled_procedure_entry "(proc);")
|
|
(" goto *entry;"))))
|
|
((and (not (eq? target 'val))
|
|
(not (eq? linkage 'return)))
|
|
(let ((proc-return (make-label 'proc-return)))
|
|
(make-instruction-sequence '(proc) all-regs
|
|
`((assign continu (label ,proc-return))
|
|
(assign val (op compiled_procedure_entry)
|
|
(reg proc))
|
|
(" goto " (reg val) "// FOO2")
|
|
,proc-return
|
|
(assign ,target (reg val))
|
|
(" goto " (label ,linkage) "; // FOO1")))))
|
|
((and (eq? target 'val) (eq? linkage 'return))
|
|
(make-instruction-sequence '(proc continu) all-regs
|
|
'((" entry = compiled_procedure_entry(proc);")
|
|
(" goto *entry;")
|
|
)))
|
|
((and (not (eq? target 'val)) (eq? linkage 'return))
|
|
(error "return linkage, target not val -- COMPILE"
|
|
target))))
|
|
|
|
;; footnote
|
|
(define all-regs '(env proc val argl continu))
|
|
|
|
|
|
;;;SECTION 5.5.4
|
|
|
|
(define (registers-needed s)
|
|
(if (symbol? s) '() (car s)))
|
|
|
|
(define (registers-modified s)
|
|
(if (symbol? s) '() (cadr s)))
|
|
|
|
(define (statements s)
|
|
(if (symbol? s) (list s) (caddr s)))
|
|
|
|
(define (needs-register? seq reg)
|
|
(memq reg (registers-needed seq)))
|
|
|
|
(define (modifies-register? seq reg)
|
|
(memq reg (registers-modified seq)))
|
|
|
|
|
|
(define (append-instruction-sequences . seqs)
|
|
(define (append-2-sequences seq1 seq2)
|
|
(make-instruction-sequence
|
|
(list-union (registers-needed seq1)
|
|
(list-difference (registers-needed seq2)
|
|
(registers-modified seq1)))
|
|
(list-union (registers-modified seq1)
|
|
(registers-modified seq2))
|
|
(append (statements seq1) (statements seq2))))
|
|
(define (append-seq-list seqs)
|
|
(if (null? seqs)
|
|
(empty-instruction-sequence)
|
|
(append-2-sequences (car seqs)
|
|
(append-seq-list (cdr seqs)))))
|
|
(append-seq-list seqs))
|
|
|
|
(define (list-union s1 s2)
|
|
(cond ((null? s1) s2)
|
|
((memq (car s1) s2) (list-union (cdr s1) s2))
|
|
(else (cons (car s1) (list-union (cdr s1) s2)))))
|
|
|
|
(define (list-difference s1 s2)
|
|
(cond ((null? s1) '())
|
|
((memq (car s1) s2) (list-difference (cdr s1) s2))
|
|
(else (cons (car s1)
|
|
(list-difference (cdr s1) s2)))))
|
|
|
|
(define (preserving regs seq1 seq2)
|
|
(if (null? regs)
|
|
(append-instruction-sequences seq1 seq2)
|
|
(let ((first-reg (car regs)))
|
|
(if (and (needs-register? seq2 first-reg)
|
|
(modifies-register? seq1 first-reg))
|
|
(preserving (cdr regs)
|
|
(make-instruction-sequence
|
|
(list-union (list first-reg)
|
|
(registers-needed seq1))
|
|
(list-difference (registers-modified seq1)
|
|
(list first-reg))
|
|
(append `((" save(",first-reg ", " ,first-reg "_stack);"))
|
|
(statements seq1)
|
|
`((" " ,first-reg " = restore(" ,first-reg "_stack);"))))
|
|
seq2)
|
|
(preserving (cdr regs) seq1 seq2)))))
|
|
|
|
(define (tack-on-instruction-sequence seq body-seq)
|
|
(make-instruction-sequence
|
|
(registers-needed seq)
|
|
(registers-modified seq)
|
|
(append (statements seq) (statements body-seq))))
|
|
|
|
(define (parallel-instruction-sequences seq1 seq2)
|
|
(make-instruction-sequence
|
|
(list-union (registers-needed seq1)
|
|
(registers-needed seq2))
|
|
(list-union (registers-modified seq1)
|
|
(registers-modified seq2))
|
|
(append (statements seq1) (statements seq2))))
|
|
|
|
'(COMPILER LOADED)
|