diff options
Diffstat (limited to 'chap5/part5.rkt')
| -rw-r--r-- | chap5/part5.rkt | 661 |
1 files changed, 661 insertions, 0 deletions
diff --git a/chap5/part5.rkt b/chap5/part5.rkt new file mode 100644 index 0000000..9db1e73 --- /dev/null +++ b/chap5/part5.rkt @@ -0,0 +1,661 @@ +#lang sicp +(#%require (only racket/base print-as-expression print-mpair-curly-braces)) +(print-as-expression #f) +(print-mpair-curly-braces #f) + +;; Chapter 5 +;; Computing with Register Machines + +;; 5.5 +;; Compilation + +;; Structure of the Compiler + +(#%provide show-compile) +(define (show-compile exp) + (for-each + (lambda (inst) + (display inst) + (newline)) + (statements (compile exp 'val 'done)))) + +(#%provide compile) +(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)) + ((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 '() '() '())) + +#| 5.31 |# + +;; a. preserve env around evaluation of operator +;; b. preserve env around evaluation of each operand (except last) +;; c. preserve argl around evaluation of each operand +;; d. preserve proc around entire operand sequence + +;; (f 'x 'y) +;; don't need a, b, c, or d + +;; ((f) 'x 'y) +;; don't need b, c, or d + +;; (f (g 'x) y) +;; don't need a + +;; (f (g 'x) 'y) +;; don't need a or b + +;; Compiling Expressions + +(define (compile-linkage linkage) + (cond + ((eq? linkage 'return) + (make-instruction-sequence + '(continue) + '() + '((goto (reg continue))))) + ((eq? linkage 'next) + (empty-instruction-sequence)) + (else + (make-instruction-sequence + '() + '() + `((goto (label ,linkage))))))) + +(define (end-with-linkage linkage instruction-sequence) + (preserving + '(continue) + instruction-sequence + (compile-linkage linkage))) + +(define (compile-self-evaluating exp target linkage) + (end-with-linkage + linkage + (make-instruction-sequence + '() + (list target) + `((assign ,target (const ,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) + `((assign + ,target + (op lookup-variable-value) + (const ,exp) + (reg 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) + `((perform + (op define-variable!) + (const ,var) + (reg val) + (reg env)) + (assign ,target (const ok)))))))) + +(define (compile-if exp target linkage) + (let + ((t-branch (make-label 'true-branch)) + (f-branch (make-label 'false-branch)) + (after-if (make-label 'after-if))) + (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 continue) + p-code + (append-instruction-sequences + (make-instruction-sequence + '(val) + '() + `((test (op false?) (reg val)) + (branch (label ,f-branch)))) + (parallel-instruction-sequences + (append-instruction-sequences t-branch c-code) + (append-instruction-sequences f-branch a-code)) + after-if)))))) + +(define (compile-sequence seq target linkage) + (if (last-exp? seq) + (compile (first-exp seq) target linkage) + (preserving + '(env continue) + (compile (first-exp seq) target 'next) + (compile-sequence (rest-exps seq) target linkage)))) + +(define (compile-lambda exp target linkage) + (let + ((proc-entry (make-label 'entry)) + (after-lambda (make-label 'after-lambda))) + (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) + `((assign + ,target + (op make-compiled-procedure) + (label ,proc-entry) + (reg env))))) + (compile-lambda-body exp proc-entry)) + after-lambda)))) + +(define (compile-lambda-body exp proc-entry) + (let ((formals (lambda-parameters exp))) + (append-instruction-sequences + (make-instruction-sequence + '(env proc argl) + '(env) + `(,proc-entry + (assign env (op compiled-procedure-env) (reg proc)) + (assign + env + (op extend-environment) + (const ,formals)) + (reg argl) + (reg env))) + (compile-sequence (lambda-body exp) 'val 'return)))) + +(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))))) + +(define (make-compiled-procedure entry env) + (list 'compile-procedure entry env)) + +(define (compiled-procedure? proc) + (tagged-list? proc 'compiled-procedure)) + +(define (compiled-procedure-entry c-proc) (cadr c-proc)) + +(define (compiled-procedure-env c-proc) (caddr c-proc)) + +;; Compiling 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 continue) + proc-code + (preserving + '(proc continue) + (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) + '((assign argl (const ())))) + (let + ((code-to-get-last-arg + (append-instruction-sequences + (car operand-codes) + (make-instruction-sequence + '(val) + '(argl) + '((assign argl (op list) (reg val))))))) + (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) + '((assign argl (op cons) (reg val) (reg argl))))))) + (if (null? (cdr operand-codes)) + code-for-next-arg + (preserving + '(env) + code-for-next-arg + (code-to-get-rest-args + (cdr operand-codes)))))) + +(define (compile-procedure-call target linkage) + (let + ((primitive-branch (make-label 'primitive-branch)) + (compiled-branch (make-label 'compiled-branch)) + (after-call (make-label 'after-call))) + (let + ((compiled-linkage + (if (eq? linkage 'next) after-call linkage))) + (append-instruction-sequences + (make-instruction-sequence + '(proc) + '() + `((test (op primitive-procedure?) (reg proc)) + (branch (label ,primitive-branch)))) + (parallel-instruction-sequences + (append-instruction-sequences + compiled-branch + (compile-proc-appl target compiled-linkage)) + (append-instruction-sequences + primitive-branch + (end-with-linkage + linkage + (make-instruction-sequence + '(proc argl) + (list target) + `((assign + ,target + (op apply-primitive-procedure) + (reg proc) + (reg argl))))))) + after-call)))) + +(define (compile-proc-appl target linkage) + (cond + ((and + (eq? target 'val) + (not (eq? linkage 'return))) + (make-instruction-sequence + '(proc) + all-regs + `((assign continue (label ,linkage)) + (assign val (op compiled-procedure-entry) (reg proc)) + (goto (reg val))))) + ((and + (not (eq? target 'val)) + (not (eq? linkage 'return))) + (let ((proc-return (make-label 'proc-return))) + (make-instruction-sequence + '(proc) + all-regs + `((assign continue (label ,proc-return)) + (assign val (op compiled-procedure-entry) (reg proc)) + (goto (reg val)) + ,proc-return + (assign ,target (reg val)) + (goto (label ,linkage)))))) + ((and + (eq? target 'val) + (eq? linkage 'return)) + (make-instruction-sequence + '(proc continue) + all-regs + '((assign val (op compiled-procedure-entry) (reg proc)) + (goto (reg val))))) + (else + #| (and (not (eq? target 'val)) (eq? linkage 'return)) |# + (error "return linkage, target not val: COMPILE" target)))) + +(define all-regs '(env proc val argl continue)) + +;; Combining Instruction Sequences + +(define (registers-needed s) + (if (symbol? s) '() (car s))) + +(define (registers-modified s) + (if (symbol? s) '() (cadr s))) + +(#%provide statements) +(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)) + (statements seq1) + `((restore ,first-reg)))) + 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)))) + +;; An Example of Compiled Code + +#| 5.33 |# +#| 5.34 |# +#| 5.35 |# +#| 5.36 |# +#| 5.37 |# +#| 5.38 |# + +;; Lexical Addressing + +#| 5.39 |# +#| 5.40 |# +#| 5.41 |# +#| 5.42 |# +#| 5.43 |# +#| 5.44 |# + +;; Interfacing Compiled Code to the Evaluator + +#| 5.45 |# +#| 5.46 |# +#| 5.47 |# +#| 5.48 |# +#| 5.49 |# +#| 5.50 |# +#| 5.51 |# +#| 5.52 |# + +; syntax procedures + +(define (self-evaluating? exp) + (cond + ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (assignment-value exp) (caddr exp)) + +(define (definition? exp) + (tagged-list? exp 'define)) + +(define (definition-variable exp) + (if (symbol? (cadr exp)) + (cadr exp) + (caadr exp))) + +(define (definition-value exp) + (if (symbol? (cadr exp)) + (caddr exp) + (make-lambda + (cdadr exp) + (cddr exp)))) + +(define (lambda? exp) (tagged-list? exp 'lambda)) + +(define (lambda-parameters exp) (cadr exp)) + +(define (lambda-body exp) (cddr exp)) + +(define (make-lambda parameters body) + (cons 'lambda (cons parameters body))) + +(define (if? exp) (tagged-list? exp 'if)) + +(define (if-predicate exp) (cadr exp)) + +(define (if-consequent exp) (caddr exp)) + +(define (if-alternative exp) + (if (not (null? (cdddr exp))) + (cadddr exp) + 'false)) + +(define (make-if predicate consequent alternative) + (list 'if predicate consequent alternative)) + +(define (begin? exp) (tagged-list? exp 'begin)) + +(define (begin-actions exp) (cdr exp)) + +(define (last-exp? seq) (null? (cdr seq))) + +(define (first-exp seq) (car seq)) + +(define (rest-exps seq) (cdr seq)) + +(define (sequence->exp seq) + (cond + ((null? seq) seq) + ((last-exp? seq) (first-exp seq)) + (else (make-begin seq)))) + +(define (make-begin seq) (cons 'begin seq)) + +(define (application? exp) (pair? exp)) + +(define (operator exp) (car exp)) + +(define (operands exp) (cdr exp)) + +(define (no-operands? ops) (null? ops)) + +(define (first-operand ops) (car ops)) + +(define (rest-operands ops) (cdr ops)) + +(define (cond? exp) (tagged-list? exp 'cond)) + +(define (cond-clauses exp) (cdr exp)) + +(define (cond-predicate clause) + (car clause)) + +(define (cond-else-clause? clause) + (eq? (cond-predicate clause) 'else)) + +(define (cond-actions clause) (cdr clause)) + +(define (cond->if exp) + (expand-clauses (cond-clauses exp))) + +(define (expand-clauses clauses) + (if (null? clauses) + 'false + (let + ((first (car clauses)) + (rest (cdr clauses))) + (if (cond-else-clause? first) + (if (null? rest) + (sequence->exp (cond-actions first)) + (error + "ELSE clause isn't last -- COND->IF" + clauses)) + (make-if + (cond-predicate first) + (sequence->exp (cond-actions first)) + (expand-clauses rest)))))) + +(define (let? exp) (tagged-list? exp 'let)) + +(define (binding-var binding) + (car binding)) + +(define (binding-exp binding) + (cadr binding)) + +(define (let-bindings exp) + (cadr exp)) + +(define (let-body exp) + (cddr exp)) + +(define (let->combination exp) + (if (null? (let-bindings exp)) + (if (null? (cdr (let-body exp))) + (car (let-body exp)) + (cons 'begin (let-body exp))) + (cons + (cons + 'lambda + (cons + (map binding-var (let-bindings exp)) + (let-body exp))) + (map binding-exp (let-bindings exp))))) |