SICP 読み (347) 5.5 翻訳系
問題 5.44
と言いつつ 5.43 なんですが、昨晩の解はダウト。lexical-address-lookup なソレが出力されておりません。日曜囲碁を見つつ問題処理。
ちなみに 5.42 な解では
gosh> (compile '(lambda (x) x) 'val 'return '()) ((env continue) (val) ((assign val (op make-compiled-procedure) (label entry23) (reg env)) #0=(goto (reg continue)) entry23 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (x)) (reg argl) (reg env)) (assign val (op lexical-address-lookup) (const (0 0)) (reg env)) #0# after-lambda24)) gosh>
なんですが、昨晩な処理系だと
gosh> (compile '(lambda (x) x) 'val 'return '()) ((env continue) (val) ((assign val (op make-compiled-procedure) (label entry28) (reg env)) #0=(goto (reg continue)) entry28 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (x)) (reg argl) (reg env)) (assign val (op lookup-variable-value) (const x) (op get-global-environment)) #0# after-lambda29)) gosh>
で、確認してみたら compile-lambda-body の末端部分のナニが
(compile-sequence (scan-out-defines (lambda-body exp)) 'val 'return cenv))))
となっているのを発見。ここで cenv 拡張しないと駄目。これでは lexical address な命令は死んでも出てこない。
これで 5.43 の最終版が出来たのだろうか。
gosh> (compile '(define (length items)
(define (length-iter a count)
(if (null? a)
count
(length-iter (cdr a) (+ 1 count))))
(length-iter items 0)) 'val 'return '())
((env continue) (val)
((assign val #0=(op make-compiled-procedure) (label entry3) . #1=((reg env)))
(goto (label after-lambda4))
entry3
#2=(assign env (op compiled-procedure-env) (reg proc))
(assign env #3=(op extend-environment) (const (items)) . #4=((reg argl) (reg env)))
(assign proc #0# (label entry5) . #1#)
(goto (label after-lambda6))
entry5
#2#
(assign env #3# (const (length-iter)) . #4#)
(assign val #0# (label entry7) . #1#)
(goto (label after-lambda8))
entry7
#2#
(assign env #3# (const (a count)) . #4#)
(save continue)
(save env)
(assign proc #5=(op lookup-variable-value) (const null?) . #6=((op get-global-environment)))
(assign val #7=(op lexical-address-lookup) (const (0 0)) . #8=((reg env)))
#9=(assign argl (op list) (reg val))
#10=(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch12))
compiled-branch13
(assign continue (label after-call14))
#11=(assign val (op compiled-procedure-entry) (reg proc))
#12=(goto (reg val))
primitive-branch12
(assign val . #13=((op apply-primitive-procedure) (reg proc) (reg argl)))
after-call14
(restore env)
(restore continue)
(test (op false?) (reg val))
(branch (label false-branch10))
true-branch9
(assign val #7# (const (0 1)) . #8#)
#14=(goto (reg continue))
false-branch10
(assign proc #7# (const (1 0)) . #8#)
(save continue)
(save proc)
(save env)
(assign proc #5# (const +) . #6#)
(assign val #7# (const (0 1)) . #8#)
#9#
(assign val (const 1))
#15=(assign argl (op cons) (reg val) (reg argl))
#10#
(branch (label primitive-branch18))
compiled-branch19
(assign continue (label after-call20))
#11#
#12#
primitive-branch18
(assign val . #13#)
after-call20
#9#
(restore env)
(save argl)
(assign proc #5# (const cdr) . #6#)
(assign val #7# (const (0 0)) . #8#)
#9#
#10#
(branch (label primitive-branch15))
compiled-branch16
(assign continue (label after-call17))
#11#
#12#
primitive-branch15
(assign val . #13#)
after-call17
(restore argl)
#15#
(restore proc)
(restore continue)
#10#
(branch (label primitive-branch21))
compiled-branch22
#16=(assign val (op compiled-procedure-entry) (reg proc))
#17=(goto (reg val))
primitive-branch21
(assign val . #13#)
#14#
after-call23
after-if11
after-lambda8
(perform (op lexicall-address-set!) (const (0 0)) (reg val) (reg env))
(assign val (const ok))
(assign proc #7# (const (0 0)) . #8#)
(assign val (const 0))
#9#
(assign val #7# (const (1 0)) . #8#)
#15#
#10#
(branch (label primitive-branch24))
compiled-branch25
#16#
#17#
primitive-branch24
(assign val . #13#)
#14#
after-call26
after-lambda6
(assign val (const *unassigned*))
#9#
#10#
(branch (label primitive-branch27))
compiled-branch28
#16#
#17#
primitive-branch27
(assign val . #13#)
#14#
after-call29
after-lambda4
(perform (op define-variable!) (const length) (reg val) (reg env))
(assign val (const ok))
#14#))
gosh> 整形は略 (を
一応 5.43 の最終版とゆーコトで 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))
((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 '() '() '()))
;;;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)
(end-with-linkage linkage
(make-instruction-sequence '(env) (list target)
`((assign ,target
(op lookup-variable-value)
(const ,exp)
(reg env))))))
(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)))
(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-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 (scan-out-defines (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)次の 5.38 な機能盛り込みは別途。
