2016/02/09
SICP 問題 5.43
内部定義を吐き出してコンパイルする.
まず4.16で作ったscan-out-definesがこれ.
(define (scan-out-defines body)
(define (split-defines proc-body defines non-defines)
(cond ((null? proc-body)
(cons (reverse defines) (reverse non-defines)))
((definition? (car proc-body))
(split-defines (cdr proc-body)
(cons (car proc-body) defines) non-defines))
(else (split-defines (cdr proc-body) defines (cons (car proc-body) non-defines)))))
(let ((splits (split-defines body '() '())))
(let ((defines (car splits))
(non-defines (cdr splits)))
(if (null? defines)
non-defines
(list (make-let (map (lambda (x) (list (definition-variable x) ''*unassigned*))
defines)
(append (map (lambda (x) (list 'set! (definition-variable x)
(definition-value x)))
defines)
non-defines)))))))
これをcompile-lambda-bodyで使う
(define (compile-lambda-body exp proc-entry ct-env)
(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))))
;; ここでscan-out-definesでlambda-bodyを変換してからcompile-sequenceに渡す
(compile-sequence (scan-out-defines (lambda-body exp)) 'val 'return (cons formals ct-env)))))
これはletに変換するのでcompileにletを追加する.
(define (compile exp target linkage ct-env)
(cond ((self-evaluating? exp)
(compile-self-evaluating exp target linkage))
((quoted? exp) (compile-quoted exp target linkage))
((variable? exp)
(compile-variable exp target linkage ct-env))
((assignment? exp)
(compile-assignment exp target linkage ct-env))
((definition? exp)
(compile-definition exp target linkage ct-env))
((if? exp) (compile-if exp target linkage ct-env))
((lambda? exp)
(compile-lambda exp target linkage ct-env))
((let? exp) ; letの追加
(compile (let->combination exp) target linkage ct-env))
((begin? exp)
(compile-sequence (begin-actions exp)
target linkage ct-env))
((cond? exp) (compile (cond->if exp) target linkage ct-env))
((open-code? exp) ;open-code?でdispatch
(compile-open-code exp target linkage ct-env))
((application? exp)
(compile-application exp target linkage ct-env))
(else
(error "Unknown expression type -- COMPILE" exp))))
test まずはscan-out-definesから.
gosh> (scan-out-defines (lambda-body '(lambda (a b)
(define x 1)
(define (y c) (+ x c))
(+ a b y))))
((let
((x '*unassigned*)
(y '*unassigned*))
(set! x 1)
(set! y (lambda (c) (+ x c)))
(+ a b y)))
期待通りに動いている.
次にcompile.
コンパイル後の命令列を追ったのでコメントをつけた.
gosh> (compile '((lambda (a b)
(define x 1)
(define (y c) (+ x c))
(+ a b (y 2))) 5 6) 'val 'next '())
((env)
(env proc argl continue val)
;; procにentry56の手続き
((assign proc (op make-compiled-procedure) (label entry56) (reg env))
(goto (label after-lambda57))
entry56
(assign env (op compiled-procedure-env) (reg proc))
;; (a b)を(5 6)に対応して拡張
(assign env (op extend-environment) (const (a b)) (reg argl) (reg env))
;; proc: entry58
(assign proc (op make-compiled-procedure) (label entry58) (reg env))
(goto (label after-lambda59))
entry58
(assign env (op compiled-procedure-env) (reg proc))
;; (x y)に(*unassigned* *unassigned*)を対応付け
(assign env (op extend-environment) (const (x y)) (reg argl) (reg env))
(assign val (const 1))
;; x のオブジェクトを1にする
(perform (op lexical-address-set!) (const (0 0)) (reg val) (const ((x y) (a b))))
(assign val (const ok))
;; val: entry60
(assign val (op make-compiled-procedure) (label entry60) (reg env))
(goto (label after-lambda61))
entry60
(assign env (op compiled-procedure-env) (reg proc))
;; ((c) (6))
(assign env (op extend-environment) (const (c)) (reg argl) (reg env))
;; arg1: 1
(assign arg1 (op lexical-address-lookup) (const (1 0)) (const ((c) (x y) (a b))))
;; arg2: 2
(assign arg2 (op lexical-address-lookup) (const (0 0)) (const ((c) (x y) (a b))))
;; val: (+ 1 2) = 3
(assign val (op +) (reg arg1) (reg arg2))
(goto (reg continue))
after-lambda61
;; y <= entry60
(perform (op lexical-address-set!) (const (0 1)) (reg val) (const ((x y) (a b))))
(assign val (const ok))
(save continue) ;aftercall71
(assign arg1 (op lexical-address-lookup) (const (1 0)) (const ((x y) (a b))))
(assign arg2 (op lexical-address-lookup) (const (1 1)) (const ((x y) (a b))))
(assign arg1 (op +) (reg arg1) (reg arg2)) ;(+ a b) =>(+ 5 6) => 11
(assign proc (op lexical-address-lookup) (const (0 1)) (const ((x y) (a b))))
(assign val (const 2))
(assign argl (op list) (reg val)) ;argl: (2)
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch62))
compiled-branch63
(assign continue (label proc-return65)) ;continue: proc-return65
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
proc-return65
;; arg2: 7
(assign arg2 (reg val))
(goto (label after-call64))
primitive-branch62
(assign arg2 (op apply-primitive-procedure) (reg proc) (reg argl))
after-call64
;; val: (+ 11 3) = 14
(assin val (op +) (reg arg1) (reg arg2))
(restore continue) ;aftercall71
(goto (reg continue))
after-lambda59
(assign val (const *unassigned*))
(assign argl (op list) (reg val))
(assign val (const *unassigned*))
(assign argl (op cons) (reg val) (reg argl)) ;argl: (*unassigned* *unassigned*)
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-branch66))
compiled-branch67
(assign val (op compiled-procedure-entry) (reg proc)) ;val: entry58
(goto (reg val))
primitive-branch66
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call68
after-lambda57
(assign val (const 6)) ;val: 6
(assign argl (op list) (reg val)) ;argl: (6)
(assign val (const 5)) ;val: 5
(assign argl (op cons) (reg val) (reg argl)) ;argl: (5 6)
(test (op primitive-procedure?) (reg proc)) ;no
(branch (label primitive-branch69))
compiled-branch70
(assign continue (label after-call71)) ;continue: aftercall71
(assign val (op compiled-procedure-entry) (reg proc)) ;val: entry56
(goto (reg val))
primitive-branch69
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call71 ;val 14
))
期待通りに内部定義を吐き出してlambdaでunassignedとして受け取り,
bodyで実際の値(手続き)にset!している.