SICP
Exercise 5.31
;;; eceval での 各 register の save/restore の理由を確認すると、
;;; env ： 評価する operator/operands がリストの場合、そのリストの operator
;;; が compound procedure だと env を変更する。次の operand を評価する
;;; ために env を save/restore する。最後の operand の場合はその必要が
;;; ない。
;;; argl ： 評価する operand がリストの場合、そのリストの operands のために argl
;;; を変更する。最終的な評価された operands を保持するために argl を
;;; save/restore する。
;;; proc : 評価する operand がリストの場合、そのリストの operator に proc を
;;; 変更する。operand の評価の間、元の operator を保持するために proc を
;;; save/resotre する。
;;; となる。これから
;;;
;;; (f 'x 'y) : operator/operands にリストが含まれないので、register の
;;; save/resotre は必要ない。
;;; ((f) 'x 'y) : operator がリストだが operands の評価に env が必要ない。
;;; (quote されているので) また、operands にリストがない。
;;; 従って、register の save/restore は必要ない。
;;; (f (g 'x) y) : env は y の評価のために (g 'x) の前後で save/resotre が必要。
;;; argl は (g 'x) が最初の operand なので save/resotre は必要ない？
;;; proc の save/resotre は必要。
;;; (f (g 'x) 'y) : env の save/restore は必要ない。(quote されている)
;;; argl は (g 'x) が最初の operand なので save/resotre は必要ない？
;;; proc の save/resotre は必要。
Exercise 5.32
;;; a.
ev-application
(save continue)
(assign unev (op operands) (reg exp))
(assign exp (op operator) (reg exp))
(assign continue (label ev-appl-did-operator1))
(test (op variable?) (reg exp))
(branch (label ev-variable))
(save env)
;(assign unev (op operands) (reg exp))
(save unev)
;(assign exp (op operator) (reg exp))
(assign continue (label ev-appl-did-operator))
(goto (label eval-dispatch))
ev-appl-did-operator
(restore unev)
(restore env)
ev-appl-did-operator1
(assign argl (op empty-arglist))
(assign proc (reg val))
(test (op no-operands?) (reg unev))
(branch (label apply-dispatch))
(save proc)
;;; b. インタープリタがソースプログラムを読み込み解釈しながら実行
;;; している限りは、インタープリタの実行時間が、
;;; コンパイラがソースプログラムを読み込んで、解釈し作り出した
;;; （解釈過程を含まない）オブジェクトプログラムの実行時間より
;;; も短くなることはない。
Exercise 5.33
;;; (factorial (- n 1)) のコンパイル結果に差はないので、この部分を (F) と書く。
;;; オペランドは右から評価、 argl にリストされる。
;;; (* (F) n) では、n の評価・arglに登録後に (F) の評価を行うようコンパイルされる
;;; ため、
;;; argl : (F)の評価時に n が登録されているので save/restoreが 行われる。
;;; env : (F)の評価後に env 環境で評価するものがないので何も行われない。
;;; (* n (F)) では、(F) の評価・arglに登録後に n の評価を行うようコンパイルされる
;;; ため、
;;; argl : (F)の評価時には何も登録されていないないので何も行わない。
;;; env : (F)の評価後に n を評価するための環境を save/restore する。
;;; 実行の効率に関して差はない。
naga:~/sicp/5$ diff factorial factorial-alt
37,40c37,38
< (assign val (op lookup-variable-value) (const n) (reg env))
< (assign argl (op list) (reg val))
< (save argl)
< (assign proc (op lookup-variable-value) (const factorial) (reg env))
---
> (save env)
> (assign proc (op lookup-variable-value) (const factorial-alt) (reg env))
67c65,67
< (restore argl)
---
> (assign argl (op list) (reg val))
> (restore env)
> (assign val (op lookup-variable-value) (const n) (reg env))
82c82
< (perform (op define-variable!) (const factorial) (reg val) (reg env))
---
> (perform (op define-variable!) (const factorial-alt) (reg val) (reg env))
naga:~/sicp/5$
Exercise 5.34
;;; stack にアクセスしてる個所に注釈をつける。
;;; 再帰呼出し版は一回で３つレジスタが積まれた状態で次の呼出しが行われるが、
;;; 末尾再帰版はレジスタの積まれ具合が増えない状態で次の呼出しが行われる。
;;; 再帰呼出し版 (* (factorial (- n 1)) n) の部分
false-branch2
(assign proc (op lookup-variable-value) (const *) (reg env))
;; stack +1
(save continue)
;; stack +2
(save proc)
(assign val (op lookup-variable-value) (const n) (reg env))
(assign argl (op list) (reg val))
;; stack +3
(save argl)
(assign proc (op lookup-variable-value) (const factorial) (reg env))
;; stack +4
(save proc)
(assign proc (op lookup-variable-value) (const -) (reg env))
(assign val (const 1))
(assign argl (op list) (reg val))
(assign val (op lookup-variable-value) (const n) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch4))
compiled-branch4
(assign continue (label after-call4))
(assign val (op complied-procedure-entry) (reg proc))
(goto (reg val))
primitive-pranch4
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call4
(assign argl (op list) (reg val))
;; stack +3
(restore proc)
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch5))
compiled-branch5
(assign continue (label after-call5))
(assign val (op complied-procedure-entry) (reg proc))
;; factorial の再帰呼出し
(goto (reg val))
primitive-pranch5
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call5
;; stack +2
(restore argl)
(assign argl (op cons) (reg val) (reg argl))
;; stack +1
(restore proc)
;; stack +0
(restore continue)
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch6))
compiled-branch6
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-pranch6
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call6
after-if2
;;; 末尾再帰版 (iter (*counter product) (+ counter 1)) の部分
false-branch3
(assign proc (op lookup-variable-value) (const iter) (reg env))
;; stack +1
(save continue)
;; stack +2
(save proc)
;; stack +3
(save env)
(assign proc (op lookup-variable-value) (const +) (reg env))
(assign val (const 1))
(assign argl (op list) (reg val))
(assign val (op lookup-variable-value) (const counter) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch6))
compiled-branch6
(assign continue (label after-call6))
(assign val (op complied-procedure-entry) (reg proc))
(goto (reg val))
primitive-pranch6
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call6
(assign argl (op list) (reg val))
;; stack +2
(restore env)
;; stack +3
(save argl)
(assign proc (op lookup-variable-value) (const *) (reg env))
(assign val (op lookup-variable-value) (const product) (reg env))
(assign argl (op list) (reg val))
(assign val (op lookup-variable-value) (const counter) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch5))
compiled-branch5
(assign continue (label after-call5))
(assign val (op complied-procedure-entry) (reg proc))
(goto (reg val))
primitive-pranch5
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call5
;; stack +2
(restore argl)
(assign argl (op cons) (reg val) (reg argl))
;; stack +1
(restore proc)
;; stack +0
(restore continue)
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch7))
compiled-branch7
(assign val (op compiled-procedure-entry) (reg proc))
;; iterの末尾再帰呼出し
(goto (reg val))
primitive-pranch7
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call7
after-if3
Exercise 5.35
(define (f x)
(+ x (g (+ x 2))))
Exercise 5.36
;;; 右→左 construct-arglist で評価順を決めている。
;;; 左→右にするには construct-arglist、code-to-get-rest-args を変更する。
;;; コンパイル結果が１命令増える。
(define (construct-arglist operand-codes)
;; opeand-codes の reverse を止める。
;;(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))
(preserving
'()
code-for-next-arg
;; 最後の operand を評価し argl に cons した後に
;; argl を reverse する実行命令を追加
(make-instruction-sequence
'(argl)
'(argl)
'((assign argl (op reverse) (reg argl)))))
(preserving
'(env)
code-for-next-arg
(code-to-get-rest-args (cdr operand-codes))))))
;;右→左
;;gosh> (Compile '(f 'x 'y) 'val 'next)
;;registers-needed : (env)
;;registers-modified : (env proc argl continue val)
;;object-codes
;; (assign proc (op lookup-variable-value) (const f) (reg env))
;; (assign val (const y))
;; (assign argl (op list) (reg val))
;; (assign val (const x))
;; (assign argl (op cons) (reg val) (reg argl))
;; (test (op primitive-procedure?) (reg proc))
;; (branch (label primitive-pranch1))
;;compiled-branch1
;; (assign continue (label after-call1))
;; (assign val (op complied-procedure-entry) (reg proc))
;; (goto (reg val))
;;primitive-pranch1
;; (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
;;after-call1
;;
;;左→右
;;gosh> (Compile '(f 'x 'y) 'val 'next)
;;registers-needed : (env)
;;registers-modified : (env proc argl continue val)
;;object-codes
;; (assign proc (op lookup-variable-value) (const f) (reg env))
;; (assign val (const x))
;; (assign argl (op list) (reg val))
;; (assign val (const y))
;; (assign argl (op cons) (reg val) (reg argl))
;; (assign argl (op reverse) (reg argl))
;; (test (op primitive-procedure?) (reg proc))
;; (branch (label primitive-pranch1))
;;compiled-branch1
;; (assign continue (label after-call1))
;; (assign val (op complied-procedure-entry) (reg proc))
;; (goto (reg val))
;;primitive-pranch1
;; (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
;;after-call1
Exercise 5.37
;;; preserving をseq2で必要であれば、seq1で変更されていなくても
;;; save/restore ように変更
(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)))))
;;; オリジナル版
gosh> (Compile '(f 'x 'y) 'target 'next)
registers-needed : (env)
registers-modified : (env proc val argl continue target)
object-codes :
(assign proc (op lookup-variable-value) (const f) (reg env))
(assign val (const y))
(assign argl (op list) (reg val))
(assign val (const x))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch1))
compiled-branch1
(assign continue (label proc-return2))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
proc-return2
(assign target (reg val))
(goto (label after-call1))
primitive-pranch1
(assign target (op apply-primitive-procedure) (reg proc) (reg argl))
after-call1
;;; preserving 修正版
gosh> (Compile '(f 'x 'y) 'target 'next)
registers-needed : (env)
registers-modified : (env proc val argl continue target)
object-codes :
(assign proc (op lookup-variable-value) (const f) (reg env))
(save proc)
(assign val (const y))
(assign argl (op list) (reg val))
(save argl)
(assign val (const x))
(restore argl)
(assign argl (op cons) (reg val) (reg argl))
(restore proc)
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch1))
compiled-branch1
(assign continue (label proc-return2))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
proc-return2
(assign target (reg val))
(goto (label after-call1))
primitive-pranch1
(assign target (op apply-primitive-procedure) (reg proc) (reg argl))
after-call1
Exercise 5.38
;;; a & d
(define (spread-argument exp seq)
(let ((operator (cond ((eq? (car exp) 'oc-) 'oc+)
((eq? (car exp) 'oc/) 'oc*)
(else (car exp))))
(operands (cdr exp)))
(let ((seq1 (compile (car operands) 'arg1 'next))
(seq2 (if (= (length exp) 3)
(compile (cadr operands) 'arg2 'next)
(compile (cons operator (cdr operands)) 'arg2 'next))))
(preserving
'(env)
seq1
(preserving
'(arg1)
seq2
seq)))))
;;; b
;; compile に追加
((oca? exp) (compile-oca exp target linkage))
((ocl? exp) (compile-ocl exp target linkage))
;; compile-oca & compile-ocl
(define (compile-oca exp target linkage)
(let ((oplen (- (length exp) 1)))
(cond ((< oplen 2) (error "Too less operand : COMPILE-OCA" exp))
(else
(end-with-linkage
linkage
(spread-argument
exp
(make-instruction-sequence
'(arg1 arg2)
'( , target)
`((assign , target (op , (car exp)) (reg arg1) (reg arg2))))))))))
(define (compile-ocl exp target linkage)
(let ((oplen (- (length exp) 1)))
(cond ((not (= oplen 2)) (error "Must be 2 operands -- COMPILE-OCL :" exp))
(else
(end-with-linkage
linkage
(spread-argument
exp
(make-instruction-sequence
'(arg1 arg2)
'( , target)
`((assign , target (op , (car exp)) (reg arg1) (reg arg2))))))))))
;; eceval-operations に追加
(list 'oc+ oc+)
(list 'oc- oc-)
(list 'oc* oc*)
(list 'oc= oc=)
;; open-code primitives 定義
(define (oc+ a b) (+ a b))
(define (oc- a b) (- a b))
(define (oc* a b) (* a b))
(define (oc= a b) (= a b))
;;; c
gosh> (Compile
'(define (factorial-oc n)
(if (oc= n 1)
1
(oc* (factorial-oc (oc- n 1)) n))) 'val 'next)
registers-needed : (env)
registers-modified : (val)
object-codes :
(assign val (op make-compiled-procedure) (label entry6) (reg env))
(goto (label after-lambda6))
entry6
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (n)) (reg argl) (reg env))
(assign arg1 (op lookup-variable-value) (const n) (reg env))
(assign arg2 (const 1))
(assign val (op oc=) (reg arg1) (reg arg2))
(test (op false?) (reg val))
(branch (label false-branch7))
true-branch7
(assign val (const 1))
(goto (reg continue))
false-branch7
(save continue)
(save env)
(assign proc (op lookup-variable-value) (const factorial-oc) (reg env))
(assign arg1 (op lookup-variable-value) (const n) (reg env))
(assign arg2 (const 1))
(assign val (op oc-) (reg arg1) (reg arg2))
(assign argl (op list) (reg val))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch8))
(test (op compound-procedure?) (reg proc))
(branch (label compound-branch8))
compiled-branch8
(assign continue (label proc-return9))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
proc-return9
(assign arg1 (reg val))
(goto (label after-call8))
compound-branch8
(assign continue (label proc-return10))
(save continue)
(goto (reg compapp))
proc-return10
(assign arg1 (reg val))
(goto (label after-call8))
primitive-pranch8
(assign arg1 (op apply-primitive-procedure) (reg proc) (reg argl))
after-call8
(restore env)
(assign arg2 (op lookup-variable-value) (const n) (reg env))
(assign val (op oc*) (reg arg1) (reg arg2))
(restore continue)
(goto (reg continue))
after-if7
after-lambda6
(perform (op define-variable!) (const factorial-oc) (reg val) (reg env))
(assign val (const ok))
;;gosh> (compile-and-go
;; '(define (factorial-oc n)
;; (if (oc= n 1)
;; 1
;; (oc* (factorial-oc (oc- n 1)) n))))
;;(total-pushes = 0 maximum-depth = 0)
;;;;; EC-Eval value:
;;ok
;;;;; EC-Eval input:
;;(factorial-oc 5)
;;(total-pushes = 11 maximum-depth = 8)
;;;;; EC-Eval value:
;;120
;;gosh> (Compile '(oc+ 1 2 3) 'val 'next)
;;registers-needed : ()
;;registers-modified : (arg1 arg2 ,target)
;;object-codes :
;; (assign arg1 (const 1))
;; (save arg1)
;; (assign arg1 (const 2))
;; (assign arg2 (const 3))
;; (assign arg2 (op oc+) (reg arg1) (reg arg2))
;; (restore arg1)
;; (assign val (op oc+) (reg arg1) (reg arg2))
Exercise 5.39
(define (frame-values frame) (cdr frame))
(define (frame-number lex-addr) (car lex-addr))
(define (displacement-number lex-addr) (cdr lex-addr))
(define (lex-addr frame-number displacement-number)
(cons frame-number displacement-number))
(define (lexical-address-lookup lex-addr env)
(let ((frame (list-ref env (frame-number lex-addr))))
(let ((val (list-ref (frame-values frame) (displacement-number lex-addr))))
(if (eq? val '*unassigned*)
(Errorsignal "Unassignd varable" var)
val))))
(define (lexcal-address-set! lex-addr val env)
(let ((frame (list-ref env (frame-number lex-addr))))
(let loop ((vals (frame-values frame))
(dis (displacement-number lex-addr)))
(if (= dis 0)
(set-car! vals val)
(loop (cdr vals) (- dis 1))))))
(define env
(list (cons '(a b) '(1 2)) ;;a->(0 . 0), b->(0 . 1)
(cons '(c d) '(3 4)))) ;;c->(1 . 0), d->(1 . 1)
;;gosh> env
;;(((a b) 1 2) ((c d) 3 4))
;;gosh> (lexical-address-lookup '(0 . 1) env)
;;2
;;gosh> (lexical-address-lookup '(1 . 1) env)
;;4
;;gosh> (lexcal-address-set! '(0 . 0) 5 env)
;;#<undef>
;;gosh> (lexcal-address-set! '(1 . 1) 6 env)
;;#<undef>
;;gosh> env
;;(((a b) 5 2) ((c d) 3 6))
Exercise 5.40
;;; compile-time-environment を使用する各 compile 手続きの名前の先頭に L を追加
(define (Lcompile exp target linkage ct-env)
(cond ((self-evaluating? exp) (compile-self-evaluating exp target linkage))
((quoted? exp) (compile-quoted exp target linkage))
((variable? exp) (Lcompile-variable exp target linkage ct-env))
((assignment? exp) (Lcompile-assignment exp target linkage ct-env))
((definition? exp) (Lcompile-definition exp target linkage ct-env))
((if? exp) (Lcompile-if exp target linkage ct-env))
((lambda? exp) (Lcompile-lambda exp target linkage ct-env))
((begin? exp) (Lcompile-sequence (begin-action exp)
target
linkage
ct-env))
((cond? exp) (Lcompile (cond->if exp) target linkage ct-env))
((oca? exp) (compile-oca exp target linkage))
((ocl? exp) (compile-ocl exp target linkage))
((application? exp) (Lcompile-application exp target linkage ct-env))
(else (error "Unknown expression type -- COMPILE" exp))))
;;; compile-time-environment を拡張して、その環境で lambda-body をコンパイル
(define (Lcompile-lambda-body exp proc-entry ct-env)
(let ((formals (lambda-parameters exp)))
(let ((extended-ct-env (cons formals ct-env)))
(append-instruction-sequences
(make-instruction-sequence
'(env proc argl)
'(enc)
`( , proc-entry
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment)
(const , formals) (reg argl) (reg env))))
(Lcompile-sequence (lambda-body exp) 'val 'return extended-ct-env)))))
;;;
(define (Lcompile-if exp target linkage ct-env)
(let* ((labels (make-labels 'true-branch 'false-branch 'after-if))
(t-branch (list-ref labels 0))
(f-branch (list-ref labels 1))
(after-if (list-ref labels 2)))
(let ((consequent-linkage
(if (eq? linkage 'next) after-if linkage)))
(let ((p-code (Lcompile (if-predicate exp) 'val 'next ct-env))
(c-code (Lcompile (if-consequent exp) target consequent-linkage ct-env))
(a-code (Lcompile (if-alternative exp) target linkage ct-env)))
(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 (Lcompile-sequence seq target linkage ct-env)
(if (last-exp? seq)
(Lcompile (first-exp seq) target linkage ct-env)
(preserving
'(env continue)
(Lcompile (first-exp seq) target 'next ct-env)
(Lcompile-sequence (rest-exps seq) target linkage ct-env))))
(define (Lcompile-lambda exp target linkage ct-env)
(let* ((labels (make-labels 'entry 'after-lambda))
(proc-entry (list-ref labels 0))
(after-lambda (list-ref labels 1)))
(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)))))
(Lcompile-lambda-body exp proc-entry ct-env))
after-lambda))))
(define (Lcompile-lambda-body exp proc-entry ct-env)
(let ((formals (lambda-parameters exp)))
(let ((extended-ct-env (cons formals ct-env)))
(append-instruction-sequences
(make-instruction-sequence
'(env proc argl)
'(enc)
`( , proc-entry
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment)
(const , formals) (reg argl) (reg env))))
(Lcompile-sequence (lambda-body exp) 'val 'return extended-ct-env)))))
(define (Lcompile-application exp target linkage ct-env)
(let ((proc-code (Lcompile (operator exp) 'proc 'next ct-env))
(operand-codes
(map (lambda (operand) (Lcompile operand 'val 'next ct-env))
(operands exp))))
(preserving
'(env continue)
proc-code
(preserving
'(proc continue)
(construct-arglist operand-codes)
(compile-procedure-call target linkage)))))
Exercise 5.41
;;; find-variable
(define (find-variable var ct-env)
(let floop ((frame-num 0)
(frames ct-env))
(if (pair? frames)
(let dloop ((displacement-num 0)
(frame (car frames)))
(if (pair? frame)
(if (eq? (car frame) var)
(lex-addr frame-num displacement-num)
(dloop (+ displacement-num 1) (cdr frame)))
(floop (+ frame-num 1) (cdr frames))))
'not-found)))
;;gosh> (find-variable 'c '((y z) (a b c d e) (x y)))
;;(1 2)
;;gosh> (find-variable 'x '((y z) (a b c d e) (x y)))
;;(2 0)
;;gosh> (find-variable 'w '((y z) (a b c d e) (x y)))
;;not-found
Exercise 5.42
;;; compile-variable
(define (Lcompile-variable exp target linkage ct-env)
(let ((lex-addr (find-variable exp ct-env)))
(end-with-linkage
linkage
(if (eq? lex-addr 'not-found)
(make-instruction-sequence
'()
(list target 'env)
`((assign env (op get-global-environment))
(assign , target (op lookup-variable-value) (cont , exp) (reg env))))
(make-instruction-sequence
'(env)
(list target)
`((assign , target (op lexcal-address-lookup) (const , lex-addr) (reg env))))))))
;;; compile-assignment
(define (Lcompile-assignment exp target linkage ct-env)
(let ((var (assignment-variable exp))
(get-value-code (Lcompile (assignment-value exp) 'val 'next ct-env)))
(let ((lex-addr (find-variable var ct-env)))
(end-with-linkage
linkage
(preserving '(env)
get-value-code
(if (eq? lex-addr 'not-found)
(make-instruction-sequence
'(val)
(list target 'env)
'((assign env (op get-global-environment))
(perform (op set-variable-value!)
(const , var) (reg val) (reg env))
(assign , target (const ok))))
(make-instruction-sequence
'(env val)
(list target)
`((perform (op lexcal-address-set!)
(const , lex-addr) (reg val) (reg env))
(assign , target (const ok))))))))))
Exercise 5.43
;;; let を special forms に追加
((let? exp) (Lcompile (let->combination exp) target linkage ct-env)
;;; scan-out-definiton (内部定義->let & set!, ex4.16で作成) の追加
(define (make-set! var val)
(list 'set! var val))
(define (scan-out-defines body)
(define (iter body bindings set!s so-body)
(if (null? body)
(if (null? bindings)
so-body
(list (make-let (reverse bindings) (append (reverse set!s) so-body))))
(let ((exp (car body)))
(cond ((and (definition? exp) (null? so-body))
(iter (cdr body)
(cons (list (definition-variable exp) '*unassigned*) bindings)
(cons (make-set! (definition-variable exp)
(definition-value exp)) set!s)
so-body))
((definition? exp)
(error "Definitions must be first of body" exp))
(else
(iter (cdr body) bindings set!s (if (null? so-body) body so-body)))
))))
(iter body '() '() '()))
;;; compile-definition に scan-out-defines を入れ込む。
(define (Lcompile-definition exp target linkage ct-env)
(let ((var (definition-variable exp))
(get-value-code (Lcompile (scan-out-defines (definition-value exp))
'val 'next ct-env)))
(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))))))))
;;; 実行結果
gosh> (LCompile
'(define lt
(let ((x 3) (y 4))
(lambda (a b c d e)
(let ((y (* a b x))
(z (+ c d x)))
(* x y z))))) 'traget 'next)
registers-needed : (env)
registers-modified : (proc argl continue val traget)
object-codes :
(save env)
(assign proc (op make-compiled-procedure) (label entry1) (reg env))
(goto (label after-lambda1))
entry1
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (x y)) (reg argl) (reg env))
(assign val (op make-compiled-procedure) (label entry2) (reg env))
(goto (reg continue))
entry2
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (a b c d e)) (reg argl) (reg env))
(assign proc (op make-compiled-procedure) (label entry3) (reg env))
(goto (label after-lambda3))
entry3
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (y z)) (reg argl) (reg env))
(save env)
(assign env (op get-global-environment))
(assign proc (op lookup-variable-value) (const *) (reg env))
(restore env)
(assign val (op lexical-address-lookup) (const (0 . 1)) (reg env))
(assign argl (op list) (reg val))
(assign val (op lexical-address-lookup) (const (0 . 0)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(assign val (op lexical-address-lookup) (const (2 . 0)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch4))
compiled-branch4
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-pranch4
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call4
after-lambda3
(save continue)
(save proc)
(save env)
(save env)
(assign env (op get-global-environment))
(assign proc (op lookup-variable-value) (const +) (reg env))
(restore env)
(assign val (op lexical-address-lookup) (const (1 . 0)) (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))
(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-pranch6))
compiled-branch6
(assign continue (label after-call6))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-pranch6
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call6
(assign argl (op list) (reg val))
(restore env)
(save argl)
(save env)
(assign env (op get-global-environment))
(assign proc (op lookup-variable-value) (const *) (reg env))
(restore env)
(assign val (op lexical-address-lookup) (const (1 . 0)) (reg env))
(assign argl (op list) (reg val))
(assign val (op lexical-address-lookup) (const (0 . 1)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(assign val (op lexical-address-lookup) (const (0 . 0)) (reg env))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch5))
compiled-branch5
(assign continue (label after-call5))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-pranch5
(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-pranch7))
compiled-branch7
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-pranch7
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
(goto (reg continue))
after-call7
after-lambda2
after-lambda1
(assign val (const 4))
(assign argl (op list) (reg val))
(assign val (const 3))
(assign argl (op cons) (reg val) (reg argl))
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-pranch8))
compiled-branch8
(assign continue (label after-call8))
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-pranch8
(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call8
(restore env)
(perform (op define-variable!) (const lt) (reg val) (reg env))
(assign traget (const ok))
最終更新：2009年09月23日 20:19
