SICP 読み (272) 5.2 レジスタ計算機での計算
問題 5.19
昨晩の修正を盛り込んで pc をトレイスしたら以下のような出力。(一部のみ)
(pc ((((after-fact 3) assign val (op *) (reg n) (reg val)) . #<closure (make-assign make-assign)>) ... 続く))
ブレイクポイントは (label n) のリストになっているとして execute は以下な感じで良いと見てるんですが ...
(define (isBreakpoint l)
(let f ((breakpoints (lookup-register 'breakpoints)))
(cond ((null? breakpoints) #f)
((equal? l (car breakpoints)) #t)
(else
(f (cdr breakpoints))))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
(if trace ;; 5.16
(begin ;; 5.16
(display (car (car insts))) ;; 5.17
(newline))) ;; 5.16
(cond ((isBreakpoint (car (car (car insts))))
(display (append (list 'break) (car (car (car insts)))))
(newline))
(else
((instruction-execution-proc (car insts)))
(set! inst-ctr (+ inst-ctr 1)) ;; 5.15
(execute)))))))他も含めて盛り込んでみたのが以下。
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(inst-ctr 0) ;; 5.15
(trace #f) ;; 5.16
(the-instruction-sequence '())
(breakpoints (make-register 'breakpoints)))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))))
(register-table
(list (list 'pc pc) (list 'flag flag))))
(define (init-inst-ctr) ;; 5.15
(set! inst-ctr 0)) ;; 5.15
(define (get-inst-ctr) ;; 5.15
inst-ctr) ;; 5.15
(define (trace-on) (set! trace #t)) ;; 5.16
(define (trace-off) (set! trace #f)) ;; 5.16
(define (reg-trace-on) ;; 5.18
(lambda (reg-name) ;; 5.18
((lookup-register reg-name) 'trace-on))) ;; 5.18
(define (reg-trace-off) ;; 5.18
(lambda (reg-name) ;; 5.18
((lookup-register reg-name) 'trace-off))) ;; 5.18
(define (allocate-register name)
(if (assoc name register-table)
(error "Multiply defined 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))))
;; 5.19
(define (isBreakpoint l)
; (let f ((breakpoints (lookup-register 'breakpoints)))
(let f ((b (breakpoints 'get)))
(cond ((null? b) #f)
((equal? l (car b)) #t)
(else
(f (cdr b))))))
;; 5.19
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
;; 5.19
;; (begin
(cond ((isBreakpoint (car (car (car insts))))
(display (append (list 'break) (car (car (car insts)))))
(newline))
(else
(proceed))))))
(define (proceed)
(if trace ;; 5.16
(begin ;; 5.16
(display (car (car insts))) ;; 5.17
(newline))) ;; 5.16
((instruction-execution-proc (car insts)))
(set! inst-ctr (+ inst-ctr 1)) ;; 5.15
(execute))
(define (set-breakpoint)
(lambda (label n)
((breakpoints 'set) (cons (list label n)
(breakpoints 'get))))
(define (reset-breakpoint)
(lambda (label n)
(let f ((b (breakpoints 'get))
(result '()))
(cond ((null? b) result)
((equal? (list label n) (car b))
(f (cdr b) result))
(else
(f (cdr b) (cons (car b) result)))))))
(define (reset-breakpoint-all)
((breakpoints 'set) '()))
;; 5.19
(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 'init-inst-ctr) (init-inst-ctr)) ;; 5.15
((eq? message 'get-inst-ctr) (get-inst-ctr)) ;; 5.15
((eq? message 'trace-on) (trace-on)) ;; 5.16
((eq? message 'trace-off) (trace-off)) ;; 5.16
((eq? message 'reg-trace-on) (reg-trace-on)) ;; 5.18
((eq? message 'reg-trace-off) (reg-trace-off)) ;; 5.18
((eq? message 'set-break) (set-breakpoint))
((eq? message 'proceed) (proceed))
((eq? message 'cancel-breakpoint) (reset-breakpoint))
((eq? message 'calcel-all) (reset-breakpoint-all))
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
;; 5.19
(define (set-breakpoint machine label n)
((m 'set-break) label n))
(define (proceed-machine machine)
(m 'proceed))
(define (cancel-breakpoint machine label n)
((m 'cancel-breakpoint) label n))
(define (calcel-all-breakpoints machine)
(m 'cancel-all))
;; 5.19バグ入ってる可能性大。今から試験をしてみます。
不具合
という不具合あり。まだ breakpoint なソレは試していません。で、セットしてみたら以下の返答が。
gosh> (set-breakpoint m 'fact-loop 2) ((fact-loop 2) . *unassigned*) gosh>
これはヒドい。しかもよく見りゃ register-table にセットしてません。breakpoints にデフォルト値 '() を設定して走らせてみると以下。
gosh> (set-breakpoint m 'fact-loop 2) ((fact-loop 2)) gosh> (m 'start) (break fact-loop 2) #<undef>
これ、display するんじゃなくってリストを戻せば良いだけ??
(define (execute)
(let ((insts (get-contents pc))
(b (breakpoints 'get)))
(if (null? insts)
'done
;; 5.19
;; (begin
(cond ((and (not (equal? '*unassigned* b))
(not (equal? '() b))
(isBreakpoint (car (car (car insts)))))
; (display (append (list 'break) (car (car (car insts)))))
; (newline))
(list 'break
(car (car (car (car insts))))
(cadr (car (car (car insts))))))
(else
(proceed))))))なんか馬鹿丸出しだなぁ (とほほ
で、次は cancel だな、という事で以下。
gosh> (set-register-contents! m 'n 3) done gosh> (set-breakpoint m 'fact-loop 2) ((fact-loop 2)) gosh> (m 'start) (break fact-loop 2) gosh> (proceed-machine m) (break fact-loop 2) gosh> (get-register-contents m 'n) 2 gosh> (get-register-contents m 'val) *unassigned* gosh> (cancel-breakpoint m 'fact-loop 2) () gosh> (proceed-machine m) (break fact-loop 2) gosh> (get-register-contents m 'breakpoints) ((fact-loop 2)) gosh>
cancel されてないし。ってこれは分かったぞ!!
(define (reset-breakpoint) (lambda (label n) (let f ((b (breakpoints 'get)) (result '())) (cond ((null? b) result) ((equal? (list label n) (car b)) (f (cdr b) result)) (else (f (cdr b) (cons (car b) result)))))))
直したリストを戻してるだけじゃん。(泣
(define (reset-breakpoint) (define (update-breakp l) (let f ((b (breakpoints 'get)) (result '())) (cond ((null? b) result) ((equal? l (car b)) (f (cdr b) result)) (else (f (cdr b) (cons (car b) result)))))) (lambda (label n) (set-contents! breakpoints (update-breakp (list label n)))))
これでどうか。
gosh> (set-breakpoint m 'fact-loop 2) ((fact-loop 2)) gosh> (cancel-breakpoint m 'fact-loop 2) () gosh> (get-register-contents m 'breakpoints) () gosh>
オーゲー。次は cancel-all ですがここでもボケをカマしてます。
gosh> (set-breakpoint m 'fact-loop 2) ((fact-loop 2)) gosh> (set-breakpoint m 'after-fact 1) ((after-fact 1) (fact-loop 2)) gosh> (get-register-contents m 'breakpoints) ((after-fact 1) (fact-loop 2)) gosh> (cancel-all-breakpoints m) *** ERROR: unbound variable: cancel-all-breakpoints Stack Trace: _______________________________________ gosh> (calcel-all-breakpoints m) *** ERROR: Unknown request -- MACHINE cancel-all Stack Trace: _______________________________________ gosh>
ソースの一部を以下に。
((eq? message 'calcel-all) (reset-breakpoint-all))
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
;; 5.19
(define (set-breakpoint machine label n)
((m 'set-break) label n))
(define (proceed-machine machine)
(m 'proceed))
(define (cancel-breakpoint machine label n)
((m 'cancel-breakpoint) label n))
(define (calcel-all-breakpoints machine)
(m 'cancel-all))段々嫌になって参りました。修正後は上手く動作している模様。
gosh> (set-breakpoint m 'fact-loop 2) ((fact-loop 2)) gosh> (set-breakpoint m 'after-fact 1) ((after-fact 1) (fact-loop 2)) gosh> (cancel-all-breakpoints m) () gosh> (get-register-contents m 'breakpoints) () gosh>
やれやれ、と言いつつスタートしたらオチました。よく見たら n なレジスタに値を設定してなかった。相当パニクってるな。一応これでデキ上がりなのだろうか。色々手を入れてみた挙句なソレを以下に。(手が入った部分のみ)
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(inst-ctr 0) ;; 5.15
(trace #f) ;; 5.16
(the-instruction-sequence '())
(breakpoints (make-register 'breakpoints)))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
;;**next for monitored stack (as in section 5.2.4)
;; -- comment out if not wanted
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))))
(register-table
(list (list 'pc pc) (list 'flag flag) (list 'breakpoints breakpoints)))
(dmy (set-contents! breakpoints '())))
(define (init-inst-ctr) ;; 5.15
(set! inst-ctr 0)) ;; 5.15
(define (get-inst-ctr) ;; 5.15
inst-ctr) ;; 5.15
(define (trace-on) (set! trace #t)) ;; 5.16
(define (trace-off) (set! trace #f)) ;; 5.16
(define (reg-trace-on) ;; 5.18
(lambda (reg-name) ;; 5.18
((lookup-register reg-name) 'trace-on))) ;; 5.18
(define (reg-trace-off) ;; 5.18
(lambda (reg-name) ;; 5.18
((lookup-register reg-name) 'trace-off))) ;; 5.18
(define (allocate-register name)
(if (assoc name register-table)
(error "Multiply defined 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))))
;; 5.19
(define (isBreakpoint l)
(let f ((b (get-contents breakpoints)))
(cond ((null? b) #f)
((equal? l (car b)) #t)
(else
(f (cdr b))))))
;; 5.19
(define (execute)
(let ((insts (get-contents pc))
(b (breakpoints 'get)))
(if (null? insts)
'done
;; 5.19
(let ((current-inst-label (car (car (car insts)))))
(cond ((and (not (equal? '*unassigned* b))
(not (equal? '() b))
(isBreakpoint current-inst-label))
(list 'break
(car current-inst-label)
(cadr current-inst-label)))
(else
(proceed)))))))
(define (proceed)
(let ((insts (get-contents pc)))
(if trace
(begin
(display (car (car insts)))
(newline)))
((instruction-execution-proc (car insts)))
(set! inst-ctr (+ inst-ctr 1))
(execute)))
(define (set-breakpoint)
(lambda (label n)
(set-contents! breakpoints (cons (list label n)
(get-contents breakpoints)))))
(define (reset-breakpoint)
(define (update-breakp l)
(let f ((b (get-contents breakpoints))
(result '()))
(cond ((null? b) result)
((equal? l (car b))
(f (cdr b) result))
(else
(f (cdr b) (cons (car b) result))))))
(lambda (label n)
(set-contents! breakpoints (update-breakp (list label n)))))
(define (reset-breakpoint-all)
(set-contents! breakpoints '()))
;; 5.19
(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 'init-inst-ctr) (init-inst-ctr)) ;; 5.15
((eq? message 'get-inst-ctr) (get-inst-ctr)) ;; 5.15
((eq? message 'trace-on) (trace-on)) ;; 5.16
((eq? message 'trace-off) (trace-off)) ;; 5.16
((eq? message 'reg-trace-on) (reg-trace-on)) ;; 5.18
((eq? message 'reg-trace-off) (reg-trace-off)) ;; 5.18
((eq? message 'set-break) (set-breakpoint)) ;; 5.19
((eq? message 'proceed) (proceed)) ;; 5.19
((eq? message 'cancel-breakpoint) (reset-breakpoint)) ;; 5.19
((eq? message 'cancel-all) (reset-breakpoint-all)) ;; 5.19
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
;; 5.19
(define (set-breakpoint machine label n)
((m 'set-break) label n))
(define (proceed-machine machine)
(m 'proceed))
(define (cancel-breakpoint machine label n)
((m 'cancel-breakpoint) label n))
(define (cancel-all-breakpoints machine)
(m 'cancel-all))
;; 5.19これはアソビがいのあるオモチャかも。
