SICP 読書ノート#77 - 5.5 翻訳系(2) (pp.343-360)
前回に続き翻訳系のセクションを読み進めて行きました。
5.5.2 式の翻訳
defineやset!などの特殊形式のコンパイルの話。ざっと読んだ。
5.5.3 組み合わせの翻訳
主に手続き適用のコンパイルの話。簡単にまとめると、
compile-applicationでは、演算子と非演算子がそれぞれコンパイルされ、compile-procedure-callを呼び出すcompile-procedure-callでは、targetに返り値を格納し、 実行後はlinkageに戻る、手続き適用の実行コードが生成される- 手続き適用の実行コード生成の処理の本体である
complie-proc-applでは、targetがvalか否か、linkageがreturnか否か、で 4通りのコードのいずれかを生成する
個人的には、超循環評価機でもそうだったが、非演算子が評価・集約され
演算子手続きに適用される振る舞いを見ると、JavaScriptの
arguments[]やarguments.calleeはきっとこれなんだろうなあと、
勝手に腑に落ちました。
5.5.4 命令列の組み合わせ
命令シーケンスのコンパイルの話。
要は、append-instruction-sequencesなどで命令シーケンスを連結し、
preservingで余分なスタック退避を取り除いている、ということだと思うが、
処理の細かい点まで理解しようとすると結構むずかしい。
ただ、これらの手続きの出力結果としてどういうコードを生成するかが より重要だと思うので、細部は置いといて先へ進みます。
それと、脚注に結構おもしろいことが書いてあった。 訳文を非公式SICP(真鍋版)より引用。
コンパイラに末尾再帰のコードを生成させるというのは 素直な考え方のように思えるかもしれません。 しかし、C言語やPascalを含め、一般的な言語ではこれを行わず、 そのためこれらの言語では反復プロセスを手続き呼ひ出しだけで表現することはできません。 これらの言語で末尾再帰が難しいのは、それらの実装では スタックをリターンアドレスを格納するのに使うだけでなく、 手続きの引数や局所変数を格納するためにも使っているからです。 この本で記述されているSchemeの実装は、 引数と変数をメモリに入れ、ガベージコレクションの対象にしています。 変数と引数にスタックを使う理由は、 ほかのところでガベージコレクションを使わない言語では、 そうすることによってガベージコレクションが必要なくなり、 またそれがより効率的たと一般に信じられているということです。 実際のところ、高機能なLispコンパイラは、末尾再帰を壊さずに 引数のためにスタックを使うことかてきます。 (snip..) また、そもそもスタック割り当てはガベージコレクションより効率的なのか というところにも議論がありますが、この問題の詳細はコンピュータアーキテクチャの 細部によるようです (snip..)
こうやって処理系を内部を追っていくと、 末尾再帰やガベージコレクションを持つ・持たないの戦略の違いがわかってとても良い。
5.5.5 翻訳したコードの例
compileでSchemeのソースコードをコンパイルすると、
どういったオブジェクトコードが生成されるか、という話。
前に問題5.31、5.32で試してきたような内容。
問題 5.37
preservingで行っている不要なスタックの退避・復元を取り除くと、
生成するコードはどう変化し、不要なスタック演算は何かを特定せよ、という問題。
preservingから不要なスタック演算を省く処理を削除する。
(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)))))
+ seq2))))
問題 5.31の(f (g 'x) y)をコンパイルしてみる。
'((env continue) (env proc argl continue val) ((save continue) (save env) (save continue) (assign proc (op lookup-variable-value) (const f) (reg env)) (restore continue) (restore env) (restore continue) (save continue) (save proc) (save env) (save continue) (assign val (op lookup-variable-value) (const y) (reg env)) (restore continue) (assign argl (op list) (reg val)) (restore env) (save argl) (save continue) (save env) (save continue) (assign proc (op lookup-variable-value) (const g) (reg env)) (restore continue) (restore env) (restore continue) (save continue) (save proc) (save continue) (assign val (const x)) (restore continue) (assign argl (op list) (reg val)) (restore proc) (restore continue) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch1)) compiled-branch2 (assign continue (label after-call3)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch1 (save continue) (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (restore continue) ;; snip...
おお！ 元々のpreservingでは一切出なかったenvへのスタックの退避・復元が、
envから変数を探索する度に実行されることがわかる。
問題 5.31でenvの退避・復元が出なかった理由の予想はどうやら当たっていたみたい。
次は「5.5.6 文面アドレス」から。
SICP 読書ノート#76 - 5.5 翻訳系(1) (pp.339-343)
いよいよ最後のセクション。
これまでレジスタマシン、積極制御評価機(解釈系=インタプリタ)と来て、 ここでは翻訳系(=コンパイラ)について学びます。
翻訳系の概観
ひとことで言うと「環境をenvに保持し、引数リストをarglに集積し、
適用する手続きをprocに、手続きが戻る場所をcontinueに入れ、
手続き適用の評価結果をvalに入れて戻る」機械語のオブジェクトプログラムを作ること。
積極制御評価機は式の中でレジスタ命令にぶつかるとすぐに評価するのに対し、 翻訳系はそれをシーケンスに集積しオブジェクトコードへ変換していく。
これは積極制御評価機が§4.1.1〜4.1.3の超循環評価機がに似ていたのに対し、 翻訳系は§4.1.7のソースプログラムを解釈して実行手続きを生成する評価機に似ている。
まさか§4.1がここに至る伏線だったとは。SICPやっぱすごいわ。
5.5.1 翻訳系
- §4.1.7の評価機と同じく、翻訳系でも解釈と実行を分離する
- 解釈と実行を分離する手続き
compileは、 ターゲット(taget)とリンク記述子(linkage)を引数に取るtargetは式の返す値の格納先レジスタlinkageはコードが実行を終えたときの継続先のラベル。 ただしnextが指定された場合は、シーケンスの次の命令から実行を続ける
- シーケンスを組み合わせる際に、レジスタの退避や復元は
preservingに任せる。 実装の詳細はここではよくわからない
とりあえず、細かいことは置いといて、 今回もMITのサンプルコードを Racketで動作するよう修正した。
https://github.com/uents/sicp/tree/master/ch5.5-compiler
問題 5.31
よくわからないので、それぞれコンパイルしてみた。
a. (f 'x 'y)
翻訳系の実行結果からすると、何も退避しなくてよい。
compiler.scm<feff>> (compile '(f 'x 'y) 'val 'next) '((env) (env proc argl continue val) ((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-branch1)) compiled-branch2 (assign continue (label after-call3)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch1 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call3))
b. ((f) 'x 'y)
aと比較すると(f ...)が((f) ...)に変わっただけ。
(f)には非演算子(の部分式)が存在しないため、
(f)を評価する際にスタックの退避が発生せず、結果はaと同じになる。
compiler.scm<feff>> (compile '((f) 'x 'y) 'val 'next) '((env) (env proc argl continue val) ((assign proc (op lookup-variable-value) (const f) (reg env)) (assign argl (const ())) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch4)) compiled-branch5 (assign continue (label proc-return7)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) proc-return7 (assign proc (reg val)) (goto (label after-call6)) primitive-branch4 (assign proc (op apply-primitive-procedure) (reg proc) (reg argl)) after-call6 (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-branch8)) compiled-branch9 (assign continue (label after-call10)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch8 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call10))
c. (f (g 'x) y)
おおよその処理の流れは以下の通り。
fを環境フレームから探し出しprocに格納procをスタックに退避するfの引数について、まずはyが評価されarglに格納- 次に
(g 'x)の評価を行うために、agrlをスタックに退避 gを環境フレームから探し出しprocに格納'xを評価しagrlに格納gにarglを適用して評価し、返り値をvalに格納- 3でスタックに退避した
arglを復元 arglに7のvalの値を追加fにarglを適用して評価し、返り値をvalに格納
compiler.scm<feff>> (compile '(f (g 'x) y) 'val 'next) '((env) (env proc argl continue val) ((assign proc (op lookup-variable-value) (const f) (reg env)) (save proc) (assign val (op lookup-variable-value) (const y) (reg env)) (assign argl (op list) (reg val)) (save argl) (assign proc (op lookup-variable-value) (const g) (reg env)) (assign val (const x)) (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch11)) compiled-branch12 (assign continue (label after-call13)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch11 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call13 (restore argl) (assign argl (op cons) (reg val) (reg argl)) (restore proc) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch14)) compiled-branch15 (assign continue (label after-call16)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch14 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call16))
ウェブで色々な回答を見ていると「envが退避or復元される」と
いったものがあったが、今回のコンパイル結果には見当たらなかった。
明示的に新たな変数束縛があるわけでないのでenvが拡張されないから、
翻訳系の最適化でenvの退避or復元はされないんじゃないかなぁ。
外してるかもしれないけど。
d. (f (g 'x) 'y)
細かいことは省略。結果はcとほぼ同じ。
compiler.scm<feff>> (compile '(f (g 'x) 'y) 'val 'next) '((env) (env proc argl continue val) ((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 proc (op lookup-variable-value) (const g) (reg env)) (assign val (const x)) (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch17)) compiled-branch18 (assign continue (label after-call19)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch17 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call19 (restore argl) (assign argl (op cons) (reg val) (reg argl)) (restore proc) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch20)) compiled-branch21 (assign continue (label after-call22)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch20 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call22))
問題 5.32 a.
積極的評価機に対して(+ 1 2)がどのように解釈されるかを
理解していないので、まずは実行して追ってみる。
§5.2でせっせと作ったトレース機能を有効にして実行。
eceval.scm<feff>> (eceval 'trace-on) eceval.scm<feff>> (start eceval) '(label = read-eval-print-loop) '(inst = (perform (op initialize-stack))) '(inst = (perform (op prompt-for-input) (const ";;; EC-Eval input:"))) ;;; EC-Eval input: '(inst = (assign exp (op read))) (+ 1 2) ;; snip... '(label = ev-application) '(inst = (save continue)) '(inst = (save env)) '(inst = (assign unev (op operands) (reg exp))) '(inst = (save unev)) '(inst = (assign exp (op operator) (reg exp))) '(inst = (assign continue (label ev-appl-did-operator))) '(inst = (goto (label eval-dispatch))) '(label = eval-dispatch) '(inst = (test (op self-evaluating?) (reg exp))) '(inst = (branch (label ev-self-eval))) '(inst = (test (op variable?) (reg exp))) '(inst = (branch (label ev-variable))) '(label = ev-variable) '(inst = (assign val (op lookup-variable-value) (reg exp) (reg env))) '(inst = (goto (reg continue))) '(label = ev-appl-did-operator) '(inst = (restore unev)) '(inst = (restore env)) '(inst = (assign argl (op empty-arglist))) '(inst = (assign proc (reg val))) '(inst = (test (op no-operands?) (reg unev))) '(inst = (branch (label apply-dispatch))) '(inst = (save proc)) '(inst = (save argl)) '(inst = (assign exp (op first-operand) (reg unev))) '(inst = (test (op last-operand?) (reg unev))) '(inst = (branch (label ev-appl-last-arg))) '(inst = (save env)) '(inst = (save unev)) '(inst = (assign continue (label ev-appl-accumulate-arg))) '(inst = (goto (label eval-dispatch))) '(label = eval-dispatch) '(inst = (test (op self-evaluating?) (reg exp))) '(inst = (branch (label ev-self-eval))) '(label = ev-self-eval) '(inst = (assign val (reg exp))) '(inst = (goto (reg continue))) '(label = ev-appl-accumulate-arg) '(inst = (restore unev)) '(inst = (restore env)) '(inst = (restore argl)) '(inst = (assign argl (op adjoin-arg) (reg val) (reg argl))) '(inst = (assign unev (op rest-operands) (reg unev))) '(inst = (goto (label ev-appl-operand-loop))) '(label = ev-appl-operand-loop) '(inst = (save argl)) '(inst = (assign exp (op first-operand) (reg unev))) '(inst = (test (op last-operand?) (reg unev))) '(inst = (branch (label ev-appl-last-arg))) '(label = ev-appl-last-arg) '(inst = (assign continue (label ev-appl-accum-last-arg))) '(inst = (goto (label eval-dispatch))) '(label = eval-dispatch) '(inst = (test (op self-evaluating?) (reg exp))) '(inst = (branch (label ev-self-eval))) '(label = ev-self-eval) '(inst = (assign val (reg exp))) '(inst = (goto (reg continue))) '(label = ev-appl-accum-last-arg) '(inst = (restore argl)) '(inst = (assign argl (op adjoin-arg) (reg val) (reg argl))) '(inst = (restore proc)) '(inst = (goto (label apply-dispatch))) '(label = apply-dispatch) '(inst = (test (op primitive-procedure?) (reg proc))) '(inst = (branch (label primitive-apply))) '(label = primitive-apply) '(inst = (assign val (op apply-primitive-procedure) (reg proc) (reg argl))) '(inst = (restore continue)) '(inst = (goto (reg continue))) '(label = print-result) '(inst = (perform (op print-stack-statistics))) '(total-pushes = 8 max-depth = 5 curr-depth = 0) '(inst = (perform (op announce-output) (const ";;; EC-Eval value:"))) ;;; EC-Eval value: '(inst = (perform (op user-print) (reg val))) 3 '(inst = (goto (label read-eval-print-loop))) '(label = read-eval-print-loop) '(inst = (perform (op initialize-stack))) '(inst = (perform (op prompt-for-input) (const ";;; EC-Eval input:")))
処理の大まかな流れは、
ev-applicationでeval-dispatchでexpに格納されて演算子の手続きを環境フレームから探してev-appl-did-operatorへ
ev-appl-did-operatorで
以降はこの流れの繰り返しで、非演算子の評価が進んでいく。
さらに、apply-dispatchへ飛ぶと、評価済みの非演算子が蓄積されたarglが
手続きprocに適用・評価され、その返り値がvalに格納される。
ただし、演算子がシンボルの場合は、演算子を評価する際のeval-dispatchで、
envが拡張されることはないので、envの退避・復元を行わなくてもよいはず。
修正方法はいくつかあると思うが、 今回は sicp-solutions の回答をそのまま拝借した。
ev-application (save continue) (assign unev (op operands) (reg exp)) (assign exp (op operator) (reg exp)) (test (op symbol?) (reg exp)) ;;the operator is symbol? (branch (label ev-appl-operator-symbol)) (save env) (save unev) (assign continue (label ev-appl-did-operator-with-restore)) (goto (label eval-dispatch)) ev-appl-operator-symbol (assign continue (label ev-appl-did-operator)) (goto (label eval-dispatch)) ev-appl-did-operator-with-restore (restore unev) (restore env) ev-appl-did-operator (assign argl (op empty-arglist)) (assign proc (reg val)) ;;the evaluated operator (test (op no-operands?) (reg unev)) (branch (label apply-dispatch)) (save proc)
積極制御評価機に組み込んで試してみる。
eceval.scm<feff>> (eceval 'trace-on) eceval.scm<feff>> (start eceval) '(label = read-eval-print-loop) '(inst = (perform (op initialize-stack))) '(inst = (perform (op prompt-for-input) (const ";;; EC-Eval input:"))) ;;; EC-Eval input: '(inst = (assign exp (op read))) (+ 1 2) ;; snip... '(label = ev-application) '(inst = (save continue)) '(inst = (assign unev (op operands) (reg exp))) '(inst = (assign exp (op operator) (reg exp))) '(inst = (test (op symbol?) (reg exp))) '(inst = (branch (label ev-appl-operator-symbol))) '(label = ev-appl-operator-symbol) '(inst = (assign continue (label ev-appl-did-operator))) '(inst = (goto (label eval-dispatch))) '(label = eval-dispatch) '(inst = (test (op self-evaluating?) (reg exp))) '(inst = (branch (label ev-self-eval))) '(inst = (test (op variable?) (reg exp))) '(inst = (branch (label ev-variable))) '(label = ev-variable) '(inst = (assign val (op lookup-variable-value) (reg exp) (reg env))) '(inst = (goto (reg continue))) '(label = ev-appl-did-operator) '(inst = (assign argl (op empty-arglist))) '(inst = (assign proc (reg val))) ;; snip... ;;; EC-Eval value: '(inst = (perform (op user-print) (reg val))) 3
狙い通り、演算子の評価でenvの退避・復元を行わなくても正しく動作する。
問題 5.32 b.
Alyssaの言いたいことはわからないでもないが、 積極制御評価機の内部をいくら最適化しても、ソースコードを逐次評価して実行する 解釈系なので、翻訳系以上の最適化は行えないように思う。
次回は「5.5.2 式の翻訳」から。
SICP 読書ノート#75 - 5.4 積極制御評価機 (pp.327-338)
積極制御評価機 (explicit-control evaluator) とは、 レジスタマシンシミュレータ上で動作する マシン語で実装されたScheme処理系のことのよう。
Schemeプログラム→積極制御評価機→レジスタマシン→Scheme処理系 と、さらに抽象化が増してきた。
実装としては、§4.1.1〜§4.1.3ででてきた超循環評価機を レジスタマシン語に書き直したような感じなので、 コードを比較すればなんとなく概要は理解できる。
評価機をRacketで動作させる
Racketではset-car!、set-cdr!が使えないため、いつものごとく
MITのサンプルコードは
そのままでは動かず、以下のように書き直した。
https://github.com/uents/sicp/tree/master/ch5.4-explicit-control-evaluator
ただ、主にはenvironmentの実装をhashに書き換えたくらいで、 それ以外はほぼそのままでOK。
末尾再帰
超循環評価機では、末尾再帰するかどうかは、下回りの処理系に依存していたが、 積極的制御評価機では、評価機の実装でそれを決めることができる。
つまり、末尾再帰が何なのか、ここでついに明らかになりました！
テキストの積極制御評価機は末尾再帰をサポートしているとのことなので、試してみる。
;;; EC-Eval input: (define (fact-iter n) (define (iter n val) (if (= n 1) val (iter (- n 1) (* n val)))) (iter n 1)) ;;; EC-Eval value: ok ;;; EC-Eval input: (fact-iter 5) '(total-pushes = 169 max-depth = 10 curr-depth = 0) ;;; EC-Eval value: 120 ;;; EC-Eval input: (fact-iter 10) '(total-pushes = 344 max-depth = 10 curr-depth = 0) ;;; EC-Eval value: 3628800
f(5)でもf(10)でもスタックの最大深さは同じなので、末尾再帰できてそう。
次に、末尾再帰を行わない方のev-sequence。
シーケンスに入る度にレジスタの内容を必ずスタックに詰め込んでいる。
;; non-tail-recursive version ev-sequence (test (op no-more-exps?) (reg unev)) (branch (label ev-sequence-end)) (assign exp (op first-exp) (reg unev)) (save unev) (save env) (assign continue (label ev-sequence-continue)) (goto (label eval-dispatch)) ev-sequence-continue (restore env) (restore unev) (assign unev (op rest-exps) (reg unev)) (goto (label ev-sequence)) ev-sequence-end (restore continue) (goto (reg continue))
テスト結果。f(5)とf(10)でスタックの最大深さが変わっていて、
末尾再帰できていないことがわかる。
;;; EC-Eval input: (fact-iter 5) '(total-pushes = 181 max-depth = 26 curr-depth = 0) ;;; EC-Eval value: 120 ;;; EC-Eval input: (fact-iter 10) '(total-pushes = 366 max-depth = 41 curr-depth = 0) ;;; EC-Eval value: 3628800
問題 5.26
あれ、さっきやったことと似たような問題がでてきた...
以下のfactorial手続きを使って、評価機の末尾特性を監視する。
(define (factorial n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1))
nをいくつか与えて最大深さとプッシュ総数をを調べて見る。
n |
n! |
最大深さ | プッシュ総数 |
|---|---|---|---|
| 1 | 1 | 10 | 64 |
| 2 | 2 | 10 | 99 |
| 3 | 6 | 10 | 134 |
| 5 | 120 | 10 | 204 |
| 10 | 3628800 | 10 | 379 |
a.
nの値に関係なく10となる。
b.
push総数のオーダーはぱっと見ではO(n)。
iterativeに処理が進むはずなので、nに比例するのは当たり前か。
各項の差分を見ると等しいので、等差数列か？高１で出たな、懐かしい。
具体的には、nに対するプッシュ総数をp(n)とすると、
p(n) = 35*(n-1) + 64 と表わされる。
問題 5.27
問題 5.26と同じように以下の手続きを評価機に与えて、
nに対する最大深さとプッシュ総数を調べる。
(define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n)))
結果は以下の通り。
n |
n! |
最大深さ | プッシュ総数 |
|---|---|---|---|
| 1 | 1 | 8 | 16 |
| 2 | 2 | 13 | 48 |
| 3 | 6 | 18 | 80 |
| 5 | 120 | 28 | 144 |
| 10 | 3628800 | 53 | 304 |
最大深さはd(n) = 5*(n-1) + 8、プッシュ総数はp(n) = 32*(n-1) + 16となる。
オーダーで表にすると以下のようになるので、
| 最大深さ | プッシュ総数 | |
|---|---|---|
| 階乗(再帰) | O(n) |
O(n) |
| 階乗(反復) | O(1) |
O(n) |
- 記憶領域(スタック)の消費の観点では、階乗(反復)の方が優れている
- 計算量の観点では、両者とも左程変わらない
ということがわかる。
残りの問題はすっ飛ばします。いよいよ最後のセクション「§5.5 翻訳系」へ。
SICP 読書ノート#74 - 5.3 記憶の割当てとごみ集め (pp.319-327)
「§5.3 記憶の割当てとごみ集め」から。以下を順に読みました。
メモリ管理とガベージコレクションの話。無限メモリーを実現できれば、 それはチューリング完全を意味するけど、実際は有限のメモリーしか持てないので ガベージコレクションで近似しましょう、みたいな話と理解。
仕事でもとある処理系を拡張したりしているけど、 いつGCを走らせるかは難しい課題だったりする。
ストップアンドコピーごみ集めも概要は理解できたので、次へ進みます。
SICP 読書ノート#73 - 5.2 レジスタ計算機シミュレータ(2) (pp.318-319)
「§5.2.4 計算機の性能の監視」から。
レジスタ計算機シミュレータにinspectorやdebuggerを実装していくみたい。面白そう。
まずはテキスト通り、スタックの状況をチェックするコマンドを実装する。
;;;; stack (define (make-stack) - (let ((s '())) + (let ((s '()) + (number-pushes 0) + (max-depth 0) + (current-depth 0)) (define (push x) - (set! s (cons x s))) + (set! s (cons x s)) + (set! number-pushes (+ 1 number-pushes)) + (set! current-depth (+ 1 current-depth)) + (set! max-depth (max current-depth max-depth))) (define (pop) (if (null? s) (error "[stack] empty stack") (let ((top (car s))) (set! s (cdr s)) + (set! current-depth (- current-depth 1)) top))) (define (initialize) (set! s '()) + (set! number-pushes 0) + (set! max-depth 0) + (set! current-depth 0) 'done) + (define (print-statistics) + (pretty-print (list 'total-pushes '= number-pushes + 'max-depth '= max-depth + 'curr-depth '= current-depth))) ;; pushは内部手続きを返すが、 ;; pop/initializeは内部手続きの実行して結果を返す(ややこしい..) (define (dispatch message) (cond ((eq? message 'push) push) ((eq? message 'pop) (pop)) ((eq? message 'initialize) (initialize)) + ((eq? message 'print-statistics) (print-statistics)) (else (error "[stack] unknown request:" + message)))) dispatch))
the-opsに手続きを追加することで、
(perform (op print-stack-statistics)でチェックできるようになる。
(stack (make-stack))
(the-instruction-sequence '())
(the-ops (list (list 'initialize-stack
- (lambda () (stack 'initialize)))))
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
(register-table (list (list 'pc pc)
(list 'flag flag))))
(define (allocate-register name)
§5.1のfactorial-machineで試してみる。
regsim.scm<feff>> (define fact-machine (make-machine '(val n continue) (list (list '= =) (list '- -) (list '* *)) '(controller (perform (op initialize-stack)) ;; add (assign continue (label fact-done)) fact-loop (test (op =) (reg n) (const 1)) (branch (label base-case)) (save continue) (perform (op print-stack-statistics)) ;; add (save n) (perform (op print-stack-statistics)) ;; add (assign n (op -) (reg n) (const 1)) (assign continue (label after-fact)) (goto (label fact-loop)) after-fact (restore n) (perform (op print-stack-statistics)) ;; add (restore continue) (perform (op print-stack-statistics)) ;; add (assign val (op *) (reg n) (reg val)) (goto (reg continue)) base-case (assign val (const 1)) (goto (reg continue)) fact-done))) regsim.scm<feff>> (set-register-contents! fact-machine 'n 3) 'done regsim.scm<feff>> (start fact-machine) '(total-pushes = 1 max-depth = 1 curr-depth = 1) '(total-pushes = 2 max-depth = 2 curr-depth = 2) '(total-pushes = 3 max-depth = 3 curr-depth = 3) '(total-pushes = 4 max-depth = 4 curr-depth = 4) '(total-pushes = 4 max-depth = 4 curr-depth = 3) '(total-pushes = 4 max-depth = 4 curr-depth = 2) '(total-pushes = 4 max-depth = 4 curr-depth = 1) '(total-pushes = 4 max-depth = 4 curr-depth = 0) 'done
current-depthの動きが§5.1で追った通りになっていることがわかる。
問題 5.14
fact-machineを以下のように改造する。
(define fact-machine
(make-machine
'(val n continue)
(list (list '= =)
(list '- -)
(list '* *))
'(controller
+ (perform (op initialize-stack))
(assign continue (label fact-done))
fact-loop
(test (op =) (reg n) (const 1))
(branch (label base-case))
(save continue)
(save n)
(assign n (op -) (reg n) (const 1))
(assign continue (label after-fact))
(goto (label fact-loop))
after-fact
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
base-case
+ (perform (op print-stack-statistics))
(assign val (const 1))
(goto (reg continue))
fact-done)))
実行結果は以下の通り。
regsim.scm<feff>> (map (lambda (n) (set-register-contents! fact-machine 'n n) (start fact-machine)) '(1 2 3 4 5 6 7 8 9 10)) '(total-pushes = 0 max-depth = 0 curr-depth = 0) '(total-pushes = 2 max-depth = 2 curr-depth = 2) '(total-pushes = 4 max-depth = 4 curr-depth = 4) '(total-pushes = 6 max-depth = 6 curr-depth = 6) '(total-pushes = 8 max-depth = 8 curr-depth = 8) '(total-pushes = 10 max-depth = 10 curr-depth = 10) '(total-pushes = 12 max-depth = 12 curr-depth = 12) '(total-pushes = 14 max-depth = 14 curr-depth = 14) '(total-pushes = 16 max-depth = 16 curr-depth = 16) '(total-pushes = 18 max-depth = 18 curr-depth = 18) '(done done done done done done done done done done)
よって、結果はnに対し2n-2となる。
問題 5.15
命令計数カウンタ(instruction counter)として、
実行手続きが実行される度に加算されるカウンタを追加すればよい。
(define (make-new-machine)
(let* ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(the-ops (list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(register-table (list (list 'pc pc)
- (list 'flag flag))))
+ (list 'flag flag)))
+ (instruction-count 0))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
((instruction-execution-proc (car insts)))
+ (set! instruction-count (+ instruction-count 1))
(execute)))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq)
(set! the-instruction-sequence seq)))
((eq? message 'allocate-register)
allocate-register)
((eq? message 'get-register)
lookup-register)
((eq? message 'install-operations)
(lambda (ops)
(set! the-ops (append the-ops ops))))
((eq? message 'stack)
stack)
((eq? message 'operations)
the-ops)
+ ((eq? message 'initialize-instruction-count)
+ (set! instruction-count 0))
+ ((eq? message 'get-instruction-count)
+ instruction-count)
実行結果は以下の通り。
(map (lambda (n) (set-register-contents! fact-machine 'n n) (fact-machine 'initialize-instruction-count) (start fact-machine) (pretty-print (list 'n '= n 'instruction-count '= (fact-machine 'get-instruction-count)))) '(1 2 3 4 5 6 7 8 9 10)) '(n = 1 instruction-count = 5) '(n = 2 instruction-count = 16) '(n = 3 instruction-count = 27) '(n = 4 instruction-count = 38) '(n = 5 instruction-count = 49) '(n = 6 instruction-count = 60) '(n = 7 instruction-count = 71) '(n = 8 instruction-count = 82) '(n = 9 instruction-count = 93) '(n = 10 instruction-count = 104)
問題 5.16
trace-flagを追加し、trueの場合はinstruction-textをプリントさせる。
(define (make-new-machine)
(let* ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(the-ops (list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(register-table (list (list 'pc pc)
(list 'flag flag)))
- (instruction-count 0))
+ (instruction-count 0)
+ (trace-flag false))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
- ((instruction-execution-proc (car insts)))
+ (let ((inst (car insts)))
+ (if trace-flag
+ (pretty-print (list 'inst '= (instruction-text inst)))
+ false)
+ ((instruction-execution-proc inst)))
(set! instruction-count (+ instruction-count 1))
(execute)))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq)
(set! the-instruction-sequence seq)))
((eq? message 'allocate-register)
allocate-register)
((eq? message 'get-register)
lookup-register)
((eq? message 'install-operations)
(lambda (ops)
(set! the-ops (append the-ops ops))))
((eq? message 'stack)
stack)
((eq? message 'operations)
the-ops)
((eq? message 'initialize-instruction-count)
(set! instruction-count 0))
((eq? message 'get-instruction-count)
instruction-count)
+ ((eq? message 'trace-on)
+ (set! trace-flag true))
+ ((eq? message 'trace-off)
+ (set! trace-flag false))
fact-machineでの実行結果。
regsim.scm<feff>> (set-register-contents! fact-machine 'n 3) 'done regsim.scm<feff>> (fact-machine 'trace-on) regsim.scm<feff>> (start fact-machine) '(inst = (assign continue (label fact-done))) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(inst = (save continue)) '(inst = (save n)) '(inst = (assign n (op -) (reg n) (const 1))) '(inst = (assign continue (label after-fact))) '(inst = (goto (label fact-loop))) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(inst = (save continue)) '(inst = (save n)) '(inst = (assign n (op -) (reg n) (const 1))) '(inst = (assign continue (label after-fact))) '(inst = (goto (label fact-loop))) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(inst = (assign val (const 1))) '(inst = (goto (reg continue))) '(inst = (restore n)) '(inst = (restore continue)) '(inst = (assign val (op *) (reg n) (reg val))) '(inst = (goto (reg continue))) '(inst = (restore n)) '(inst = (restore continue)) '(inst = (assign val (op *) (reg n) (reg val))) '(inst = (goto (reg continue))) 'done
問題 5.17
実装方法は色々あると思うが、問題5.19のことも考えると ラベル名と命令シーケンスを対で管理しておいた方がよい。
そこで、make-label-entryでラベル名に対する命令シーケンスを紐づける箇所を、
ラベル名と命令シーケンスの対を紐づけるように修正する。
(define (extract-labels ctrl-text recieve)
(if (null? ctrl-text)
(recieve '() '())
(extract-labels (cdr ctrl-text)
(lambda (insts labels)
(let ((next-inst (car ctrl-text)))
(if (symbol? next-inst)
(if (label-insts labels next-inst)
(error "[extract-labels] duplicate label:" next-inst)
(recieve insts
- (cons (make-label-entry next-inst insts)
+ (cons (make-label-entry next-inst
+ (cons next-inst insts))
labels)))
(recieve (cons (make-instruction next-inst)
insts)
labels)))))))
これに合わせてexecuteで命令シーケンスを実行する際に、
ラベル名かどうかのチェックとログの表示処理を追加する。
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
- (begin
- (let ((inst (car insts)))
- (if trace-flag
- (pretty-print (list 'inst '= (instruction-text inst)))
- false)
- ((instruction-execution-proc inst)))
- (set! instruction-count (+ instruction-count 1))
- (execute)))))
+ (if (symbol? (car insts))
+ (begin
+ (if trace-flag
+ (pretty-print (list 'label '= (car insts)))
+ false)
+ (set-contents! pc (cdr insts))
+ (execute))
+ (begin
+ (let ((inst (car insts)))
+ (if trace-flag
+ (pretty-print (list 'inst '= (instruction-text inst)))
+ false)
+ ((instruction-execution-proc inst)))
+ (set! instruction-count (+ instruction-count 1))
+ (execute))))))
さらに命令シーケンスの先頭に対し、最初のラベル名と紐づける。
(define (make-machine register-names ops ctrl-text)
(let ((machine (make-new-machine)))
;; レジスタの登録
(for-each (lambda (register-name)
((machine 'allocate-register) register-name))
register-names)
;; オペレーションの登録
((machine 'install-operations) ops)
;; 命令シーケンスの登録
(let ((inst-seq (assemble ctrl-text machine)))
(pretty-print inst-seq) ;; 命令シーケンスの登録
(let ((inst-seq (assemble ctrl-text machine)))
(pretty-print inst-seq)
- ((machine 'install-instruction-sequence) inst-seq))
+ ((machine 'install-instruction-sequence) (cons (car ctrl-text) inst-seq)))
machine))
fact-machineでの実行結果。§5.1で追ったのと同じ結果になった。
regsim.scm<feff>> (set-register-contents! fact-machine 'n 3) 'done regsim.scm<feff>> (fact-machine 'trace-on) regsim.scm<feff>> (start fact-machine) '(label = controller) '(inst = (assign continue (label fact-done))) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(inst = (save continue)) '(inst = (save n)) '(inst = (assign n (op -) (reg n) (const 1))) '(inst = (assign continue (label after-fact))) '(inst = (goto (label fact-loop))) '(label = fact-loop) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(inst = (save continue)) '(inst = (save n)) '(inst = (assign n (op -) (reg n) (const 1))) '(inst = (assign continue (label after-fact))) '(inst = (goto (label fact-loop))) '(label = fact-loop) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(label = base-case) '(inst = (assign val (const 1))) '(inst = (goto (reg continue))) '(label = after-fact) '(inst = (restore n)) '(inst = (restore continue)) '(inst = (assign val (op *) (reg n) (reg val))) '(inst = (goto (reg continue))) '(label = after-fact) '(inst = (restore n)) '(inst = (restore continue)) '(inst = (assign val (op *) (reg n) (reg val))) '(inst = (goto (reg continue))) '(label = fact-done) 'done
問題 5.18
命令シーケンスと同じようにレジスタにもトレース機能を持たせる。
(define (make-register name) - (let ((contents '*unassigned*)) + (let ((contents '*unassigned*) + (trace-flag false)) (define (dispatch message) (cond ((eq? message 'get) contents) ((eq? message 'set) - (lambda (value) (set! contents value))) + (lambda (value) + (if trace-flag + (pretty-print (list 'reg '= name ': + contents '=> value)) + false) + (set! contents value))) + ((eq? message 'trace-on) + (set! trace-flag true)) + ((eq? message 'trace-off) + (set! trace-flag false)) (else (error "[register] unknown request:" message)))) dispatch))
レジスタマシン側のインターフェースに紐づける。
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq)
(set! the-instruction-sequence seq)))
((eq? message 'allocate-register)
allocate-register)
((eq? message 'get-register)
lookup-register)
((eq? message 'install-operations)
(lambda (ops)
(set! the-ops (append the-ops ops))))
((eq? message 'stack)
stack)
((eq? message 'operations)
the-ops)
((eq? message 'initialize-instruction-count)
(set! instruction-count 0))
((eq? message 'get-instruction-count)
instruction-count)
((eq? message 'trace-on)
(set! trace-flag true))
((eq? message 'trace-off)
(set! trace-flag false))
+ ((eq? message 'trace-register-on)
+ (lambda (reg-name)
+ ((lookup-register reg-name) 'trace-on)))
+ ((eq? message 'trace-register-off)
+ (lambda (reg-name)
+ ((lookup-register reg-name) 'trace-off)))
fact-machineでの実行結果。n!の結果が格納されるvalレジスタが意図通りに動いている。
> (set-register-contents! fact-machine 'n 3) 'done > ((fact-machine 'trace-register-on) 'val) > (start fact-machine) '(reg = val : *unassigned* => 1) '(reg = val : 1 => 2) '(reg = val : 2 => 6) 'done
問題 5.19
これまでのまとめ的な問題。要件をかみくだくと、以下のことができればよさそう。
(<label-name> <line-number>)の形式で、任意の箇所にブレークポイントが張れる- レジスタマシンはブレークポイントに達すると処理を中断する
(proceed-machine <machine>)で、レジスタマシンが中断した箇所から 処理を継続させることができる
まずは、ブレークポイントの管理する変数the-breakpointsを追加。
(define (make-new-machine)
(let* ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(the-ops (list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))))
(register-table (list (list 'pc pc)
(list 'flag flag)))
(instruction-count 0)
- (trace-flag false))
+ (trace-flag false)
+ (the-breakpoints '()))
the-breakpointsには、ブレークポイントを
(<label-name> <line-number>)のリストとして管理する。
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq)
(set! the-instruction-sequence seq)))
((eq? message 'allocate-register)
allocate-register)
((eq? message 'get-register)
lookup-register)
((eq? message 'install-operations)
(lambda (ops)
(set! the-ops (append the-ops ops))))
((eq? message 'stack)
stack)
((eq? message 'operations)
the-ops)
((eq? message 'initialize-instruction-count)
(set! instruction-count 0))
((eq? message 'get-instruction-count)
instruction-count)
((eq? message 'trace-on)
(set! trace-flag true))
((eq? message 'trace-off)
(set! trace-flag false))
((eq? message 'trace-register-on)
(lambda (reg-name)
((lookup-register reg-name) 'trace-on)))
((eq? message 'trace-register-off)
(lambda (reg-name)
((lookup-register reg-name) 'trace-off)))
+ ((eq? message 'set-breakpoint)
+ (lambda (label-name line-number)
+ (set! the-breakpoints
+ (cons (cons label-name line-number) the-breakpoints))))
+ ((eq? message 'cancel-breakpoint)
+ (lambda (label-name line-number)
+ (set! the-breakpoints
+ (filter (lambda (item)
+ (not (equal? item (cons label-name line-number))))
+ the-breakpoints))))
+ ((eq? message 'cancel-all-breakpoints)
+ (set! the-breakpoints '()))
+ ((eq? message 'print-breakpoints)
+ (pretty-print (list 'breakpoints '= the-breakpoints)))
現在の実行位置をcurrent-pointとして保持し、
current-pointがthe-breakpointsに含まれる場合はブレークさせる。
(define (make-new-machine)
(let* ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(the-ops (list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))))
(register-table (list (list 'pc pc)
(list 'flag flag)))
(instruction-count 0)
(trace-flag false)
- (the-breakpoints '()))
+ (the-breakpoints '())
+ (current-point '()))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(if (symbol? (car insts))
(begin
(if trace-flag
(pretty-print (list 'label '= (car insts)))
false)
+ (set! current-point (cons (car insts) 0))
(set-contents! pc (cdr insts))
(execute))
(begin
(let ((inst (car insts)))
(if trace-flag
(pretty-print (list 'inst '= (instruction-text inst)))
false)
((instruction-execution-proc inst)))
(set! instruction-count (+ instruction-count 1))
- (execute))))))
+ (set! current-point (cons (car current-point)
+ (add1 (cdr current-point))))
+ (if (member current-point the-breakpoints)
+ 'break!
+ (execute)))))))
ブレーク後に継続させるproceedでは単にexecuteを実行する。
+ ((eq? message 'proceed) + (execute)) (else (error "[machine] unknown request:" message)))) dispatch))
最後にインターフェースを追加する。
+(define (set-breakpoint machine label-name line-number) + ((machine 'set-breakpoint) label-name line-number)) +(define (cancel-breakpoint machine label-name line-number) + ((machine 'cancel-breakpoint) label-name line-number)) +(define (cancel-all-breakpoints machine) + (machine 'cancel-all-breakpoints)) +(define (proceed-machine machine) + (machine 'proceed))
gcd-machineで実行する。
regsim.scm<feff>> (define gcd-machine (make-machine '(a b t) (list (list 'rem remainder) (list '= =)) '(test-b (test (op =) (reg b) (const 0)) (branch (label gcd-done)) (assign t (op rem) (reg a) (reg b)) (assign a (reg b)) (assign b (reg t)) (goto (label test-b)) gcd-done))) regsim.scm<feff>> (set-register-contents! gcd-machine 'a 206) regsim.scm<feff>> (set-register-contents! gcd-machine 'b 40) regsim.scm<feff>> (set-breakpoint gcd-machine 'test-b 4) regsim.scm<feff>> (start gcd-machine) 'break! regsim.scm<feff>> (get-register-contents gcd-machine 'a) 40 regsim.scm<feff>> (proceed-machine gcd-machine) 'break! regsim.scm<feff>> (get-register-contents gcd-machine 'a) 6 regsim.scm<feff>> (proceed-machine gcd-machine) 'break! regsim.scm<feff>> (get-register-contents gcd-machine 'a) 4 regsim.scm<feff>> (proceed-machine gcd-machine) 'break! regsim.scm<feff>> (get-register-contents gcd-machine 'a) 2 regsim.scm<feff>> (proceed-machine gcd-machine) 'done regsim.scm<feff>> (get-register-contents gcd-machine 'a) 2
次回は「§5.3 記憶の割当てとごみ集め」から。
