さかもとのブログ

つらつらと

SICP演習問題5.19

SICP

今回の問題はcall/ccを使えば簡単にできる．使っていいのかな?まぁいっか．
問題5.17をベースに今回の問題を解く．5.17はlabelをinstructionに付随させるものなので，その性質を使う．というか，むしろ，この問題のための問題だったのか?
今回追加するものと修正するものは...と思ったが結構多いので，そのまま貼り付けます．
簡単に方針を書きます．
まず，breakpointのデータ構造は

((break1 . 1) (break2 . 2)...)

のような連想リストにする．これをbreakpoint-pairsとする．
また，同じラベルの中で，instructionの数を数えておく．この数をinst-count-for-labelとする．
(この2つはどちらもmake-new-machineの内部変数)
で，breakするかどうかは

  1. instに付随しているlabelを確認する
  2. (assoc label breakpoint-pairs）で#fでなければ
  3. assocで得られたpairのcdrがinst-count-for-labelと等しいか確認する
  4. 3が真なら，breakする

breakをどうやって実現するかというと，breakpointという変数を用意しておき，

(call/cc (lambda (break) 
         (set! breakpoint break)
         (after-break))

を実行する．(after-break)はmake-new-machineの外に出るための，継続．
set-breakpointによって，breakpointをセットしたり，cancel-breakpointによって，breakpointを消すには，当然breakpoint-pairsをいじくればいい．
まずは，make-new-machineを載せる．
相当長くなってます...

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (instruction-count 0) ;; exercise 5.15
        (trace? #f) ;; exercise 5.16
        (label #f) ;; exercise5.17
        (breakpoint #f)
        (breakpoint-pairs '())
        (inst-count-for-label 0))
    (let ((the-operations
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply define register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register: " name))))
      ;; exercise5.19 ======================================
      (define (set-breakpoint label n)
        (if (not (null? breakpoint-pairs))
            (set-cdr! breakpoint-pairs (list (cons label n)))
            (set! breakpoint-pairs (list (cons label n))))
        (print "set-breakpoint"))
      (define (search-breakpoint label n)
        (let ((pair (assoc label breakpoint-pairs)))
          (if pair
              (if (eq? n (cdr pair))
                  pair
                  #f)
              #f)))
      (define (cancel-breakpoint label n)
        (let ((cancel-pair (cons label n)))
          (set! breakpoint-pairs
                (map (lambda (pair)
                       (if (equal? pair cancel-pair) '() pair))
                     breakpoint-pairs))
          (print "cancel-pair: "cancel-pair " breakpoint-pairs: " breakpoint-pairs)))
      (define (cancel-all-breakpoints)
        (set! breakpoint-pairs '())
        (set! breakpoint #f)
        'done)
      ;; ==================================================
      (define (execute)
        (let ((instructions (get-contents pc)))
          (if (null? instructions)
              'done
              (begin
                (if (not (eq? (caaar instructions) 'label)) ;; check-label-tag
                    (begin
                      (inc! inst-count-for-label)
                      (instruction-count-up)
                      (print-trace (caar instructions)))
                    (begin
                      (set! inst-count-for-label 0)
                      (set! label (cadr (caar instructions)))))
                (let ((break-pair (search-breakpoint label inst-count-for-label)))
                  (if break-pair
                      (call/cc (lambda (break)
                                 (set! breakpoint break)
                                 ;(error "***BREAK*** break-point: " break-pair  (caar instructions))))))
                                 (after-break)))))
                ((instruction-execution-proc (car instructions)))
                (execute)))))
      (define (print-trace trace) ;; exercise 5.16
        (if trace?
            (print "label: " label " instruction: " trace)))
      (define (print-stack-statistics) ;; exercise 5.14
        (stack 'print-statistics))
      (define (instruction-count-up) ;; exercise 5.15
        (set! instruction-count (+ instruction-count 1)))
      (define (print-inst-count) ;; exercise 5.15
        (let ((x instruction-count))
          (set! instruction-count 0)
          (print "instruction-count: " x)))
      (define (trace-on) ;; exercise 5.16
        (set! trace? #t))
      (define (trace-off) ;; exercise 5.16
        (set! trace? #f))
      (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 (operations) (set! the-operations
                                          (append the-operations operations)))]
              [(eq? message 'stack) stack]
              [(eq? message 'print-stack) (print-stack-statistics)] ;; exercise 5.14
              [(eq? message 'inst-count-init) (instruction-count-init)] ;; exercise 5.15
              [(eq? message 'print-inst-count) (print-inst-count)] ;; exercise 5.15
              [(eq? message 'trace-on) (trace-on)] ;; exercise 5.16
              [(eq? message 'trace-off) (trace-off)] ;; exercise 5.16
              [(eq? message 'set-label) set-label] ;; exercise 5.17
              [(eq? message 'set-breakpoint) set-breakpoint] ;; exercise5.19
              [(eq? message 'proceed-machine) (breakpoint)] ;; exercise5 5.19
              [(eq? message 'cancel-breakpoint) cancel-breakpoint] ;; exercise5.19
              [(eq? message 'cancel-all-breakpoints) (cancel-all-breakpoints)] ;;exercise5.19
              [(eq? message 'operations) the-operations]
              [else
               (error "Unknown request -- MACHINE" message)]))
      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))

また，make-new-machineから脱出するための定義は

(define after-break '())

(define (break-proc)
  (call/cc (lambda (break)
             (set! after-break break)))
  #f)

(break-proc)

一度break-procを実行しておかなければならない．

実行
(define expt-machine
  (make-machine
   '(b n val continue)
   (list (list '= =) (list '- -) (list '* *))
   '((assign continue (label expt-done))
     expt-loop
      (test (op =) (reg n) (const 0))
      (branch (label return))
      (save continue)
      (assign n (op -) (reg n) (const 1))
      (assign continue (label after-expt))
      (goto (label expt-loop))
     after-expt
      (restore continue)
      (assign val (op *) (reg b) (reg val))
      (goto (reg continue))
     return
      (assign val (const 1))
      (goto (reg continue))
   expt-done)))
(set-register-contents! expt-machine 'b 2)
(set-register-contents! expt-machine 'n 3)
(set-breakpoint expt-machine 'return 2)
(start expt-machine)
;; gosh> expt-machine
;; gosh> done
;; gosh> done
;; gosh> set-breakpoint
;; #<undef>
;; gosh> *** IO-CLOSED-ERROR: I/O attempted on closed port: #<iport(closed) ./exercise5-19.scm 0x8135620>

(最後のIO-ERRORはなぜおきるかは不明...とりあえず結果には問題ないので，続ける．)
これでvalを確認すると，

(get-register-contents expt-machine 'val)
;=> 1

無事にbreakできている．
保存していた継続を呼び出す

(proceed-machine expt-machine)
;=> doen
(get-register-contents expt-machine 'val)
;=> 8

無事に再開される．２つでもできるし, cancel-breakpointもできることを確認．

(cancel-breakpoint expt-machine 'return 2)
;=> cancel-pair: (return . 2) breakpoint-pairs: (())
;=> #<undef>

外側の継続を呼び出したときになぜIOERRORがでるのか...上のコードでコメントアウトしているerror関数を使う方法でももちろんmake-new-machineを脱出できるけれど...errorでもないのにerrorは使いたくない.