SICP 読み (348) 5.5 翻訳系
カゼ引いた。どこまでイケるか分かりませんが、ヤッてみます。
問題 5.44
とりあえず問題 5.38 なディレクトリをコピーして (347) なソレを盛り込めばなんとかなるはず。
で、色々コケながら盛り込み終了。問題で例示されている式を吸わせてみた結果が以下。一応整形しときます。
gosh> (compile '(lambda (+ * a b x y) (+ (* a x) (* b y))) 'val 'return '()) ((env continue) (val) ((assign val (op make-compiled-procedure) (label entry1) (reg env)) (goto (reg continue)) entry1 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (+ * a b x y)) (reg argl) (reg env)) (assign arg1 (op lexical-address-lookup) (const (0 2)) (reg env)) (assign arg2 (op lexical-address-lookup) (const (0 4)) (reg env)) (assign arg1 (op *) (reg arg1) (reg arg2)) (save arg1) (assign arg1 (op lexical-address-lookup) (const (0 3)) (reg env)) (assign arg2 (op lexical-address-lookup) (const (0 5)) (reg env)) (assign arg2 (op *) (reg arg1) (reg arg2)) (restore arg1) (assign val (op +) (reg arg1) (reg arg2)) after-lambda2)) gosh>
あら、駄目ぢゃん。何故だ、と言いつつソースを睨む。とほほほ。compile ですか。
((let? exp) (compile (let->combination exp) target linkage cenv)) ((eq? '+ (car exp)) (compile-plus exp target linkage cenv)) ((eq? '* (car exp)) (compile-mul exp target linkage cenv)) ((eq? '= (car exp)) (compile-equal exp target linkage cenv)) ((eq? '- (car exp)) (compile-minus exp target linkage cenv)) ((application? exp) (compile-application exp target linkage cenv))
これ、どうすりゃ良いのやら。compile-application で横取りするのかな。
- (operator exp) なソレが翻訳時環境にあれば lexical-address-lookup
- + * - = なら手続き吐いて終わる
- それ以外は普通に lookup する
って簡単に書いてますがムズい。とりあえず書いてみる。
(define (open-code-dispatch exp target linkage cenv) (cond ((eq? '+ (operator exp)) (compile-plus exp target linkage cenv)) ((eq? '* (operator exp)) (compile-mul exp target linkage cenv)) ((eq? '= (operator exp)) (compile-equal exp target linkage cenv)) ((eq? '- (operator exp)) (compile-minus exp target linkage cenv)))) (define (compile-application exp target linkage cenv) (let ((proc-code (find-variable (operator exp) cenv))) (if (and (eq? 'not-found proc-code) (or (eq? '+ (operator exp)) (eq? '* (operator exp)) (eq? '= (operator exp)) (eq? '- (operator exp)))) (open-code-dispatch exp target linkage cenv) (let ((if (eq? 'not-found proc-code) (proc-code (compile (operator exp) 'proc 'next cenv))) (operand-codes (map (lambda (operand) (compile operand 'val 'next cenv)) (operands exp)))) (preserving '(env continue) proc-code (preserving '(proc continue) (construct-arglist operand-codes) (compile-procedure-call target linkage)))))))
駄目。よく考えたら compile で横取りされたものを再度戻す方法にすれば良いのかな。こんな感じ。
(define (compile-plus exp target linkage cenv) (if (eq? 'not-found (find-variable (operator exp) cenv)) (let ((arg (spread-arguments (operands exp) cenv))) (preserving '(continue) arg (make-instruction-sequence '(arg1 arg2) '(val) `((assign ,target (op +) (reg arg1) (reg arg2)))))) (compile-application exp target linkage cenv)))
出力確認。そろそろ遅い時間。限界近い。整形済みのソレが以下。
gosh> (compile '(lambda (+ * a b x y) (+ (* a x) (* b y))) 'val 'return '()) ((env continue) (val) ((assign val (op make-compiled-procedure) (label entry1) (reg env)) (goto (reg continue)) entry1 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (+ * a b x y)) (reg argl) (reg env)) (assign proc (op lexical-address-lookup) (const (0 0)) (reg env)) (save continue) (save proc) (save env) (assign proc (op lexical-address-lookup) (const (0 1)) (reg env)) (assign val (op lexical-address-lookup) (const (0 5)) (reg env)) (assign argl (op list) (reg val)) (assign val (op lexical-address-lookup) (const (0 3)) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch6)) compiled-branch7 (assign continue (label after-call8)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch6 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call8 (assign argl (op list) (reg val)) (restore env) (save argl) (assign proc (op lexical-address-lookup) (const (0 1)) (reg env)) (assign val (op lexical-address-lookup) (const (0 4)) (reg env)) (assign argl (op list) (reg val)) (assign val (op lexical-address-lookup) (const (0 2)) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch3)) compiled-branch4 (assign continue (label after-call5)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch3 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call5 (restore argl) (assign argl (op cons) (reg val) (reg argl)) (restore proc) (restore continue) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch9)) compiled-branch10 (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch9 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (goto (reg continue)) after-call11 after-lambda2)) gosh>
良さげに見える。とりあえず調子悪いので寝ます。
追記
以下に ch5-compiler.scm を貼っておく。(自分メモ
;;;;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 "ch5-syntax.scm") ;section 4.1.2 syntax procedures (define (scan-out-defines exp) (define (make-set init set exp) (if (null? exp) (if (null? init) '() (append (list 'let init) set)) (if (definition? (car exp)) (make-set (append init (list (list (definition-variable (car exp)) ''*unassigned*))) (append set (list (list 'set! (definition-variable (car exp)) (definition-value (car exp))))) (cdr exp)) (make-set init set (cdr exp))))) (define (remove-define l exp) (cond ((null? exp) l) ((definition? (car exp)) (remove-define l (cdr exp))) (else (remove-define (append l (list (car exp))) (cdr exp))))) (let ((result (make-set '() '() exp))) (if (null? result) exp (list (append result (remove-define '() exp)))))) ;;;SECTION 5.5.1 (define (lexical-address-lookup add env) (let ((result (list-ref (cdr (list-ref env (car add))) (cadr add)))) (if (eq? '*unassigned* result) (error "variable is unassigned -- " result) result))) (define (lexical-address-set! add val env) (define (scan n l) (if (= n 0) (set-car! l val) (scan (- n 1) (cdr l)))) (scan (cadr add) (cdr (list-ref env (car add))))) (define (find-variable var env) (define (f-search i env) (define (lexical-add-out j l) (cond ((null? l) (f-search (+ i 1) (cdr env))) ((eq? var (car l)) (list i j)) (else (lexical-add-out (+ j 1) (cdr l))))) (if (null? env) 'not-found (lexical-add-out 0 (car env)))) (f-search 0 env)) (define (compile exp target linkage cenv) (cond ((self-evaluating? exp) (compile-self-evaluating exp target linkage)) ((quoted? exp) (compile-quoted exp target linkage)) ((variable? exp) (compile-variable exp target linkage cenv)) ((assignment? exp) (compile-assignment exp target linkage cenv)) ((definition? exp) (compile-definition exp target linkage cenv)) ((if? exp) (compile-if exp target linkage cenv)) ((lambda? exp) (compile-lambda exp target linkage cenv)) ((begin? exp) (compile-sequence (begin-actions exp) target linkage cenv)) ((cond? exp) (compile (cond->if exp) target linkage cenv)) ((let? exp) (compile (let->combination exp) target linkage cenv)) ((eq? '+ (car exp)) (compile-plus exp target linkage cenv)) ((eq? '* (car exp)) (compile-mul exp target linkage cenv)) ((eq? '= (car exp)) (compile-equal exp target linkage cenv)) ((eq? '- (car exp)) (compile-minus exp target linkage cenv)) ((application? exp) (compile-application exp target linkage cenv)) (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.38 (define (compile-plus exp target linkage cenv) (if (eq? 'not-found (find-variable (operator exp) cenv)) (let ((arg (spread-arguments (operands exp) cenv))) (preserving '(continue) arg (make-instruction-sequence '(arg1 arg2) '(val) `((assign ,target (op +) (reg arg1) (reg arg2)))))) (compile-application exp target linkage cenv))) (define (compile-minus exp target linkage cenv) (if (eq? 'not-found (find-variable (operator exp) cenv)) (let ((arg (spread-arguments (operands exp) cenv))) (preserving '(continue) arg (make-instruction-sequence '(arg1 arg2) '(val) `((assign ,target (op -) (reg arg1) (reg arg2)))))) (compile-application exp target linkage cenv))) (define (compile-mul exp target linkage cenv) (if (eq? 'not-found (find-variable (operator exp) cenv)) (let ((arg (spread-arguments (operands exp) cenv))) (preserving '(continue) arg (make-instruction-sequence '(arg1 arg2) '(val) `((assign ,target (op *) (reg arg1) (reg arg2)))))) (compile-application exp target linkage cenv))) (define (compile-equal exp target linkage cenv) (if (eq? 'not-found (find-variable (operator exp) cenv)) (let ((arg (spread-arguments (operands exp) cenv))) (preserving '(continue) arg (make-instruction-sequence '(arg1 arg2) '(val) `((assign ,target (op =) (reg arg1) (reg arg2)))))) (compile-application exp target linkage cenv))) (define (spread-arguments arglist cenv) (let ((seq1 (compile (car arglist) 'arg1 'next cenv)) (seq2 (compile (cadr arglist) 'arg2 'next cenv))) (append-instruction-sequences seq1 (if (modifies-register? seq2 'arg1) (make-instruction-sequence (registers-needed seq2) (registers-modified seq2) (append '((save arg1)) (statements seq2) '((restore arg1)))) seq2)))) ;;;SECTION 5.5.2 ;;;linkage code (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))) ;;;simple expressions (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 cenv) (let ((lexical-add (find-variable exp cenv))) (end-with-linkage linkage (make-instruction-sequence '(env) (list target) (if (eq? 'not-found lexical-add) `((assign ,target (op lookup-variable-value) (const ,exp) (op get-global-environment))) `((assign ,target (op lexical-address-lookup) (const ,lexical-add) (reg env)))))))) (define (compile-assignment exp target linkage cenv) (let ((var (assignment-variable exp)) (get-value-code (compile (assignment-value exp) 'val 'next cenv))) (let ((lexical-add (find-variable var cenv))) (end-with-linkage linkage (preserving '(env) get-value-code (make-instruction-sequence '(env val) (list target) (if (eq? 'not-found lexical-add) `((perform (op set-variable-value!) (const ,var) (reg val) (reg env)) (assign ,target (const ok))) `((perform (op lexicall-address-set!) (const ,lexical-add) (reg val) (reg env)) (assign ,target (const ok)))))))))) (define (compile-definition exp target linkage cenv) (let ((var (definition-variable exp)) (get-value-code (compile (definition-value exp) 'val 'next cenv))) (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)))))))) ;;;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 cenv) (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 cenv)) (c-code (compile (if-consequent exp) target consequent-linkage cenv)) (a-code (compile (if-alternative exp) target linkage cenv))) (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)))))) ;;; sequences (define (compile-sequence seq target linkage cenv) (if (last-exp? seq) (compile (first-exp seq) target linkage cenv) (preserving '(env continue) (compile (first-exp seq) target 'next cenv) (compile-sequence (rest-exps seq) target linkage cenv)))) ;;;lambda expressions (define (compile-lambda exp target linkage cenv) (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 cenv)) after-lambda)))) (define (compile-lambda-body exp proc-entry cenv) (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 (cons formals cenv))))) ;;;SECTION 5.5.3 ;;;combinations (define (compile-application exp target linkage cenv) (let ((proc-code (compile (operator exp) 'proc 'next cenv)) (operand-codes (map (lambda (operand) (compile operand 'val 'next cenv)) (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)))))) ;;;applying procedures (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)))) ;;;applying compiled procedures (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))))) ((and (not (eq? target 'val)) (eq? linkage 'return)) (error "return linkage, target not val -- COMPILE" target)))) ;; footnote (define all-regs '(env proc val argl continue)) ;;;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)) (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)))) '(COMPILER LOADED)