プログラミング再入門

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

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
>

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