問題5.18-5.19

生きてます。大学でverilog使った実験が面倒くさすぎてハード周りの話に嫌気がさしてしまい、
しばらくやる気がなくなってました。
最近またやる気が出てきたので、あとちょっと頑張ろうと思います。

5.18

registerのトレースができるようにします。
まずmake-ragister。

(define (make-register name)
  (let ((contents '*unassigned*)
        (trace-switch flase))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set)
             (lambda (value) (set! contents value)))
            ((eq? message 'trace-on)
             (lambda () (set! trace-switch true)))
            ((eq? message 'trace-off)
             (lambda () (set! trace-switch false)))
            ((eq? message 'trace-switch) trace-switch)
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))

次にmake-new-machineを拡張します。

(define (make-new-machine)
  ...

              ((eq? message 'reg-trace-on)
               (lambda (regname)
                 (((cadr (assoc regname register-table)) 'trace-on))))
              ((eq? message 'reg-trace-off)
               (lambda (regname) 
                 (((cadr (assoc regname register-table)) 'trace-off))))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

レジスタの値の変更時の通知ですが、これはmake-assignとmake-restoreに追加するのが一番楽そうです。

(define (make-assign inst machine labels operations pc)
  (let ((target (get-register machine (assign-reg-name inst)))
        (value-exp (assign-value-exp inst)))
    (let ((value-proc
           (if (operation-exp? value-exp)
               (make-operation-exp value-exp machine labels operations)
               (make-primitive-exp (car value-exp) machine labels))))
      (lambda ()
        (let ((value (value-proc)))
          (if (target 'trace-switch)
              (begin 
                (display (list (list 'reg (assign-reg-name inst))
                         ': (target 'get) '-> value))
                (newline)))
          (set-contents! target value)
          (advance-pc pc))))))
(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (let ((value (pop stack)))
        (if (reg 'trace-switch)
            (begin
              (display (list (list 'reg (stack-inst-reg-name inst))
                             ': (reg 'get) '-> value))
              (newline)))
        (set-contents! reg value))
      (if *trace-switch*
          (begin
            (pop *trace-stack*)
            (display-stack *trace-stack*)))
      (advance-pc pc))))

ということで実行してみます。

> ((factorial-machine 'reg-trace-on) 'n)
> (execute-machine-with factorial-machine ((n 10)) val)
((reg n) : 10 -> 9)
((reg n) : 9 -> 8)
((reg n) : 8 -> 7)
((reg n) : 7 -> 6)
((reg n) : 6 -> 5)
((reg n) : 5 -> 4)
((reg n) : 4 -> 3)
((reg n) : 3 -> 2)
((reg n) : 2 -> 1)
((reg n) : 1 -> 2)
((reg n) : 2 -> 3)
((reg n) : 3 -> 4)
((reg n) : 4 -> 5)
((reg n) : 5 -> 6)
((reg n) : 6 -> 7)
((reg n) : 7 -> 8)
((reg n) : 8 -> 9)
((reg n) : 9 -> 10)
val=3628800

おけーです。

5.19

make-new-machineにブレークポイントを保持する変数を作ります。cancel-*はこれを削除するようなものとして作ればいいです。ブレークポイントの表現は(label n)のようなリストにします。面倒なので選択子を作ったりの抽象化はしません。
また、はもっとも近いラベルからの指定のみに対応することにします。

ブレークポイントの認識のため、make-new-machineにcurrent-lineという変数を作り、現在処理中のlabelとnをブレークポイントと同じ(label n)の形で保持しておきます。これで、memberを使うだけでブレークポイントの判定ができます。効率とか気にしません。

proceed-machineは再開する処理をmake-new-machine内でlambdaで保持しておいて、proceed-machine呼び出し時に評価するようにすればいいと思います。

要求された4つの手続きは、make-new-machine内のlet変数にアクセスする必要があるので、実体をmake-new-machineの中に書く必要があります。あとは、make-new-machine内のexecuteを弄る必要があります。

ということで、以前との差分は以下になります。どんどん肥大していってます。

(define (make-new-machine)
  (let (
        ...
        (current-line '())
        (break-points '())
        (proceed-point '())
        ...))
  ...
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                (if (symbol? (car insts))
                    (begin
                      (set! current-line (list (car insts) 0))
                      (if trace-switch
                          (begin (display (car insts)) (newline)))
                      (advance-pc pc)
                      (execute))
                    (begin
                      (set-car! (cdr current-line) (+ (cadr current-line) 1))
                      (set! inst-count (+ inst-count 1))
                      (set! proceed-point
                            (lambda ()
                              (if trace-switch
                                  (begin (display (instruction-text (car insts)))
                                         (newline)))
                              ((instruction-execution-proc (car insts)))
                              (execute)))
                      (if (member current-line break-points)
                          'break!
                          (proceed-point))))))))
      ...
      (define (dispatch message)
        (cond ,..
              ((eq? message 'set-breakpoint)
               (lambda (label n) (set! break-points (cons (list label n) break-points))))
              ((eq? message 'proceed-machine) proceed-point)
              ((eq? message 'cancel-breakpoint)
               (lambda (label n)
                 (set! break-points (filter (lambda (x) (not (equal? (list label n) x))) break-points))))
              ((eq? message 'cancel-all-breakpoints)
               (lambda () (set! break-points '())))
        dispatch)))

なんか久しぶりで忘れてる部分が多いので、すごく無駄なところが多そうですが、この辺のコードこの後はあんまり弄らなくなるみたいなんで(たぶん)許してください。

あとは簡単です。

(define (set-breakpoint machine label n) ((machine 'set-breakpoint) label n))
(define (proceed-machine machine) ((machine 'proceed-machine)))
(define (cancel-breakpoint machine label n) ((machine 'cancel-breakpoint) label n))
(define (cancel-all-breakpoints machine) ((machine 'cancel-all-breakpoints)))

ということで動かしてみます。

> (set-breakpoint gcd-machine 'test-b 4)
> (set-register-contents! gcd-machine 'a 22)
done
> (set-register-contents! gcd-machine 'b 8)
done
> (start gcd-machine)
break!
> (get-register-contents gcd-machine 'a)
22
> (get-register-contents gcd-machine 'b)
8
> (get-register-contents gcd-machine 't)
6
> (proceed-machine gcd-machine)
break!
> (get-register-contents gcd-machine 'a)
8
> (get-register-contents gcd-machine 'b)
6
> (get-register-contents gcd-machine 't)
2
> (cancel-breakpoint gcd-machine 'test-b 4)
> (proceed-machine gcd-machine)
done
> (get-register-contents gcd-machine 'a)
2

> (set-breakpoint gcd-machine 'test-b 4)
> (set-breakpoint gcd-machine 'test-b 6)
> (cancel-all-breakpoints gcd-machine)
> (set-register-contents! gcd-machine 'a 22)
done
> (set-register-contents! gcd-machine 'b 8)
done
> (start gcd-machine)
done
> (get-register-contents gcd-machine 'a)
2

正しく動いていることが分かります。よかった。