プログラミング再入門

プログラミングをもう一度ちゃんと勉強する読書ノート

SICP 5.3 Storage Allocation and Garbage Collection

LISP Scheme

ノート

レジスタマシンとしてのScheme評価器を実装する前に、メモリ割り当てに関する問題を片付けておく。
一つの問題はペア（セル）をどう表現するのか。もう一つの問題は実際には有限のメモリサイズをあたかも無限にあるかの様に見せる技術。

5.3.1 Memory as Vectors

メモリは小さな情報を格納出来る容器の並びで、

  • それぞれはアドレス（あるいはロケーション）で特定する事が出来る
  • アドレスもメモリに格納する事が出来る
  • アドレスは算術演算できる

事が要求されている。

vector-ref、vector-set!はSchemeの標準として定義されている。

Representing Lisp data

ベクタを使ってcarだけのベクタ、cdrだけのベクタを作る。
それぞれの要素には基本的にはポインタが入るが、セルへのポインタ（p）、数値（n）、ヌルポインタ（e）等の肩を表すタグを用いる。シンボルもそれ用のタグを付けて各文字をリストとして保存するものと思われる。

Implementing the primitive list operations

前節までに実装したレジスタマシンのプリミティブとしてvector-ref、vector-set!を登録すると、car、cdrを参照する、あるいはそれらに保存する命令を実装出来る。
また、cons、eq?も実装可能。

Implementing stacks

スタックの走査、saveとrestoreもthe-stackと言うベクタへの操作として実装出来る。

Exercise 5.20


Index 0 1 2 3
the-cars n1 p1 p1
the-cdrs n2 p3 e0

結果としての各ポインターの値

free 4
x 1
y 2
Exercise 5.21

話の流れからすると、vector-set!やvector-refをプリミティブとして実装する事になりそうだが、

Assume that the list-structure memory operations are available as machine primitives.

と言うのは、car、cdr等がプリミティブとして用意されていて、vector-set!、vector-ref等は使わなくて良いと読める。YouTubeにアップロードされているMITのSICPの講義を見てもvectorを使った具体的なリストの実装には言及していないので、ここでは単に今までの様に数値を扱うのではなくリストを扱う手続きを定義する演習であると解釈する。

make-machineでmake-vectorを呼んでthe-cars、the-cdrsを作ったとしてもstart-machineを呼び出す前にレジスタの中身を設定するのはかなりややこしい話になる。なのでこの部分はベースとなるLispシステムのリストを素直に使うものと仮定する。

今までの例では手続き呼び出しのパターンとしては

  1. 最初に引数となる変数に初期値を保存してスタート
  2. レジスタcontinueは手続きから戻るべきラベルを保存する
  3. なので最初の呼び出しから戻った時には終了するので最後のラベルをcontinueに保存する
  4. ここから手続きの本体に傾れ込むかgotoでジャンプする

次に手続きを呼び出す時に

  1. 保存しておきたいレジスタを一旦スタックに保存する
  2. continueに戻る場所としてのラベルを設定する
  3. 引数として渡す為のレジスタを設定
  4. 呼び出す手続きのラベルにジャンプする
  5. 戻って来たら、保存していたレジスタを復元する

a.
足し算の引数としての値を保存するレジスタa、pairの結果を保存する為のレジスタp、手続きの戻り値としてレジスタretを使う事にする。

  1. treeに初期値を設定してスタート（ここはマシンの定義の外）
  2. スタックを初期化
  3. ラベルdoneをレジスタcontinueに保存

count-leaves本体

  1. retに0を保存
  2. treeが空かチェック
  3. 空なら「リターン処理」にジャンプ
  4. retに1を保存
  5. treeがペアか否かの結果をレジスタpに保存
  6. レジスタpにnotを適用した結果をチェック
  7. pが偽だったら「リターン処理」にジャンプ
  8. 保存しておきたいレジスタ（treeとcontinue）をスタックに保存
  9. treeのcarをtreeに設定
  10. continueを「戻る場所その１」を設定
  11. count-leavesにジャンプ

戻る場所その１

  1. 保存しておいたレジスタ（continueとtree）を復元
  2. retの値をaに保存
  3. 保存しておきたいレジスタ（treeとaとcontinue）をスタックに保存
  4. treeのcdrをtreeに設定
  5. continueを「戻る場所その２」を設定
  6. count-leavesにジャンプ

戻る場所その２

  1. 保存しておいたレジスタ（continueとaとtree)を復元
  2. retの値とaの値を足してretに保存する

リターン処理

  1. continueに入っているラベル時ジャンプ

continueのスタックへの保存と復元とか冗長な部分が多少あるが、こんな感じ。

(define count-leaves-machine
  (make-machine
   (list (list 'null? null?)
         (list 'pair? pair?)
         (list 'not not)
         (list 'car car)
         (list 'cdr cdr)
         (list '+ +))
   '((perform (op initialize-stack))
     (assign continue (label done))
     count-leaves
     (assign ret (const 0))
     (test (op null?) (reg tree))
     (branch (label return))
     (assign ret (const 1))
     (assign p (op pair?) (reg tree))
     (test (op not) (reg p))
     (branch (label return))
     (save tree)
     (assign tree (op car) (reg tree))
     (save continue)
     (assign continue (label after-car))
     (goto (label count-leaves))
     after-car
     (restore continue)
     (restore tree)
     (assign a (reg ret))
     (save a)
     (save tree)
     (assign tree (op cdr) (reg tree))
     (save continue)
     (assign continue (label after-cdr))
     (goto (label count-leaves))
     after-cdr
     (restore continue)
     (restore tree)
     (restore a)
     (assign ret (op +) (reg a) (reg ret))
     return
     (goto (reg continue))
     done
     )))

実行結果

> (set-register-contents! count-leaves-machine 'tree '())
'done
> (start count-leaves-machine)
'done
> (get-register-contents count-leaves-machine 'ret)
0
> (set-register-contents! count-leaves-machine 'tree '(1))
'done
> (start count-leaves-machine)
'done
> (get-register-contents count-leaves-machine 'ret)
1
> (set-register-contents! count-leaves-machine 'tree '(1 2 3))
'done
> (start count-leaves-machine)
'done
> (get-register-contents count-leaves-machine 'ret)
3
> (set-register-contents! count-leaves-machine 'tree '((1 2) (3 4) 5))
'done
> (start count-leaves-machine)
'done
> (get-register-contents count-leaves-machine 'ret)
5
>

b.
アキュムレータとしてレジスタnを使うパターン。
今回は一工夫をしてレジスタretを使わずにnだけで関数値を表現する。その代わり、treeがペアでなかった時の演算を条件判断の前には出来ないのでリターンする直前に行う様にジャンプ先を変更。

  1. treeに初期値を設定してスタート（ここはマシンの定義の外）
  2. スタックを初期化
  3. nに0を保存
  4. ラベルdoneをレジスタcontinueに保存

count-iter本体

  1. treeが空かチェック
  2. 空なら「リターン処理」にジャンプ
  3. treeがペアか否かの結果をレジスタpに保存
  4. レジスタpにnotを適用した結果をチェック
  5. pが偽だったら「足し算（してリターン）」にジャンプ
  6. 保存しておきたいレジスタ（treeとcontinueのみ、nは保存する必要なし）をスタックに保存
  7. treeのcarをtreeに設定
  8. continueを「戻る場所その１」を設定
  9. count-iterにジャンプ

戻る場所

  1. 保存しておいたレジスタ（continueとtree）を復元
  2. （※この後はレジスタを保存しておく必要なし）
  3. treeのcdrをtreeに設定
  4. count-iterにジャンプ

足し算（してリターン）

  1. nにn+1を保存

リターン処理

  1. continueに入っているラベル時ジャンプ
(define count-leaves-machine
  (make-machine
   (list (list 'null? null?)
         (list 'pair? pair?)
         (list 'not not)
         (list 'car car)
         (list 'cdr cdr)
         (list '+ +))
   '((perform (op initialize-stack))
     (assign n (const 0))
     (assign continue (label done))
     count-iter
     (test (op null?) (reg tree))
     (branch (label return))
     (assign p (op pair?) (reg tree))
     (test (op not) (reg p))
     (branch (label return-plus-1))
     (save tree)
     (assign tree (op car) (reg tree))
     (save continue)
     (assign continue (label after-car))
     (goto (label count-iter))
     after-car
     (restore continue)
     (restore tree)
     (assign tree (op cdr) (reg tree))
     (goto (label count-iter))
     return-plus-1
     (assign n (op +) (reg n) (const 1))
     return
     (goto (reg continue))
     done
     )))

動作

> (set-register-contents! count-leaves-machine 'tree '())
'done
> (start count-leaves-machine)
'done
> (get-register-contents count-leaves-machine 'n)
0
> (set-register-contents! count-leaves-machine 'tree '(1))
'done
> (start count-leaves-machine)
'done
> (get-register-contents count-leaves-machine 'n)
1
> (set-register-contents! count-leaves-machine 'tree '(1 2 3))
'done
> (start count-leaves-machine)
'done
> (get-register-contents count-leaves-machine 'n)
3
> (set-register-contents! count-leaves-machine 'tree '((1 2) (3 4) 5))
'done
> (start count-leaves-machine)
'done
> (get-register-contents count-leaves-machine 'n)
5
>
Exercise 5.22

Exercise 3.12でのappendの定義は

(define (append x y)
  (if (null? x)
      y
      (cons (car x) (append (cdr x) y))))

同じ様な考え方でappend-machineを設計すると

(define append-machine
  (make-machine
   (list (list 'null? null?)
         (list 'car car)
         (list 'cdr cdr)
         (list 'cons cons))
   '((perform (op initialize-stack))
     (assign continue (label done))
     append
     (assign ret (reg y))
     (test (op null?) (reg x))
     (branch (label return))
     (save x)
     (assign x (op cdr) (reg x))
     (save continue)
     (assign continue (label after-call))
     (goto (label append))
     after-call
     (restore continue)
     (restore x)
     (assign x (op car) (reg x))
     (assign ret (op cons) (reg x) (reg ret))
     return
     (goto (reg continue))
     done
     )))

動作させてみる

> (set-register-contents! append-machine 'x '())
'done
> (set-register-contents! append-machine 'y '())
'done
> (start append-machine)
'done
> (get-register-contents append-machine 'ret)
'()
> (set-register-contents! append-machine 'x '(1))
'done
> (set-register-contents! append-machine 'y '())
'done
> (start append-machine)
'done
> (get-register-contents append-machine 'ret)
'(1)
> (set-register-contents! append-machine 'x '())
'done
> (set-register-contents! append-machine 'y '(2))
'done
> (start append-machine)
'done
> (get-register-contents append-machine 'ret)
'(2)
> (set-register-contents! append-machine 'x '(1))
'done
> (set-register-contents! append-machine 'y '(2))
'done
> (start append-machine)
'done
> (get-register-contents append-machine 'ret)
'(1 2)
> (set-register-contents! append-machine 'x '(1 2))
'done
> (set-register-contents! append-machine 'y '(3 4))
'done
> (start append-machine)
'done
> (get-register-contents append-machine 'ret)
'(1 2 3 4)
> (set-register-contents! append-machine 'x '(1 2))
'done
> (set-register-contents! append-machine 'y '((3 4)))
'done
> (start append-machine)
'done
> (get-register-contents append-machine 'ret)
'(1 2 (3 4))
>

append!の定義は

(define (append! x y)
  (set-cdr! (last-pair x) y)
  x)

(define (last-pair x)
  (if (null? (cdr x))
      x
      (last-pair (cdr x))))

set-cdr!を使うのにset-mcdr!を使うので少しトリッキー。set-mcdr!は値を返さないのでperformを使う。また、最初に引数として与えたレジスタxが指しているペアをそのまま返す為に、最初にxの値をスタックに保存して、最後に復元して戻る。

(define append!-machine
  (make-machine
   (list (list 'null? null?)
         (list 'cdr mcdr)
         (list 'set-cdr! set-mcdr!))
   '((perform (op initialize-stack))
     (save x)
     (assign continue (label done))
     last-pair
     (assign ret (reg x))
     (assign x (op cdr) (reg x))
     (test (op null?) (reg x))
     (branch (label return))
     (goto (label last-pair))
     return
     (goto (reg continue))
     done
     (perform (op set-cdr!) (reg ret) (reg y))
     (restore x)
     )))

動作確認も一工夫。mpairが返って来て結果が見にくいのでdisplayを使って表示する。

> (set-register-contents! append!-machine 'x (mcons 1 '()))
'done
> (set-register-contents! append!-machine 'y (mcons 2 '()))
'done
> (start append!-machine)
'done
> (display (get-register-contents append!-machine 'x))
{1 2}
> (set-register-contents! append!-machine 'x (mcons 1 (mcons 2 '())))
'done
> (set-register-contents! append!-machine 'y (mcons 3 (mcons 4 '())))
'done
> (start append!-machine)
'done
> (display (get-register-contents append!-machine 'x))
{1 2 3 4}
>
5.3.2 Maintaining the Illusion of Infinite Memory

最も（？）シンプルなガーベッジコレクションのstop-and-copy方式の説明。

Implementation of a stop-and-copy garbage collector

the-carsとthe-cdrsのベクタのペアを２セット用意していて、セルが無くなるまではその片方を使用する。consしようとして現在使用中のペアのセルを使い切っていた場合には、rootから辿れる全てのセルをもう片方のペアの方にコピーする。そうするとrootからアクセス出来ないゴミはコピーされないため、コピー後のペアには空きが出来る筈。

セルをコピーする際には元載せるにはコピーが済んでいる目印とコピー先のアドレスを書き込んでおく。ポインタを辿ってセルをコピーして行く際にはコピーされたセルに入っているポインタはまだ以前のアドレスを指している。ポインタの先がまだコピーされていなければそれをコピーしてポインタも更新する。ポインタの先が既にコピーされていたら新しいアドレスでポインタを更新する。

SICP 5.2.4 Monitoring Machine Performance

LISP Scheme

ノート

パフォーマンスを測る為の仕組みをシミュレータに組み込む。

Exercise 5.14

0を入力すると終了する様にfactorial-machineを改造して実行する。

> (define factorial-machine
  (make-machine
   (list (list '= =)
         (list '- -)
         (list '* *)
         (list 'read read)
         (list 'print print)
         (list 'display display)
         (list 'newline newline))
   '(controller
     fact-start
     (perform (op initialize-stack))
     (perform (op display) (const "Input n :"))
     (assign n (op read))
     (test (op =) (reg n) (const 0))
     (branch (label fact-exit))
     (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
     (assign val (const 1))
     (goto (reg continue))
     fact-done
     (perform (op print) (reg val))
     (perform (op print-stack-statistics))
     (perform (op newline))
     (goto (label fact-start))
     fact-exit)))
> (start factorial-machine)
Input n :3
6
(total-pushes = 4 maximum-depth = 4)
Input n :4
24
(total-pushes = 6 maximum-depth = 6)
Input n :5
120
(total-pushes = 8 maximum-depth = 8)
Input n :6
720
(total-pushes = 10 maximum-depth = 10)
Input n :0
'done
>

ここから読み取れるのは、total-pushes=maximum-depth=2(n-1)と言う事。

Exercise 5.15

実行した命令の数を数える機能を追加する。

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (num-instruction-executed 0))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))
                 (list 'reset-num-instruction-executed
                       (lambda () (set! num-instruction-executed 0)))
                 (list 'print-num-instruction-executed
                       (lambda () (display num-instruction-executed)(display " instructions executed.")(newline)))))
…中略
      (define (execute)
        (set! num-instruction-executed (+ num-instruction-executed 1))
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
                (execute)))))
…以下省略

実行結果はこんな感じ。

> (define factorial-machine
  (make-machine
   (list (list '= =)
         (list '- -)
         (list '* *)
         (list 'read read)
         (list 'print print)
         (list 'display display)
         (list 'newline newline))
   '(controller
     fact-start
     (perform (op initialize-stack))
     (perform (op reset-num-instruction-executed))
     (perform (op display) (const "Input n :"))
     (assign n (op read))
     (test (op =) (reg n) (const 0))
     (branch (label fact-exit))
     (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
     (assign val (const 1))
     (goto (reg continue))
     fact-done
     (perform (op print) (reg val))
     (perform (op print-stack-statistics))
     (perform (op newline))
     (perform (op print-num-instruction-executed))
     (perform (op newline))
     (goto (label fact-start))
     fact-exit)))
> (start factorial-machine)
Input n :3
6
(total-pushes = 4 maximum-depth = 4)
35 instructions executed.

Input n :4
24
(total-pushes = 6 maximum-depth = 6)
46 instructions executed.

Input n :5
120
(total-pushes = 8 maximum-depth = 8)
57 instructions executed.

Input n :0
'done
>
Exercise 5.16

本当はexecuteの実装とトレースの為のコードは分離したい所だが、この作りでは仕方ないか。

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (num-instruction-executed 0)
        (trace false))
…中略
      (define (execute)
        (set! num-instruction-executed (+ num-instruction-executed 1))
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                (if trace
                    (begin
                      (display (instruction-text (car insts)))(newline))
                    'done)
                ((instruction-execution-proc (car insts)))
                (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 'trace-on) (set! trace true))
              ((eq? message 'trace-off) (set! trace false))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

実行結果

> (define fib-machine
  (make-machine
   (list (list '< <)
         (list '- -)
         (list '+ +))
   '(controller
     (perform (op initialize-stack))
     (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 4)
'done
> (fib-machine 'trace-on)
> (start fib-machine)
(perform (op initialize-stack))
(assign continue (label fib-done))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(assign val (reg n))
(goto (reg continue))
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(assign val (reg n))
(goto (reg continue))
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(assign val (reg n))
(goto (reg continue))
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(assign val (reg n))
(goto (reg continue))
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(assign val (reg n))
(goto (reg continue))
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
'done
> (get-register-contents fib-machine 'val)
3
> (set-register-contents! fib-machine 'n 4)
'done
> (fib-machine 'trace-off)
> (start fib-machine)
'done
> (get-register-contents fib-machine 'val)
3
>
Exercise 5.17

まず問題の解釈だが、「immediately precede that instruction」は「それより前方の最も近いラベル」ではなく「シーケンスの一つ前にあるラベル」と解釈する。なので直前にラベルがある命令の時にだけラベルが印字されて、それ以外は命令だけが印字される。

現状ラベルは、ラベル名とその次の命令へのポインタのペアのリストをextract-labelsで作って、make-gotoなどで各命令用に作成されるクロージャから参照されている。つまり命令リスト側からラベルリストを参照するのはちょっと難しそう。なので命令リスト側にラベルへの参照を持たせる事にする。

まずは命令の構造をテキストと手続きのペアだった所を、テキスト・手続き・ラベルとinstructionのペアと言う3つの要素のタプルにする。

(define (instruction-execution-proc inst)
  (mcar (mcdr inst)))
(define (set-instruction-execution-proc! inst proc)
  (set-mcdr! inst (mcons proc null)))
(define (set-label-on-instruction! inst label)
  (set-mcdr! (mcdr inst) label))
(define (label-on-instruction inst)
  (mcdr (mcdr inst)))

次に、ラベルに対応する命令にラベルの情報を追加する。

(define (update-insts! insts labels machine)
  (let ((pc (get-register machine 'pc))
        (flag (get-register machine 'flag))
        (stack (machine 'stack))
        (ops (machine 'operations)))
    (for-each
     (lambda (inst)
       (set-instruction-execution-proc! 
        inst
        (make-execution-procedure
         (instruction-text inst) labels machine
         pc flag stack ops)))
     insts)
    (for-each
     (lambda (label)
       (if (not (null? (cdr label)))
           (set-label-on-instruction! (cadr label) (car label))
           'done))
     labels)))

トレースを表示する部分の変更。

      (define (execute)
        (set! num-instruction-executed (+ num-instruction-executed 1))
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                (if trace
                    (let ((label (label-on-instruction (car insts))))
                      (if (not (null? label))
                          (begin
                            (display label)
                            (newline))
                          'done)
                      (display (instruction-text (car insts)))
                      (newline))
                    'done)
                ((instruction-execution-proc (car insts)))
                (execute)))))

実行結果。

> (define fib-machine
  (make-machine
   (list (list '< <)
         (list '- -)
         (list '+ +))
   '(controller
     (perform (op initialize-stack))
     (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 4)
'done
> (fib-machine 'trace-on)
> (start fib-machine)
controller
(perform (op initialize-stack))
(assign continue (label fib-done))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
'done
>

このフォーマットでの欠点は命令シーケンスの最後がラベルだった時に、それを表示出来ない事。
それも表示する為にはラベルも一つの命令とみなして何もせずにpcを進めて、実行した命令の数をカウントしない様な処理が必要となるが、トレースを出す為にそこに手を入れるのにはやや抵抗があるので難しい選択である。

Exercise 5.18

やる事は殆どマシンのトレースと同じ。

(define (make-register name)
  (let ((contents '*unassigned*)
        (trace false))
    (define (set value)
      (if trace
          (begin
            (display "Register: ")
            (display name)(display ", old value=")
            (display contents)(display ", new value=")
            (display value)(newline))
          'done)
      (set! contents value))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set) set)
            ((eq? message 'trace-on) (set! trace true))
            ((eq? message 'trace-off) (set! trace false))
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))

get-register-contentsの様なグローバルな手続きがAPIとして用意されているので、これに合わせて手続きを作成する。

(define (register-trace-on machine register-name)
  ((get-register machine register-name) 'trace-on))
(define (register-trace-off machine register-name)
  ((get-register machine register-name) 'trace-off))

動作確認

> (define fib-machine
  (make-machine
   (list (list '< <)
         (list '- -)
         (list '+ +))
   '(controller
     (perform (op initialize-stack))
     (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 4)
'done
> (register-trace-on fib-machine 'val)
> (start fib-machine)
Register: val, old value=*unassigned*, new value=1
Register: val, old value=1, new value=0
Register: val, old value=0, new value=1
Register: val, old value=1, new value=1
Register: val, old value=1, new value=1
Register: val, old value=1, new value=1
Register: val, old value=1, new value=2
Register: val, old value=2, new value=1
Register: val, old value=1, new value=0
Register: val, old value=0, new value=1
Register: val, old value=1, new value=1
Register: val, old value=1, new value=2
Register: val, old value=2, new value=3
'done
> (get-register-contents fib-machine 'val)
3
> (set-register-contents! fib-machine 'n 4)
'done
> (register-trace-off fib-machine 'val)
> (start fib-machine)
'done
> (get-register-contents fib-machine 'val)
3
>
Exercise 5.19

ひょっとするとExercise 5.17はこれに関連していて、各命令にその前に出て来る最も近いラベルをトレースするべきだったのかも知れない。が、気を取り直して、これはこれで実装する。

問題文の最後に
>
or to remove all breakpoints by means of<
とあるので、ブレークポイントは複数指定出来なければならない。

マシーンにブレークポイントのリストを持って、executeの度にどれかのブレークポイントと一致するかチェックする方法と、命令リストの中にブレークを示すマークか命令を挿入する方法が考えられる。パフォーマンスを考えると後者の方がやや有利か？　毎回の実行で比較が必要となるが、比較対象がリストではないので多数のブレークポイントが存在していても影響を受けない。ただし削除する時には命令リストの走査が必要となる。

ブレークする命令を挿入する方法は、ラベルの直後にブレークポイントを置く場合に問題が生じる。ラベルにジャンプした時にブレークの命令ではなくその次（ラベル直後の）命令に飛んでしまうので止められない。これを避けるにはラベル直後にブレークポイントを置く場合にはラベルの情報も更新する必要がある。ブレークポイントを削除する場合は更に厄介。

なので命令の中にブレークを示すマークを挿入する方法をとる。

(define (set-label-on-instruction! inst label)
  (let ((last (mcdr inst)))
    (if (null? (mcdr last))
        (set-mcdr! last (make-hash (list (cons 'label label))))
        (hash-set! (mcdr last) 'label label))))
(define (label-on-instruction inst)
  (let ((last (mcdr inst)))
    (if (null? (mcdr last))
        null
        (hash-ref (mcdr last) 'label))))
(define (set-break-on-instruction! inst)
  (let ((last (mcdr inst)))
    (if (null? (mcdr last))
        (set-mcdr! last (make-hash (list (cons 'break '()))))
        (hash-set! (mcdr last) 'break '()))))
(define (break? inst)
  (let ((last (mcdr inst)))
    (cond ((null? (mcdr last)) false)
          ((hash-ref (mcdr last) 'break false) true)
          (else
           false))))
(define (cancel-break-on-instruction! inst)
  (let ((last (mcdr inst)))
    (if (null? (mcdr last))
        inst
        (hash-remove! (mcdr last) 'break))))

前の問題の解答としてラベルを命令のリストの最後の要素のcdrに入れていたが、これをハッシュに変更する。
キーlabelに対してラベル名、キーbreakに対しては値は無し。

これを使って命令にブレークポイントのマークを埋め込む。

(define (make-new-machine)
…
      (define (find-instruction insts label n)
        (define (proceed-to-inst m insts)
          (cond ((null? insts) 'not-found)
                ((= m 1) (car insts))
                (else
                 (proceed-to-inst (- m 1) (cdr insts)))))
        (define (proceed-to-label insts)
          (if (null? insts)
              'not-found
              (if (eq? label (label-on-instruction (car insts)))
                  (proceed-to-inst n insts)
                  (proceed-to-label (cdr insts)))))
        (proceed-to-label the-instruction-sequence))
      (define (set-break-point label n)
        (let ((inst (find-instruction the-instruction-sequence label n)))
          (if (eq? inst 'not-found)
              inst
              (set-break-on-instruction! inst))))
      (define (cancel-break-point label n)
        (let ((inst (find-instruction the-instruction-sequence label n)))
          (if (eq? inst 'not-found)
              inst
              (cancel-break-on-instruction! inst))))
      (define (cancel-all-break-points)
        (define (cancel-break-points insts)
          (cond ((null? insts) 'done)
                ((break? (car insts)) (cancel-break-on-instruction! (car insts)) (cancel-break-points (cdr insts)))
                (else
                 (cancel-break-points (cdr insts)))))
        (cancel-break-points the-instruction-sequence))
…
              ((eq? message 'set-break-point) set-break-point)
              ((eq? message 'cancel-break-point) cancel-break-point)
              ((eq? message 'cancel-all-break-points) (cancel-all-break-points))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

全てのブレークポイントを削除する時にはthe-instruction-sequenceを全て走査して削除する。

実行を止める側はexecuteに実装する事になるが少し整理する。

  1. 命令全て完了したか、ブレークポイントであるかをチェック
  2. トレースを出す
  3. 実際に命令を実行する
  4. ループする

をそれぞれ切り出す。
再開する時にはこれらの切り出された手続きを利用する。

(define (make-new-machine)
…
      (define (execute)
        (let ((condition (breaker)))
          (cond ((eq? condition 'done) 'done)
                ((eq? condition 'break) 'break)
                (else
                 (tracer)
                 (execute-an-instruction)
                 (execute)))))
      (define (continue)
        (tracer)
        (execute-an-instruction)
        (execute))
      (define (action-on-instruction action) 
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (action (car insts)))))
      (define (tracer)
        (action-on-instruction (lambda (inst)
                                 (if trace
                                     (let ((label (label-on-instruction inst)))
                                       (if (not (null? label))
                                           (begin
                                             (display label)
                                             (newline))
                                           'done)
                                       (display (instruction-text inst))
                                       (newline))
                                     'done))))
      (define (breaker) 
        (action-on-instruction (lambda (inst)
                                 (if (break? inst)
                                     'break
                                     'continue))))
      (define (execute-an-instruction) 
        (action-on-instruction (lambda (inst)
                                 (set! num-instruction-executed (+ num-instruction-executed 1))
                                 ((instruction-execution-proc inst)))))
…
      (define (dispatch message)
        (cond ((eq? message 'start)
…
              ((eq? message 'proceed) (continue))
…
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

後はラッパーとしての関数を用意する。

(define (set-break-point machine label n)
  ((machine 'set-break-point) label n))
(define (proceed-machine machine)
  (machine 'proceed))
(define (cancel-break-point machine label n)
  ((machine 'cancel-break-point) label n))
(define (cancel-all-break-points machine)
  (machine 'cancel-all-break-points))

実行してみる。

> (define fib-machine
  (make-machine
   (list (list '< <)
         (list '- -)
         (list '+ +))
   '(controller
     (perform (op initialize-stack))
     (assign continue (label fib-done))
     fib-loop
     (test (op <) (reg n) (const 2))
     (branch (label immediate-answer))
     (save continue)
     (assign continue (label afterfib-n-1))
     (save n)
     (assign n (op -) (reg n) (const 1))
     (goto (label fib-loop))
     afterfib-n-1
     (restore n)
     (restore continue)
     (assign n (op -) (reg n) (const 2))
     (save continue)
     (assign continue (label afterfib-n-2))
     (save val)
     (goto (label fib-loop))
     afterfib-n-2
     (assign n (reg val))
     (restore val)
     (restore continue)
     (assign val
             (op +) (reg val) (reg n)) 
     (goto (reg continue))
     immediate-answer
     (assign val (reg n))
     (goto (reg continue))
     fib-done)))
> (set-break-point fib-machine 'fib-loop 1)
> (set-register-contents! fib-machine 'n 5)
'done
> (fib-machine 'trace-on)
> (start fib-machine)
controller
(perform (op initialize-stack))
(assign continue (label fib-done))
'break
>

トレースは実行した命令を表示しているので、少し分かりにくいが一応意図した所で止まっている。

> (get-register-contents fib-machine 'n)
5
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
'break
>

実行を再開してまた同じ所で止まる。以下続けると。

> (get-register-contents fib-machine 'n)
4
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
3
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
2
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
1
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
0
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
1
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
2
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
1
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
0
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
3
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
2
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
1
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
0
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
afterfib-n-1
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
'break
> (get-register-contents fib-machine 'n)
1
> (proceed-machine fib-machine)
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer
(assign val (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
'done
>

ここで漸く終了。値を確認。

> (get-register-contents fib-machine 'n)
2
> (get-register-contents fib-machine 'val)
5
>

もう１カ所ブレークポイントを設定して実行する。

> (set-break-point fib-machine 'immediate-answer 2)
> (set-register-contents! fib-machine 'n 5)
'done
> (set-register-contents! fib-machine 'val '*unassigned*)
'done
> (fib-machine 'trace-off)
> (start fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'done
> (get-register-contents fib-machine 'n)
2
> (get-register-contents fib-machine 'val)
5
>

前回は15回だったが、今回は23回ブレークしている。
最初のブレークポイントを削除する。

> (cancel-break-point fib-machine 'fib-loop 1)
> (set-register-contents! fib-machine 'n 5)
'done
> (set-register-contents! fib-machine 'val '*unassigned*)
'done
> (start fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'break
> (proceed-machine fib-machine)
'done
> (get-register-contents fib-machine 'n)
2
> (get-register-contents fib-machine 'val)
5
>

８回ブレークしている。
最初のブレークポイントをもう一度設定した後、全てのブレークポイントを削除して実行する。

> (set-break-point fib-machine 'fib-loop 1)
> (cancel-all-break-points fib-machine)
'done
> (set-register-contents! fib-machine 'n 5)
'done
> (set-register-contents! fib-machine 'val '*unassigned*)
'done
> (start fib-machine)
'done
> (get-register-contents fib-machine 'n)
2
> (get-register-contents fib-machine 'val)
5
>

ブレークせずに実行が完了する。

SICP 5.2.3 Generating Execution Procedures for Instructions

LISP Scheme

ノート

make-execution-procedureはレジスタマシン言語の命令毎のディスパッチャ。各命令毎に実行する為の手続きを返す手続きが定義されている。

Assign instructions

命令に指定されているレジスタ、式をローカル変数に保存して引数無しの手続きを返す。値の部分も命令なので実行して（これも引数無しの手続き）その結果をレジスタに保存する。最後にpcを進める。

advance-pcで更新するpcはまんまポインターとして動作している。現在のpcが指しているリストのcdrをpcに代入。指されている命令リスト側には影響無し。

Test, branch, and goto instructions

make-branchでは

  1. 飛び先のラベルから命令リストの該当する位置をinstに保存
  2. 条件文を実行して結果をflagに保存
  3. flagが真であればpcをinstの位置に変更、偽であればpcを進めて次の命令に移項する手続きを生成する。

make-gotoは

  1. 飛び先がラベルの場合には、命令リストの該当する位置をpcに保存する手続きを
  2. レジスタの場合には、レジスタの内容をpcにコピーする手続き

を生成する。

Other instructions

3つの手続きともほぼ自明。

  • make-saveはレジスタの内容をスタックにpushしてpcを進める手続きを生成する。
  • make-restoreはスタックからpopした内容をレジスタに保存してpcを進める手続きを生成する。
  • make-performは単に手続きを実行してpcを進める手続きを生成する。
Execution procedures for subexpressions

make-primitive-expはassignに対するオペランド、単なるoperationのオペランドとなる値を提供する手続きを生成する。

  • constに対しては、その命令に書いてある値
  • labelに対しては、そのラベルの次の命令への参照
  • regに対してはレジスタに保存されている値

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))

ここの部分。

  1. valの値(v1)をnにコピー
  2. stackの先頭の値(v2)をvalにポップ
  3. continueは兎も角
  4. 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
>

SICP 5.2.1 The Machine Model

LISP Scheme

ここからはシミュレータの解説。モデルとしては完全にオブジェクト指向的。

ノート

make-machineではメッセージパッシングに応答する手続きを作る。つまりメソッドを持ったオブジェクト。実際にはmake-new-machineがオブジェクトを作り、make-machineではそれに対して'allocate-register、'install-operations、'install-instruction-sequenceと言うメッセージを送ってマシンを作っている。それぞれのメッセージは手続きを返す様に実装されている。

Registers

make-registerもオブジェクトとしての手続きを返す。'getと'setのメッセージを受ける。メッセージに対応するメソッドは用意されずディスパッチャに直に書いてある。ローカルな変数contentsにその値を保存する。Racketでもローカルな変数に対してはset!が使える。

The stack

スタックもオブジェクトとしての手続きを返す。'push、'pop、'initializeのメッセージを受ける。メッセージに対応するそれぞれのメソッドが用意されている。データは当然リストで保存する。

The basic machine

これもオブジェクトとしての手続きを返す。

ユーザーが定義するレジスタとは別ににpc（プログラムカウンタ）とflag（testの結果を保存して条件分岐に使用）を用意。レジスタのリストにも予め登録しておく。命令リストにはスタックを初期化する命令を用意する。

'startの時点でpcに命令リストを保存してexecuteを呼び出す。executeではpcのcarを取り出して実行。各命令はinstruction-execution-procが返す手続きとなり、それを実行すると結果としてpcが更新されるので、もう一度executeを呼び出す。命令リスト自体が変更されることは無いので、pcはそのなかのある部分から以降のリストとなる。pcはmake-new-machineのローカル変数だがオブジェクトそのものはレジスタリストから探せるので外部から変更可能。

5.2.2 The Assembler

4.1.7で学んだ様にプログラムの解釈と実行は分離することが出来る。ここでもプログラムを解釈して命令の列に変換してから実行する。

assembleからextract-labelsを呼び出してプログラムを解釈する。assembleがextract-labelsに渡す第二引数が最終的に呼ばれ、その引数instsとlabelsに命令トラベルのリストが渡される。

extract-labelsはプログラムのcarを見て、シンボル（すなわちラベル）だったらラベルのリストに、そうでなければ命令リストにそれぞれ追加する手続きを第二引数としてextract-labelsを再帰呼び出しする。再帰の戻りでリストを構築して、最後にassembleから渡した手続きが呼ばれる。

update-insts!は命令リストの一つ一つに対してmake-execution-procedureを呼び出して、set-instruction-execution-proc!でinstのcdrに手続きを保存する。make-execution-procedureは次節に登場。

Exercise 5.8
(define machine
  (make-machine
   '(a)
   '()
   '(controller
     start
     (goto (label here))
     here
     (assign a (const 3))
     (goto (label there))
     here
     (assign a (const 4))
     (goto (label there))
     there)))

で動かしてみると

> (start machine)
'done
> (get-register-contents machine 'a)
3
>

最初に見つけたhereに飛ぶ。

extract-labelsでラベルを登録する際に既に存在しているかを確認する。

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
       (lambda (insts labels)
         (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)))
               (receive (cons (make-instruction next-inst)
                              insts)
                        labels)))))))

マシンを定義しようとすると

> (define machine
  (make-machine
   '(a)
   '()
   '(controller
     start
     (goto (label here))
     here
     (assign a (const 3))
     (goto (label there))
     here
     (assign a (const 4))
     (goto (label there))
     there)))
. . Multiply defined label:  here
>

エラーで止まる。

SICP 5.2 A Register-Machine Simulator

LISP Scheme

いよいよ本題な感じ。

ノート

Exercise 5.7

実装してみないことには何も分からないので、先の節の実装を写経してシムレータを作成してから実行してみる。
Racketではペアはimmutableでset-cdr!は使えないので、instructionのペアのメソッドを以下の様にmpairを使った実装に差し替える。

(define (make-instruction text)
  (mcons text '()))
(define (instruction-text inst)
  (mcar inst))
(define (instruction-execution-proc inst)
  (mcdr inst))
(define (set-instruction-execution-proc! inst proc)
  (set-mcdr! inst proc))

GCDの例で動作確認

> (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
>

動いていそう。

早速a.の再帰パターン

(define expt-machine-a
  (make-machine
   '(continue b n result)
   (list (list '= =)
         (list '- -)
         (list '* *))
   '(controller
     (assign continue (label expt-done))
     (save continue)
     expt-prep
     (test (op =) (reg n) (const 0))
     (branch (label expt-init))
     (assign n (op -) (reg n) (const 1))
     (assign continue (label expt-calc))
     (save continue)
     (goto (label expt-prep))
     expt-init
     (assign result (const 1))
     (restore continue)
     (goto (reg continue))
     expt-calc
     (assign result (op *) (reg result) (reg b))
     (restore continue)
     (goto (reg continue))
     expt-done)))

実行してみる

> (set-register-contents! expt-machine-a 'b 2)
'done
> (set-register-contents! expt-machine-a 'n 3)
'done
> (start expt-machine-a)
'done
> (get-register-contents expt-machine-a 'result)
8
>

動いた。

b.の繰り返しパターン

(define expt-machine-b
  (make-machine
   '(b n count product)
   (list (list '= =)
         (list '- -)
         (list '* *))
   '(controller
     (assign count (reg n))
     (assign product (const 1))
     expt-iter
     (test (op =) (reg count) (const 0))
     (branch (label expt-done))
     (assign count (op -) (reg count) (const 1))
     (assign product (op *) (reg product) (reg b))
     (goto (label expt-iter))
     expt-done)))

実行してみる

> (set-register-contents! expt-machine-b 'b 2)
'done
> (set-register-contents! expt-machine-b 'n 3)
'done
> (start expt-machine-b)
'done
> (get-register-contents expt-machine-b 'product)
8
>

どちらも一発で動いてくれて少し感動。

SICP 5.1.3 Subroutines

LISP Scheme

ノート

昔懐かしいBASICの世界。共通部分を括り出す。
括り出すステップ：

  1. それぞれのGCD計算部分の先頭にgcd-1、gcd-2のラベル、GCD計算部分を抜けた所にafter-gcd-1、after-gcd-2のラベルをつけている状態
  2. レジスタはGCDの計算区間でしか使用しないので共通のa、b、tを使用する
  3. レジスタcontinueにIDとなる数字を入れて、共通のラベルgcdに飛び、GCDの計算が終わった所でcontinueの値を見てafter-gcd-1かafter-gcd-2に飛ぶ
  4. レジスタにラベルを代入出来る事にして、レジスタcontinueにafter-gcd-1あるいはafter-gcd-2を代入する事でGCD計算が終わった部分を一般化

これで取り敢えずGCDの部分のコードに呼び出しもと依存の部分が無くなるが、レジスタcontinueが一つしか無いとGCDからサブルーチン（例えばrem）を呼び出す事が出来ない。と言う事で次節に繋がる。

5.1.4 Using a Stack to Implement Recursion

GCDは末尾再帰になっているがfactorialは(n-1)!を計算した後に掛け算が必要。末尾再帰であればレジスタをそのまま再利用出来るので単純なループで表現出来たが、factorialの場合は(n-1)!を計算している間もnは保持しておかなければならない。と言う事はfactorialの
factorialの計算をマシンで実現しようとするとfactorialマシンが無限に必要になってしまう。

物理的なマシンを再帰の度に再利用するにはレジスタの値を一旦退避して、あとから必要になった時に復元出来る仕組み＝スタックが必要。ここでは階乗を計算する値nとプログラム上の戻るべき場所（ラベル）continueをスタックにセーブする。

A double recursion

例示されているfibonacciマシンを図にしてみると

こんな感じか。

Exercise 5.4

a. 再帰の復路で計算するパターン
exptの戻り値を入れるレジスタをresultとすると、

  1. 再帰の度にnを一つずつ減らす
  2. nが0になったらresultを1で初期化して、再帰から戻り始める
  3. 再帰を戻る度にresultにbを掛けて代入する

nは実はresultの計算とは殆ど関係無くて、再帰する回数を決めているだけ。スタックには計算終了のラベルの次に、掛け算をする場所のラベルをn個積む事になる。

'(controller
  (assign continue (label expt-done))
  (save continue)
  expt-prep
  (test (op =) (reg n) (const 0))
  (branch (label expt-init))
  (assign n (op -) (reg n) (const 1))
  (assign continue (label expt-calc))
  (save continue)
  (goto (label expt-prep))
  expt-init
  (assign result (const 1))
  (restore continue)
  (goto (reg continue))
  expt-calc
  (assign result (op *) (reg result) (reg b))
  (restore continue)
  (goto (reg continue))
  expt-done)

b. 再帰の往路で計算するパターン
今度のレジスタはcountとproduct

  1. それぞれの初期値としてnと1を代入
  2. countが0であれば計算終了
  3. countからは1を引き、productにはbを掛ける

これを繰り返すだけなのでスタックは不要（何気なく末尾再帰の最適化になっている）。

'(controller
  (assign count (reg n))
  (assign product (const 1))
  expt-iter
  (test (op =) (reg count) (const 0))
  (branch (label expt-done))
  (assign count (op -) (reg count) (const 1))
  (assign product (op *) (reg product) (reg b))
  (goto (label expt-iter))
  expt-done)
Exercise 5.5

factorialの場合。3!を計算するとすると
（「significant pointで」と書いてあるけど、どの道全部書き出さないと分からない。）

ステップ 命令 val n continue stack
1 (assign continue (label fact-done)) 3 (label fact-done)
2 (test (op =) (reg n) (const 1)) 3 (label fact-done)
3 (save continue) 3 (label fact-done) (label fact-done)
4 (save n) 3 (label fact-done) 3/(label fact-done)
5 (assign n (op -) (reg n) (const 1)) 2 (label fact-done) 3/(label fact-done)
6 (assign continue (label after-fact)) 2 (label after-fact) 3/(label fact-done)
7 (goto (label fact-loop)) 2 (label after-fact) 3/(label fact-done)
8 (test (op =) (reg n) (const 1)) 2 (label after-fact) 3/(label fact-done)
9 (save continue) 2 (label after-fact) (label after-fact)/3/(label fact-done)
10 (save n) 2 (label after-fact) 2/(label after-fact)/3/(label fact-done)
11 (assign n (op -) (reg n) (const 1)) 1 (label after-fact) 2/(label after-fact)/3/(label fact-done)
12 (assign continue (label after-fact)) 1 (label after-fact) 2/(label after-fact)/3/(label fact-done)
13 (goto (label fact-loop) 1 (label after-fact) 2/(label after-fact)/3/(label fact-done)
14 (test (op =) (reg n) (const 1)) 1 (label after-fact) 2/(label after-fact)/3/(label fact-done)
15 (branch (label base-case)) 1 (label after-fact) 2/(label after-fact)/3/(label fact-done)
16 (assign val (const 1)) 1 1 (label after-fact) 2/(label after-fact)/3/(label fact-done)
17 (goto (reg continue)) 1 1 (label after-fact) 2/(label after-fact)/3/(label fact-done)
18 (restore n) 1 2 (label after-fact) (label after-fact)/3/(label fact-done)
19 (restore continue) 1 2 (label after-fact) 3/(label fact-done)
20 (assign val (op *) (reg n) (reg val)) 2 2 (label after-fact) 3/(label fact-done)
21 (goto (reg continue)) 2 2 (label after-fact) 3/(label fact-done)
22 (restore n) 2 3 (label after-fact) (label fact-done)
23 (restore continue) 2 3 (label fact-done)
24 (assign val (op *) (reg n) (reg val)) 6 3 (label fact-done)
25 (goto (reg continue)) 6 3 (label fact-done)

Fibonacciの場合。Fib(5)を計算するとすると。

ステップ 命令 val n continue stack
1 (assign continue (label fib-done)) 5 (label fib-done)
2 (test (op <) (reg n) (const 2)) 5 (label fib-done)
3 (save continue) 5 (label fib-done) (label fib-done)
4 (assign continue (label afterfib-n-1)) 5 (label afterfib-n-1) (label fib-done)
5 (save n) 5 (label afterfib-n-1) 5/(label fib-done)
6 (assign n (op -) (reg n) (const 1)) 4 (label afterfib-n-1) 5/(label fib-done)
7 (goto (label fib-loop)) 4 (label afterfib-n-1) 5/(label fib-done)
8 (test (op <) (reg n) (const 2) 4 (label afterfib-n-1) 5/(label fib-done)
9 (save continue) 4 (label afterfib-n-1) (label afterfib-n-1)/5/(label fib-done)
10 (assign continue (label afterfib-n-1)) 4 (label afterfib-n-1) (label afterfib-n-1)/5/(label fib-done)
11 (save n) 4 (label afterfib-n-1) 4/(label afterfib-n-1)/5/(label fib-done)
12 (assign n (op -) (reg n) (const 1)) 3 (label afterfib-n-1) 4/(label afterfib-n-1)/5/(label fib-done)
13 (goto (label fib-loop)) 3 (label afterfib-n-1) 4/(label afterfib-n-1)/5/(label fib-done)
14 (test (op <) (reg n) (const 2) 3 (label afterfib-n-1) 4/(label afterfib-n-1)/5/(label fib-done)
15 (save continue) 3 (label afterfib-n-1) (label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
16 (assign continue (label afterfib-n-1)) 3 (label afterfib-n-1) (label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
17 (save n) 3 (label afterfib-n-1) 3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
18 (assign n (op -) (reg n) (const 1)) 2 (label afterfib-n-1) 3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
19 (goto (label fib-loop)) 2 (label afterfib-n-1) 3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
20 (test (op <) (reg n) (const 2) 2 (label afterfib-n-1) 3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
21 (save continue) 2 (label afterfib-n-1) (label afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
22 (assign continue (label afterfib-n-1)) 2 (label afterfib-n-1) (label afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
23 (save n) 2 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
24 (assign n (op -) (reg n) (const 1)) 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
25 (goto (label fib-loop)) 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
26 (test (op <) (reg n) (const 2) 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
27 (branch (label immediate-answer)) 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
28 (assign val (reg n)) 1 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
29 (goto (reg continue)) 1 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
30 (restore n) 1 2 (label afterfib-n-1) (label afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
31 (restore continue) 1 2 (label afterfib-n-1) 3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
32 (assign n (op -) (reg n) (const 2)) 1 0 (label afterfib-n-1) 3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
33 (save continue) 1 0 (label afterfib-n-1) (afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
34 (assign continue (label afterfib-n-2)) 1 0 (label afterfib-n-2) (afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
35 (save val) 1 0 (label afterfib-n-2) 1/(afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
36 (goto (label fib-loop)) 1 0 (label afterfib-n-2) 1/(afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
37 (test (op <) (reg n) (const 2)) 1 0 (label afterfib-n-2) 1/(afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
38 (branch (label immediate-answer)) 1 0 (label afterfib-n-2) 1/(afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
39 (assign val (reg n)) 0 0 (label afterfib-n-2) 1/(afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
40 (goto (reg continue)) 0 0 (label afterfib-n-2) 1/(afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
41 (assign n (reg val)) 0 0 (label afterfib-n-2) 1/(afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
42 (restore val) 1 0 (label afterfib-n-2) (afterfib-n-1)/3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
43 (restore continue) 1 0 (label afterfib-n-1) 3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
44 (assign val (op +) (reg val) (reg n)) 1 0 (label afterfib-n-1) 3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
45 (goto (reg continue)) 1 0 (label afterfib-n-1) 3/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
46 (restore n) 1 3 (label afterfib-n-1) (label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
47 (restore continue) 1 3 (label afterfib-n-1) (label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
48 (assign n (op -) (reg n) (const 2)) 1 1 (label afterfib-n-1) (label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
49 (save continue) 1 1 (label afterfib-n-1) (label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
50 (assign continue (label afterfib-n-2)) 1 1 (label afterfib-n-2) (label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
51 (save val) 1 1 (label afterfib-n-2) 1/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
52 (goto (label fib-loop)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
53 (test (op <) (reg n) (const 2)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
54 (branch (label immediate-answer)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
55 (assign val (reg n)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
56 (goto (reg continue)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
57 (assign n (reg val)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
58 (restore val) 1 1 (label afterfib-n-2) (label afterfib-n-1)/4/(label afterfib-n-1)/5/(label fib-done)
59 (restore continue) 1 1 (label afterfib-n-1) 4/(label afterfib-n-1)/5/(label fib-done)
60 (assign val (op +) (reg val) (reg n)) 2 1 (label afterfib-n-1) 4/(label afterfib-n-1)/5/(label fib-done)
61 (goto (reg continue)) 2 1 (label afterfib-n-1) 4/(label afterfib-n-1)/5/(label fib-done)
62 (restore n) 2 4 (label afterfib-n-1) (label afterfib-n-1)/5/(label fib-done)
63 (restore continue) 2 4 (label afterrfib-n-1) 5/(label fib-done)
64 (assign n (op -) (reg n) (const 2)) 2 2 (label afterrfib-n-1) 5/(label fib-done)
65 (save continue) 2 2 (label afterfib-n-1) (label afterfib-n-1)/5/(label fib-done)
66 (assign continue (label afterfib-n-2)) 2 2 (label afterfib-n-2) (label afterfib-n-1)/5/(label fib-done)
67 (save val) 2 2 (label afterfib-n-2) 2/(label afterfib-n-1)/5/(label fib-done)
68 (goto (label fib-loop)) 2 2 (label afterfib-n-2) 2/(label afterfib-n-1)/5/(label fib-done)
69 (test (op <) (reg n) (const 2)) 2 2 (label afterfib-n-2) 2/(label afterfib-n-1)/5/(label fib-done)
70 (save continue) 2 2 (label afterfib-n-2) (label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
71 (assign continue (label afterfib-n-1)) 2 2 (label afterfib-n-1) (label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
72 (save n) 2 2 (label afterfib-n-1) 2/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
73 (assign n (op -) (reg n) (const 1)) 2 1 (label afterfib-n-1) 2/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
74 (goto (label fib-loop)) 2 1 (label afterfib-n-1) 2/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
75 (test (op <) (reg n) (const 2)) 2 1 (label afterfib-n-1) 2/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
75 (branch (label immediate-answer)) 2 1 (label afterfib-n-1) 2/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
76 (assign val (reg n)) 1 1 (label afterfib-n-1) 2/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
77 (goto (reg continue)) 1 1 (label afterfib-n-1) 2/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
78 (restore n) 1 2 (label afterfib-n-1) (label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
79 (restore continue) 1 2 (label afterfib-n-2) 2/(label afterfib-n-1)/5/(label fib-done)
80 (assign n (op -) (reg n) (const 2)) 1 0 (label afterfib-n-2) 2/(label afterfib-n-1)/5/(label fib-done)
81 (save continue) 1 0 (label afterfib-n-2) (label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
82 (assign continue (label afterfib-n-2)) 1 0 (label afterfib-n-2) (label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
83 (save val) 1 0 (label afterfib-n-2) 1/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
84 (goto (label fib-loop)) 1 0 (label afterfib-n-2) 1/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
85 (test (op <) (reg n) (const 2)) 1 0 (label afterfib-n-2) 1/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
86 (branch (label immediate-answer)) 1 0 (label afterfib-n-2) 1/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
87 (assign val (reg n)) 0 0 (label afterfib-n-2) 1/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
88 (goto (reg continue)) 0 0 (label afterfib-n-2) 1/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
89 (assign n (reg val)) 0 0 (label afterfib-n-2) 1/(label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
90 (restore val) 1 0 (label afterfib-n-2) (label afterfib-n-2)/2/(label afterfib-n-1)/5/(label fib-done)
91 (restore continue) 1 0 (label afterfib-n-2) 2/(label afterfib-n-1)/5/(label fib-done)
92 (assign val (op +) (reg val) (reg n)) 1 0 (label afterfib-n-2) 2/(label afterfib-n-1)/5/(label fib-done)
93 (goto (reg continue)) 1 0 (label afterfib-n-2) 2/(label afterfib-n-1)/5/(label fib-done)
94 (assign n (reg val)) 1 1 (label afterfib-n-2) 2/(label afterfib-n-1)/5/(label fib-done)
95 (restore val) 2 1 (label afterfib-n-2) (label afterfib-n-1)/5/(label fib-done)
96 (restore continue) 2 1 (label afterfib-n-1) 5/(label fib-done)
97 (assign val (op +) (reg val) (reg n)) 3 1 (label afterfib-n-1) 5/(label fib-done)
98 (goto (reg continue)) 3 1 (label afterfib-n-1) 5/(label fib-done)
99 (restore n) 3 5 (label afterfib-n-1) (label fib-done)
100 (restore continue) 3 5 (label fib-done)
101 (assign n (op -) (reg n) (const 2)) 3 3 (label fib-done)
102 (save continue) 3 3 (label fib-done) (label fib-done)
103 (assign continue (label afterfib-n-2)) 3 3 (label afterfib-n-2) (label fib-done)
104 (save val) 3 3 (label afterfib-n-2) 3/(label fib-done)
105 (goto (label fib-loop)) 3 3 (label afterfib-n-2) 3/(label fib-done)
106 (test (op <) (reg n) (const 2)) 3 3 (label afterfib-n-2) 3/(label fib-done)
107 (save continue) 3 3 (label afterfib-n-2) (label afterfib-n-2)/3/(label fib-done)
108 (assign continue (label afterfib-n-1)) 3 3 (label afterfib-n-1) (label afterfib-n-2)/3/(label fib-done)
109 (save n) 3 3 (label afterfib-n-1) 3/(label afterfib-n-2)/3/(label fib-done)
110 (assign n (op -) (reg n) (const 1)) 3 2 (label afterfib-n-1) 3/(label afterfib-n-2)/3/(label fib-done)
111 (goto (label fib-loop)) 3 2 (label afterfib-n-1) 3/(label afterfib-n-2)/3/(label fib-done)
112 (test (op <) (reg n) (const 2)) 3 2 (label afterfib-n-1) 3/(label afterfib-n-2)/3/(label fib-done)
113 (save continue) 3 2 (label afterfib-n-1) (label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
114 (assign continue (label afterfib-n-1)) 3 2 (label afterfib-n-1) (label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
115 (save n) 3 2 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
116 (assign n (op -) (reg n) (const 1)) 3 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
117 (goto (label fib-loop)) 3 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
118 (test (op <) (reg n) (const 2)) 3 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
119 (branch (label immediate-answer)) 3 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
120 (assign val (reg n)) 1 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
121 (goto (reg continue)) 1 1 (label afterfib-n-1) 2/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
122 (restore n) 1 2 (label afterfib-n-1) (label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
123 (restore continue) 1 2 (label afterfib-n-1) 3/(label afterfib-n-2)/3/(label fib-done)
124 (assign n (op -) (reg n) (const 2)) 1 0 (label afterfib-n-1) 3/(label afterfib-n-2)/3/(label fib-done)
125 (save continue) 1 0 (label afterfib-n-1) (label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
126 (assign continue (label afterfib-n-2)) 1 0 (label afterfib-n-2) (label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
127 (save val) 1 0 (label afterfib-n-2) 1/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
128 (goto (label fib-loop)) 1 0 (label afterfib-n-2) 1/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
129 (test (op <) (reg n) (const 2)) 1 0 (label afterfib-n-2) 1/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
130 (branch (label immediate-answer)) 1 0 (label afterfib-n-2) 1/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
131 (assign val (reg n)) 0 0 (label afterfib-n-2) 1/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
132 (goto (reg continue)) 0 0 (label afterfib-n-2) 1/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
133 (assign n (reg val)) 0 0 (label afterfib-n-2) 1/(label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
134 (restore val) 1 0 (label afterfib-n-2) (label afterfib-n-1)/3/(label afterfib-n-2)/3/(label fib-done)
135 (restore continue) 1 0 (label afterfib-n-1) 3/(label afterfib-n-2)/3/(label fib-done)
136 (assign val (op +) (reg val) (reg n)) 1 0 (label afterfib-n-1) 3/(label afterfib-n-2)/3/(label fib-done)
137 (goto (reg continue)) 1 0 (label afterfib-n-1) 3/(label afterfib-n-2)/3/(label fib-done)
138 (restore n) 1 3 (label afterfib-n-1) (label afterfib-n-2)/3/(label fib-done)
139 (restore continue) 1 3 (label afterfib-n-2) 3/(label fib-done)
140 (assign n (op -) (reg n) (const 2)) 1 1 (label afterfib-n-2) 3/(label fib-done)
141 (save continue) 1 1 (label afterfib-n-2) (label afterfib-n-2)/3/(label fib-done)
142 (assign continue (label afterfib-n-2)) 1 1 (label afterfib-n-2) (label afterfib-n-2)/3/(label fib-done)
143 (save val) 1 1 (label afterfib-n-2) 1/(label afterfib-n-2)/3/(label fib-done)
144 (goto (label fib-loop)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-2)/3/(label fib-done)
145 (test (op <) (reg n) (const 2)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-2)/3/(label fib-done)
146 (branch (label immediate-answer)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-2)/3/(label fib-done)
147 (assign val (reg n)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-2)/3/(label fib-done)
148 (goto (reg continue)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-2)/3/(label fib-done)
149 (assign n (reg val)) 1 1 (label afterfib-n-2) 1/(label afterfib-n-2)/3/(label fib-done)
150 (restore val) 1 1 (label afterfib-n-2) (label afterfib-n-2)/3/(label fib-done)
151 (restore continue) 1 1 (label afterfib-n-2) 3/(label fib-done)
152 (assign val (op +) (reg val) (reg n)) 2 1 (label afterfib-n-2) 3/(label fib-done)
153 (goto (reg continue)) 2 1 (label afterfib-n-2) 3/(label fib-done)
154 (assign n (reg val)) 2 2 (label afterfib-n-2) 3/(label fib-done)
155 (restore val) 3 2 (label afterfib-n-2) (label fib-done)
156 (restore continue) 3 2 (label fib-done)
157 (assign val (op +) (reg val) (reg n)) 5 2 (label fib-done)
158 (goto (reg continue)) 5 2 (label fib-done)
Exercise 5.6

Exercise 5.5を手で書いていると直ぐに気付く。以下の部分

 afterfib-n-1
   (restore n)
   (restore continue)  ;; ←これと
   ;; set up to compute Fib(n - 2)
   (assign n (op -) (reg n) (const 2))
   (save continue)  ;; ←これ

continueにrestoreしたラベルをまたそのままスタックに積むので無駄。

5.1.5 Instruction Summary

ここは纏めだけなので特にノートは無し。

SICP 5 Computing with Register Machines

LISP Scheme

ノート

プログラムの実行環境についてsubstitution model、environment model、metacircular evaluatorと見て来たが、一番核心の部分はベースのLispシステムに委ねて解説されていない。

この章ではプロセッサとそのマシン語に相当するレジスタ・システムをLisp上に実装してプログラムを実行する。

5.1 Designing Register Machines

データフローダイヤグラムの様なデータパスダイヤグラム。

  • レジスタは四角
  • データの代入は矢印に⊗マーク（このマークには名前が付いていて、ボタンとして働く）
  • 定数は三角
  • 演算は台形
  • テスト（即ち述語演算？）は丸

述語演算の結果についてはこの図では表現されない。またボタンは正しい順序で押される必要がある。これを別のコントローラーダイヤグラム（どう見てもフローチャート）で記述する。四角のアクションの所にはボタンの名前が書いてある。

Exercise 5.1
  1. や*の演算の入力に対して出力をそのまま代入しても良いものなのか良く分からないので、取り敢えず中間の変数を置く事にする。



5.1.1 A Language for Describing Register Machines

データパスダイヤグラムとコントローラーダイヤグラムをS式で表現する。
また、ボタンは名前だけでは内容が分からないので、そのアクションが分かる様な式にする。

Exercise 5.2

動かしてみないと正しいのか検証出来ないけど。

'(data-paths
  (registers
   ((name n))
   ((name counter)
    (buttons ((name counter<-1) (source constant 1))
             ((name counter<-t1) (source register t1))))
   ((name product)
    (buttons ((name product<-1) (source constant 1))
             ((name product<-t2) (source register t2))))
   ((name t1)
    (buttons ((name t1<-+) (source operation +))))
   ((name t2)
    (buttons ((name t2<-*) (source operation *)))))
  
  (operations
   ((name +)
    (inputs (constant 1) (register counter)))
   ((name *)
    (inputs (register conter) (register product)))))
  
'(controller
   (assign counter (const 1))
   (assign product (const 1))
   test-counter
   (test (op <) (reg counter) (reg n))
   (branch (label factorial-done))
   (assign t1 (op +) (const 1) (reg counter))
   (assign t2 (op *) (reg counter) (reg product))
   (assign (reg counter) (reg t1))
   (assign (reg product) (reg t2))
   (goto (label test-counter))
   factorial-done)
Actions

readとprintと言うアクション（演算）を導入。
>
But read does not take inputs from any registers; its value depends on something that happens outside the parts of the machine we are designing.

Though it has an effect, this effect is not on a part of the machine we are designing.<
『IOはプログラム（マシン）とは別の世界で起きる』と言う言い回しが関数型言語（と言うかHaskell）的。

assign, test, branch, gotoに加えてperformを導入。

5.1.2 Abstraction in Machine Design

マシンのデザインには常に詳細が隠されたプリミティブが存在する。が、基本的にはこれらは展開可能である。

Exercise 5.3

まずgood-enough?とimproveをプリミティブとした単純な実装。引数には現れないがどちらもxを入力としている。

good-enough?を-（引き算）、abs、squareを比較演算<をプリミティブとして実装する。


述語を実装する時の最後の部分をどう表現するのが良いのか良く分からない。

improveをaverageと/をプリミティブとして実装する。

全体をあわせると。

コードにすると

#lang racket
'(data-paths
  (registers
   ((name x))
   ((name guess)
    (buttons ((name guess<-1.0) (source constant 1.0))
             ((name guess<-average) (source operation average))))
   ((name d)
    (buttons ((name d<-div) (source operation /))))
   ((name s)
    (buttons ((name s<-square) (source operation square))))
   ((name diff)
    (buttons ((name diff<-sub) (source operation -))))
   ((name ad)
    (buttons ((name ad<-abs) (source operation abs))))
  
  (operations
   ((name /)
    (inputs (register x) (register guess)))
   ((name average)
    (inputs (register guess) (register d)))
   ((name square)
    (inputs (register guess)))
   ((name -)
    (inputs (register x) (register s)))
   ((name abs)
    (inputs (register diff)))
   ((name >)
    (inputs (register ad) (constant 0.001))))))
  
'(controller
    (assign guess (const 1.0))
  good-enough?
    (assign s (op square) (register guess))
    (assign diff (op -) (register x) (register s))
    (assign ad (op abs) (register diff))
    (test (op >) (const 0.001) (register ad))
    (branch (label sqrt-done))
    (assign d (op /) (register x) (register guess))
    (assign guess (op average) (register d) (register guess))
    (goto (label good-enough?))
  sqrt-done)

ここまでの所、何も動作させていないので合ってるのかどうなのかサッパリ分からない。