@uents blog

Code wins arguments.

SICP 読書ノート#76 - 5.5 翻訳系(1) (pp.339-343)

SICP Scheme

いよいよ最後のセクション。

これまでレジスタマシン、積極制御評価機(解釈系=インタプリタ)と来て、 ここでは翻訳系(=コンパイラ)について学びます。

翻訳系の概観

ひとことで言うと「環境を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)

おおよその処理の流れは以下の通り。

  1. fを環境フレームから探し出しprocに格納
  2. procをスタックに退避する
  3. fの引数について、まずはyが評価されarglに格納
  4. 次に(g 'x)の評価を行うために、agrlをスタックに退避
  5. gを環境フレームから探し出しprocに格納
  6. 'xを評価しagrlに格納
  7. gにarglを適用して評価し、返り値をvalに格納
  8. 3でスタックに退避したarglを復元
  9. arglに7のvalの値を追加
  10. 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 で
    • envをスタックに退避
    • 演算子をexp、非演算子をunevに格納して、eval-dispatchへ
  • eval-dispatchで
    • expに格納されて演算子の手続きを環境フレームから探してev-appl-did-operatorへ
  • ev-appl-did-operatorで
    • unenvとenvをスタックから復元
    • 空の引数リストをarglに、演算子の手続きをprocに格納
    • procとarglをスタックに退避
    • 最初の非演算子をexpへ格納
    • envとunevをスタックにをスタックに退避し、eval-dispatchへ

以降はこの流れの繰り返しで、非演算子の評価が進んでいく。

さらに、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読書ノート」の目次はこちら

SICP 読書ノート#75 - 5.4 積極制御評価機 (pp.327-338)

SICP Scheme

積極制御評価機 (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読書ノート」の目次はこちら

SICP 読書ノート#74 - 5.3 記憶の割当てとごみ集め (pp.319-327)

SICP Scheme

「§5.3 記憶の割当てとごみ集め」から。以下を順に読みました。

  • ベクターとしてのメモリ
    • Lispデータの表現
    • 基本リスト演算の実装
    • スタックの実装
  • 無限メモリーの幻想の維持
    • ストップアンドコピーごみ集めの実装

メモリ管理とガベージコレクションの話。無限メモリーを実現できれば、 それはチューリング完全を意味するけど、実際は有限のメモリーしか持てないので ガベージコレクションで近似しましょう、みたいな話と理解。

仕事でもとある処理系を拡張したりしているけど、 いつGCを走らせるかは難しい課題だったりする。

ストップアンドコピーごみ集めも概要は理解できたので、次へ進みます。

※「SICP読書ノート」の目次はこちら

SICP 読書ノート#73 - 5.2 レジスタ計算機シミュレータ(2) (pp.318-319)

SICP Scheme

「§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

これまでのまとめ的な問題。要件をかみくだくと、以下のことができればよさそう。

まずは、ブレークポイントの管理する変数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 記憶の割当てとごみ集め」から。

※「SICP読書ノート」の目次はこちら

SICP 読書ノート#72 - 5.2 レジスタ計算機シミュレータ(1) (pp.306-317)

SICP Scheme

テキストを読んでも文字ばかりで全然頭に入ってこないので、まずはシミュレータをがっと実装した。

https://github.com/uents/sicp/blob/master/ch5-register-simulator

いつものようにRacketで動かせるように修正してます。 他にもデバッグのために実行手続きは名前付きにしたりとちょこちょこ変えてます。

シミュレータの概要

インターフェースとしては、マシンの構築、レジスタへのアクセサ、マシンの実行からなる。

マシンの構築

レジスタ、演算手続き、コントローラ命令列からなるマシンを構築しそれを返す。

(make-machine <register-names> <operations> <controller>)

レジスタへのアクセサ

マシンのレジスタに対するsetter, getterがある。

(set-register-contents! <machine-model> <register-name> <value>)
(get-register-contents! <machine-model> <register-name>)

マシンの実行

マシンの実行をシミュレートする。 コントローラ命令列の初めから開始し、最後まで実行すると終了する。

(start <machine-model>)

シミュレータを実行した時の結果はこんな感じ。

> (define gcd-machine
    (make-machine
     '(a b t) ;; register names
     (list (list 'rem remainder) (list '= =)) ;; operations
     '(test-b ;; controller instruction sequence
       (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)))

  #=> 命令シーケンス(アセンブルされたコントローラ命令列)を出力させるとこんな感じ
  (list
    (mcons '(test (op =) (reg b) (const 0)) #<procedure:test-proc>)
    (mcons '(branch (label gcd-done)) #<procedure:branch-proc>)
    (mcons '(assign t (op rem) (reg a) (reg b)) #<procedure:assign-proc>)
    (mcons '(assign a (reg b)) #<procedure:assign-proc>)
    (mcons '(assign b (reg t)) #<procedure:assign-proc>)
    (mcons '(goto (label test-b)) #<procedure:goto-label-proc>))

> gcd-machine
#<procedure:dispatch>

> (set-register-contents! gcd-machine 'a 206)
'done

> (set-register-contents! gcd-machine 'b 40)
'done

> (start gcd-machine)
'done

> (get-register-contents gcd-machine 'a)
2

処理の流れをフローで書いてみる。

image

(make-machine)および(start <machine-model>)の処理は、 それぞれ次のようになるかと思う。

  • (make-machine)
    1. 与えられたコントローラ命令列をアセンブラ(assemble)に通して 命令シーケンス(instrcution sequence)に変換
    2. 命令シーケンスはいったんthe-instruction-sequenceというレジスタにset
  • (start <machine-model>)
    1. the-instruction-sequenceレジスタの内容をpcレジスタにset
    2. (execute)という手続きを実行し、pcレジスタから 命令シーケンスの先頭の実行手続きを取り出し、(instruction-exec-proc)で実行
    3. 実行手続きの最後で(advance-pc)という手続きを実行し、 残りの命令シーケンスをpcレジスタにset
    4. 再び(execute)を実行。以下2〜4の繰り返し

ただしbranchおよびgoto命令は、以下の命令シーケンスを pcレジスタにsetして(execute)を実行する

  • branch命令は、flagレジスタ(test命令の実行結果が格納される)がtrueの場合、 ラベルに紐づく命令シーケンスをpcレジスタにset
  • goto命令は、与えられたラベルまたはレジスタの内容をpcレジスタにset

また、アセンブルのフェーズでラベルを発見すると、 ラベルのシンボルとそれに続く命令シーケンスを対にして保持することで、 ラベルの管理を行っている。

問題 5.8

ラベルが重複しているコントローラ命令を与えるとどう振る舞うか？

racket@> ,enter "regsim.scm"
'(REGISTER SIMULATOR LOADED)

racket@regsim.scm> (define test-machine
                     (make-machine
                      '(a)
                      '()
                      '(start
                        (goto (label here))
                        here
                        (assign a (const 3)) (goto (label there))
                        here
                        (assign a (const 4)) (goto (label there))
                        there)))
racket@regsim.scm> (start test-machine)
'done

racket@regsim.scm> (get-register-contents test-machine 'a)
3

2つ目のhereへは処理が映らないから、結果は3になる。

ラベルの重複を許さないようにするには (extract-labels)でチェック処理を追加すればよい。こんな感じかな。

diff --git a/ch5-register-simulator/regsim.scm b/ch5-register-simulator/regsim.scm
index 8ec7d87..af416ad 100644
--- a/ch5-register-simulator/regsim.scm
+++ b/ch5-register-simulator/regsim.scm
@@ -138,9 +138,11 @@
                       (lambda (insts labels)
                         (let ((next-inst (car ctrl-text)))
                           (if (symbol? next-inst)
-                              (recieve insts
-                                       (cons (make-label-entry next-inst insts)
-                                             labels))
+                              (if (label-insts labels next-inst)
+                                  (error "[extract-labels] duplicate label:" next-inst)
+                                  (recieve insts
+                                           (cons (make-label-entry next-inst insts)
+                                                 labels)))
                               (recieve (cons (make-instruction next-inst)
                                              insts)
                                        labels)))))))
@@ -178,8 +180,11 @@
 (define (make-label-entry label-name insts)
   (cons label-name insts))

+(define (label-insts labels label-name)
+  (assoc label-name labels))
+
 (define (lookup-label labels label-name)
-  (let ((val (assoc label-name labels)))
+  (let ((val (label-insts labels label-name)))
        (if val
                (cdr val)
                (error "[lookup-label] undefined label:" label-name))))

問題 5.9

オリジナルの実装のままだとマシンはラベルに対しても演算しようとするらしい。試してみる。

racket@regsim.scm> (define test-machine
                     (make-machine
                      '(a)
                      (list (list '+ +))
                      '(test
                        (assign a (op +) (const 1) (label test)))))

racket@regsim.scm> (start test-machine)
+: contract violation
  expected: number?
  given: (list (mcons '(assign a (op +) (const 1) (label test)) #<procedure:assign-proc>))
  argument position: 2nd
  other arguments...:
   1
  context...:
   /Users/uents/work/sicp/ch5-register-simulator/regsim.scm:222:8: assign-proc
   /Users/uents/work/sicp/ch5-register-simulator/regsim.scm:47:8: dispatch
   /opt/homebrew-cask/Caskroom/racket/6.1.1/Racket v6.1.1/collects/racket/private/misc.rkt:87:7

そこで、アセンブルの段階でオペランドのチェックをするようにした。

diff --git a/ch5-register-simulator/regsim.scm b/ch5-register-simulator/regsim.scm
index af416ad..60e3432 100644
--- a/ch5-register-simulator/regsim.scm
+++ b/ch5-register-simulator/regsim.scm
@@ -329,7 +329,9 @@
 (define (make-operation-exp exp machine labels ops)
   (let ((op (lookup-prim (operation-exp-op exp) ops))
                (procs (map (lambda (exp)
-                                         (make-primitive-exp exp machine labels))
+                      (if (label-exp? exp)
+                          (error "[make-operation-exp] cannot use label:" + exp)
+                          (make-primitive-exp exp machine labels)))
                                        (operation-exp-operands exp))))
        (define (op-proc)
          (apply op (map (lambda (proc) (proc)) procs)))

マシンを作成するとアセンブルの段階で中断する。

racket@regsim.scm> (define test-machine
                     (make-machine
                      '(a)
                      (list (list '+ +))
                      '(test
                        (assign a (op +) (const 1) (label test)))))
[make-operation-exp] cannot use label: #<procedure:+> (label test)
  context...:
   /opt/homebrew-cask/Caskroom/racket/6.1.1/Racket v6.1.1/collects/racket/private/map.rkt:26:19: loop
   /Users/uents/work/sicp/ch5-register-simulator/regsim.scm:329:0: make-operation-exp
   /Users/uents/work/sicp/ch5-register-simulator/regsim.scm:216:0: make-assign
   /opt/homebrew-cask/Caskroom/racket/6.1.1/Racket v6.1.1/collects/racket/private/map.rkt:53:19: loop
   /Users/uents/work/sicp/ch5-register-simulator/regsim.scm:128:34
   /Users/uents/work/sicp/ch5-register-simulator/regsim.scm:3:0: make-machine
   /opt/homebrew-cask/Caskroom/racket/6.1.1/Racket v6.1.1/collects/racket/private/misc.rkt:87:7

問題 5.10-13 はパスで。

次は「§5.2.4 計算機の性能の監視」から。

※「SICP読書ノート」の目次はこちら