SICP 5.2.3 Generating Execution Procedures for Instructions
ノート
make-execution-procedureはレジスタマシン言語の命令毎のディスパッチャ。各命令毎に実行する為の手続きを返す手続きが定義されている。
Assign instructions
命令に指定されているレジスタ、式をローカル変数に保存して引数無しの手続きを返す。値の部分も命令なので実行して（これも引数無しの手続き）その結果をレジスタに保存する。最後にpcを進める。
advance-pcで更新するpcはまんまポインターとして動作している。現在のpcが指しているリストのcdrをpcに代入。指されている命令リスト側には影響無し。
Test, branch, and goto instructions
make-branchでは
- 飛び先のラベルから命令リストの該当する位置をinstに保存
- 条件文を実行して結果をflagに保存
- flagが真であればpcをinstの位置に変更、偽であればpcを進めて次の命令に移項する手続きを生成する。
make-gotoは
を生成する。
Other instructions
3つの手続きともほぼ自明。
Execution procedures for subexpressions
make-primitive-expはassignに対するオペランド、単なるoperationのオペランドとなる値を提供する手続きを生成する。
make-operation-expはassign、perform、testのオペランドとなる命令を実行する手続きを生成する。命令はマシンのoperation listから見つけた手続きopをapplyを使って実行する手続きを生成する。expの引数それぞれにmake-primitive-expで生成した手続きのリスト（aproc）をmapで一つ一つ実行して値に変換してapplyを使ってopに渡す。
以上は命令の一部となるのでpcを進めない。
Exercise 5.9
make-primitive-expが扱う対象はassignのオペランドでもあるので、ここではlabelも扱う必要がある。
なのでmake-operation-expを変更してopでのみlabelの使用を禁止しなければならない。
(define (make-operation-exp exp machine labels operations) (let ((op (lookup-prim (operation-exp-op exp) operations)) (aprocs (map (lambda (e) (if (label-exp? e) (error "Label cannot be an operand of op.") (make-primitive-exp e machine labels))) (operation-exp-operands exp)))) (lambda () (apply op (map (lambda (p) (p)) aprocs)))))
例えば
> (define machine (make-machine '(a) (list (list '= =)) '(controller start here (test (op =) (label start) (label here)) (goto (label start))))) . . Label cannot be an operand of op. >
こんな感じ。
Exercise 5.10
> Can you implement your new syntax without changing any part of the simulator except the syntax procedures in this section?
要は構文解析部分のみの変更で実行部分には変更を加えずと言う事。もう少し言うとmake-execution-procedureのみ変更、後は追加された構文用の手続きを追加するだけで出来るかと言う事。
現時点で用意されている命令で基本的なことは全て出来るし、演算的なことはプリミティブとして用意してしまえば出来てしまう。命令セットとしては建前的には内部レジスタflagやpcを他のレジスタに保存したりスタックに保存したりは出来ない事になっている。実際にflagやpcと言うレジスタ名を使ってしまえば動作する筈だけど。特にpcをスタックにsaveしてrestoreするとcallとreturnが出来るので便利に使えそう。
(define (make-execution-procedure inst labels machine pc flag stack ops) (cond ((eq? (car inst) 'assign) (make-assign inst machine labels ops pc)) ・・・中略 ((eq? (car inst) 'call) (make-call inst machine labels stack pc)) ((eq? (car inst) 'return) (make-return inst machine stack pc)) (else (error "Unknown instruction type -- ASSEMBLE" inst)))) (define (make-call inst machine labels stack pc) (let ((dest (call-dest inst))) (if (label-exp? dest) (let ((insts (lookup-label labels (label-exp-label dest)))) (lambda () (push stack (get-contents pc)) (set-contents! pc insts))) (error "Bad CALL instruction -- ASSEMBLE" inst)))) (define (call-dest call-instruction) (cadr call-instruction)) (define (make-return inst machine stack pc) (lambda () (set-contents! pc (pop stack)) (advance-pc pc)))
使ってみる。
> (define add-three (make-machine '(a) (list (list '+ +)) '(controller (goto (label main)) inc (assign a (op +) (reg a) (const 1)) (return) main (call (label inc)) (call (label inc)) (call (label inc)) ))) > (set-register-contents! add-three 'a 206) 'done > (start add-three) 'done > (get-register-contents add-three 'a) 209 >
こんな感じ。
Exercise 5.11
a.
afterfib-n-2 ; upon return, val contains Fib(n - 2) (assign n (reg val)) ; n now contains Fib(n - 2) (restore val) ; val now contains Fib(n - 1) (restore continue) (assign val ; Fib(n - 1) + Fib(n - 2) (op +) (reg val) (reg n))
ここの部分。
- valの値(v1)をnにコピー
- stackの先頭の値(v2)をvalにポップ
- continueは兎も角
- valにvalの値(v2)とnの値(v1)の和を保存
となっているけど、最後の命令でv1とv2はvalでもnでもどちらに入っていても良いので、v1はvalに入れたまま、v2をnにポップしても結果は同じ。従って
afterfib-n-2 ; upon return, val contains Fib(n - 2) ; at this moment, val contains Fib(n - 2) (restore n) ; n now contains Fib(n - 1) (restore continue) (assign val ; Fib(n - 1) + Fib(n - 2) (op +) (reg val) (reg n))
と書ける。
b.
save命令に対応する手続きでは、pushを呼び出す時にレジスタに対してget-contentsを適用してスタックには値だけを渡している。これをレジスタそのものを渡す様に変更。
(define (make-save inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst)))) (lambda () (push stack reg) (advance-pc pc)))) (define (push stack register) ((stack 'push) register))
make-registerでは引数としてレジスタの名前を渡しているが、実はこの名前はこれまでのところ何にも利用されていない。
この名前を返すメソッドnameを追加する。
(define (make-register name) (let ((contents '*unassigned*)) (define (dispatch message) (cond ((eq? message 'get) contents) ((eq? message 'set) (lambda (value) (set! contents value))) ((eq? message 'name) name) (else (error "Unknown request -- REGISTER" message)))) dispatch)) (define (register-name register) (register 'name))
スタックではメソッドpushに渡される引数xが値からレジスタregに変わる。ここでレジスタをそのまま保存しても中身が変わってしまうので、名前と値のペアを保存する事にする。
(define (make-stack) (let ((s '())) (define (push reg) (set! s (cons (list (register-name reg) (get-contents reg)) s)))
restoreではpopで取り出した値をレジスタにセットしているが、popする際に代入するレジスタがどこなのかが必要となるのでpushと同様にレジスタを引数として渡して、stackの操作の中でレジスタに値を代入する必要がある。
(define (pop reg) (cond ((null? s) (error "Empty stack -- POP")) ((eq? (register-name reg) (caar s)) (set-contents! reg (cadar s)) (set! s (cdr s))) (else (error "Restoring register does not match:" (register-name reg) (caar s)))))
これに伴って以下の変更をする。dispatchでは内部手続きのpopを直接呼び出していたが、内部手続きpopを返す様にする。
(define (dispatch message) (cond ((eq? message 'push) push) ((eq? message 'pop) pop) ((eq? message 'initialize) (initialize)) (else (error "Unknown request -- STACK" message))))
グローバル手続きのpopではdispatchから返って来た内部手続きのpopを引数registerに適用する。
(define (pop stack register) ((stack 'pop) register))
popを呼び出すところでは返って来た値をレジスタに設定していて部分をpopにレジスタを渡す様に変更。
(define (make-restore inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst)))) (lambda () (pop stack reg) (advance-pc pc))))
一応回帰テスト。
> (define machine-ok (make-machine '(a b) '() '(controller (assign a (const 1)) (assign b (const 2)) (save a) (save b) (assign a (const 3)) (assign b (const 4)) (restore b) (restore a)))) > (start machine-ok) 'done > (get-register-contents machine-ok 'a) 1 > (get-register-contents machine-ok 'b) 2 >
では、動作確認
> (define machine-ng (make-machine '(a b) '() '(controller (assign a (const 1)) (assign b (const 2)) (save a) (save b) (assign a (const 3)) (assign b (const 4)) (restore a) (restore b)))) > (start machine-ng) . . Restoring register does not match: a b >
c.
pushする時に該当するレジスタ用のスタックが見つからなければ作る事も出来るが、問題文のアドバイスでは全てのレジスタ用のスタックを作る手続きを作れとの事なので、これに従う。
また、レジスタと対応するスタックを用意する事になるので、それぞれのレジスタにスタックを組み込む方法も考えられるが、その場合はレジスタを作るあるいは初期化する手続きを作ってそこでスタックも用意する事になるので、initialize-stackと言う手続きで全てのスタックを初期化する方針からは離れてしまうので、ここでは採用しない。
各レジスタ用のスタックのリストと言う構造を取るとset-cdr!でスタック部分を書き換える必要が出て来るが、Racketでは色々と制約があるのでハッシュテーブルで実現する事にする。レジスタ名をキーに、値のリストをスタックとする。
(define (make-stack) (let ((s (make-hash))) (define (push reg) (let ((st (hash-ref s (register-name reg)))) (if st (hash-set! s (register-name reg) (cons (get-contents reg) st)) (error "Unknown register used:" (register-name reg))))) (define (pop reg) (if (null? s) (error "Empty stack -- POP") (let ((st (hash-ref s (register-name reg)))) (if st (begin (set-contents! reg (car st)) (hash-set! s (register-name reg) (cdr st))) (error "Restoring unknown register:" (register-name reg)))))) (define (initialize name) (hash-set! s name '()) 'done) (define (dispatch message) (cond ((eq? message 'push) push) ((eq? message 'pop) pop) ((eq? message 'initialize) initialize) (else (error "Unknown request -- STACK" message)))) dispatch))
pushでもpopでも一旦ハッシュテーブルから該当のスタックを取り出して、そこに追加、あるいはそこから削除してもう一度ハッシュテーブルに戻す。
元々make-new-machineのthe-opsの初期値としてinitialize-stackが登録されているので、これを生かすとなると、ここでregister-tableにアクセスする必要が出て来るのでletを１段増やす。
(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '())) (let ((register-table (list (list 'pc pc) (list 'flag flag)))) (let ((the-ops (list (list 'initialize-stack (lambda () (initialize-stack stack register-table)))))) …
register-tableを引数に、各レジスタ用のスタックを用意する手続きinitialize-stackを定義する。
(define (initialize-stack stack registers) (for-each (lambda (reg) ((stack 'initialize) (car reg))) registers))
今までは呼んでいなかったが、ここではこのinitialize-stackを最初に呼び出す必要がある。アプリケーションのmake-machineの引数に含める事も出来るが、make-machineの中で最初に自動的にこのコードを追加する。
(define (make-machine register-names ops controller-text) (let ((machine (make-new-machine))) (for-each (lambda (register-name) ((machine 'allocate-register) register-name)) register-names) ((machine 'install-operations) ops) ((machine 'install-instruction-sequence) (assemble (cons '(perform (op initialize-stack)) controller-text) machine)) machine))
動作確認。
> (define machine (make-machine '(a b) '() '(controller (assign a (const 1)) (assign b (const 2)) (save a) (save b) (assign a (const 3)) (assign b (const 4)) (restore a) (restore b)))) > (start machine) 'done > (get-register-contents machine 'a) 1 > (get-register-contents machine 'b) 2 >
aを先に、bを後にスタックに積んでいるが、a、bの順にrestoreしてもどちらのレジスタも元の値に戻っている。
Exercise 5.12
そもそもこれらの情報はリクエストされた時に命令リストを走査して得れば良さそうなものだが、assemblerを改造して結果をマシンの中に保存せよとの事なので、assembleの中で全ての情報を作ってマシンに渡す事にする。
assembleは、extract-labelsがラベルを取り除いた命令リストinstsをupdate-insts!に渡して各命令に対応する手続きを付加している。extract-labelsが実はお膳立てとして元の命令リスト（controller-text）を命令のテキストと空リストからなるペアのリスト（insts）に変換しているので、instsは別の用途には少し使いにくい。従ってextract-labelsの再帰において何らかの情報を取り出して、必要があれば整形をしてマシンに保存するのがバランスとしては良さそう。
receive関数の引数にinsts、labelsに加えて、inst-index（controller-textの要素のうちシンボルでないもの全て）、goto-regs（gotoのオペランドとなっているレジスタ全て）、saved-regs（saveとrestoreのオペランド全て）、reg-sources（assignの第１引数毎の第２引数全て）を取る事にする。それぞれのリストは情報を集める段階ではsetを使って重複を除く。最後のreg-sourcesだけはレジスタ毎の分類が必要なので単純なリストではなくハッシュを使って、値としてsetを使う。
make-execution-procedureの条件分岐と重複するところが少し嫌な感じだが、目的が随分異なるので同居は断念。
(define (extract-labels text receive)
(if (null? text)
(receive '() '() (set) (set) (set) (make-hash))
(extract-labels (cdr text)
(lambda (insts labels inst-index label-regs saved-regs reg-sources)
(let ((next-inst (car text)))
(if (symbol? next-inst)
(if (assq next-inst labels)
(error "Multiply defined label: " next-inst)
(receive insts
(cons (make-label-entry next-inst
insts)
labels)
inst-index label-regs saved-regs reg-sources))
(receive (cons (make-instruction next-inst)
insts)
labels
(set-add inst-index next-inst)
(add-label-regs next-inst label-regs)
(add-saved-regs next-inst saved-regs)
(add-reg-sources next-inst reg-sources)
)))))))
(define (add-label-regs next-inst label-regs)
(if (and (eq? (car next-inst) 'goto) (eq? (caadr next-inst) 'reg))
(set-add label-regs (cadadr next-inst))
label-regs))
(define (add-saved-regs next-inst saved-regs)
(if (or (eq? (car next-inst) 'save) (eq? (car next-inst) 'restore))
(set-add saved-regs (cadr next-inst))
saved-regs))
(define (add-reg-sources next-inst reg-sources)
(if (eq? (car next-inst) 'assign)
(let ((l (hash-ref! reg-sources (cadr next-inst) (set (cddr next-inst)))))
(hash-set! reg-sources
(cadr next-inst)
(set-add l (cddr next-inst)))
reg-sources)
reg-sources))extract-labelsは本来名前を変えるべきだが、ここではそのままにする。
一応setは普通のリストに直しておく。hashは面倒なのでそのまま。ソートする為にsymbol->stringを使う。
assembleは単にinstsだけを返していたが、４つのリストと一つのhashのリストを返す様に変更。
(define (assemble controller-text machine) (extract-labels controller-text (lambda (insts labels inst-index label-regs saved-regs reg-sources) (update-insts! insts labels machine) (list insts (sort (set->list inst-index) (lambda (a b) (string<? (symbol->string (car a)) (symbol->string (car b))))) (set->list label-regs) (set->list saved-regs) reg-sources ))))
make-machineではassembleが返して来る４つのリストをそれぞれマシンに保存する。
(define (make-machine register-names ops controller-text) (let ((machine (make-new-machine))) (for-each (lambda (register-name) ((machine 'allocate-register) register-name)) register-names) ((machine 'install-operations) ops) (let ((insts (assemble controller-text machine))) ((machine 'install-instruction-sequence) (car insts)) ((machine 'install-instruction-index) (cadr insts)) ((machine 'install-label-registers) (caddr insts)) ((machine 'install-saved-registers) (cadddr insts)) ((machine 'install-register-sources) (car (cddddr insts))) machine)))
make-new-machineで作るマシンで上記のメッセージを受け取り、instruction-index、label-registers、saved-registersメッセージで保存された情報を返す様に変更する。
(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (the-instruction-index '()) (the-label-registers '()) (the-saved-registers '()) (the-register-sources '())) …中略 (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 'install-instruction-index) (lambda (index) (set! the-instruction-index index))) ((eq? message 'install-label-registers) (lambda (regs) (set! the-label-registers regs))) ((eq? message 'install-saved-registers) (lambda (regs) (set! the-saved-registers regs))) ((eq? message 'install-register-sources) (lambda (sources) (set! the-register-sources sources))) ((eq? message 'instruction-index) the-instruction-index) ((eq? message 'label-registers) the-label-registers) ((eq? message 'saved-registers) the-saved-registers) ((eq? message 'register-sources) the-register-sources) …以下省略
動作確認。
> (define fib-machine (make-machine '(continue n val) (list (list '< <) (list '- -) (list '+ +)) '(controller (assign continue (label fib-done)) fib-loop (test (op <) (reg n) (const 2)) (branch (label immediate-answer)) ;; set up to compute Fib(n - 1) (save continue) (assign continue (label afterfib-n-1)) (save n) ; save old value of n (assign n (op -) (reg n) (const 1)); clobber n to n - 1 (goto (label fib-loop)) ; perform recursive call afterfib-n-1 ; upon return, val contains Fib(n - 1) (restore n) (restore continue) ;; set up to compute Fib(n - 2) (assign n (op -) (reg n) (const 2)) (save continue) (assign continue (label afterfib-n-2)) (save val) ; save Fib(n - 1) (goto (label fib-loop)) afterfib-n-2 ; upon return, val contains Fib(n - 2) (assign n (reg val)) ; n now contains Fib(n - 2) (restore val) ; val now contains Fib(n - 1) (restore continue) (assign val ; Fib(n - 1) + Fib(n - 2) (op +) (reg val) (reg n)) (goto (reg continue)) ; return to caller, answer is in val immediate-answer (assign val (reg n)) ; base case: Fib(n) = n (goto (reg continue)) fib-done))) > (fib-machine 'instruction-index) '((assign continue (label afterfib-n-1)) (assign continue (label afterfib-n-2)) (assign continue (label fib-done)) (assign n (reg val)) (assign val (reg n)) (assign n (op -) (reg n) (const 2)) (assign n (op -) (reg n) (const 1)) (assign val (op +) (reg val) (reg n)) (branch (label immediate-answer)) (goto (label fib-loop)) (goto (reg continue)) (restore n) (restore val) (restore continue) (save val) (save n) (save continue) (test (op <) (reg n) (const 2))) > (fib-machine 'label-registers) '(continue) > (fib-machine 'saved-registers) '(n val continue) > (fib-machine 'register-sources) (hash 'n (set '((reg val)) '((op -) (reg n) (const 1)) '((op -) (reg n) (const 2))) 'continue (set '((label fib-done)) '((label afterfib-n-1)) '((label afterfib-n-2))) 'val (set '((reg n)) '((op +) (reg val) (reg n)))) >
一応結果は正しそう。
Exercise 5.13
make-machineの第１引数をやめて、for-eachでそれぞれのレジスタに対してallocate-registerメッセージでレジスタを登録するのをやめる。
(define (make-machine ops controller-text) (let ((machine (make-new-machine))) ((machine 'install-operations) ops) ((machine 'install-instruction-sequence) (assemble controller-text machine)) machine))
その代わりassembleの中で始めて登場した時に登録せよとの事。
この状態でmake-machineを実行すると
> (define fib-machine (make-machine (list (list '< <) (list '- -) (list '+ +)) '(controller (assign continue (label fib-done)) …中略 immediate-answer (assign val (reg n)) ; base case: Fib(n) = n (goto (reg continue)) fib-done))) . . Unknown register: continue >
とエラーになる。これはlookup-registerで探しているレジスタが見つからないため。なので、ここで見つからなければ新規に作れば良い事になる。allocate-registerはシンボル'register-allocatedを返してしまうので、登録した後にもう一度検索してレジスタを返す。
(define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (begin (allocate-register name) (cadr (assoc name register-table))))))
実行結果
> (define fib-machine (make-machine (list (list '< <) (list '- -) (list '+ +)) '(controller (assign continue (label fib-done)) fib-loop (test (op <) (reg n) (const 2)) (branch (label immediate-answer)) ;; set up to compute Fib(n - 1) (save continue) (assign continue (label afterfib-n-1)) (save n) ; save old value of n (assign n (op -) (reg n) (const 1)); clobber n to n - 1 (goto (label fib-loop)) ; perform recursive call afterfib-n-1 ; upon return, val contains Fib(n - 1) (restore n) (restore continue) ;; set up to compute Fib(n - 2) (assign n (op -) (reg n) (const 2)) (save continue) (assign continue (label afterfib-n-2)) (save val) ; save Fib(n - 1) (goto (label fib-loop)) afterfib-n-2 ; upon return, val contains Fib(n - 2) (assign n (reg val)) ; n now contains Fib(n - 2) (restore val) ; val now contains Fib(n - 1) (restore continue) (assign val ; Fib(n - 1) + Fib(n - 2) (op +) (reg val) (reg n)) (goto (reg continue)) ; return to caller, answer is in val immediate-answer (assign val (reg n)) ; base case: Fib(n) = n (goto (reg continue)) fib-done))) > (set-register-contents! fib-machine 'n 6) 'done > (start fib-machine) 'done > (get-register-contents fib-machine 'val) 8 >
