SICP 読書ノート#73 - 5.2 レジスタ計算機シミュレータ(2) (pp.318-319)
「§5.2.4 計算機の性能の監視」から。
レジスタ計算機シミュレータにinspectorやdebuggerを実装していくみたい。面白そう。
まずはテキスト通り、スタックの状況をチェックするコマンドを実装する。
;;;; stack (define (make-stack) - (let ((s '())) + (let ((s '()) + (number-pushes 0) + (max-depth 0) + (current-depth 0)) (define (push x) - (set! s (cons x s))) + (set! s (cons x s)) + (set! number-pushes (+ 1 number-pushes)) + (set! current-depth (+ 1 current-depth)) + (set! max-depth (max current-depth max-depth))) (define (pop) (if (null? s) (error "[stack] empty stack") (let ((top (car s))) (set! s (cdr s)) + (set! current-depth (- current-depth 1)) top))) (define (initialize) (set! s '()) + (set! number-pushes 0) + (set! max-depth 0) + (set! current-depth 0) 'done) + (define (print-statistics) + (pretty-print (list 'total-pushes '= number-pushes + 'max-depth '= max-depth + 'curr-depth '= current-depth))) ;; pushは内部手続きを返すが、 ;; pop/initializeは内部手続きの実行して結果を返す(ややこしい..) (define (dispatch message) (cond ((eq? message 'push) push) ((eq? message 'pop) (pop)) ((eq? message 'initialize) (initialize)) + ((eq? message 'print-statistics) (print-statistics)) (else (error "[stack] unknown request:" + message)))) dispatch))
the-opsに手続きを追加することで、
(perform (op print-stack-statistics)でチェックできるようになる。
(stack (make-stack))
(the-instruction-sequence '())
(the-ops (list (list 'initialize-stack
- (lambda () (stack 'initialize)))))
+ (lambda () (stack 'initialize)))
+ (list 'print-stack-statistics
+ (lambda () (stack 'print-statistics)))))
(register-table (list (list 'pc pc)
(list 'flag flag))))
(define (allocate-register name)
§5.1のfactorial-machineで試してみる。
regsim.scm<feff>> (define fact-machine (make-machine '(val n continue) (list (list '= =) (list '- -) (list '* *)) '(controller (perform (op initialize-stack)) ;; add (assign continue (label fact-done)) fact-loop (test (op =) (reg n) (const 1)) (branch (label base-case)) (save continue) (perform (op print-stack-statistics)) ;; add (save n) (perform (op print-stack-statistics)) ;; add (assign n (op -) (reg n) (const 1)) (assign continue (label after-fact)) (goto (label fact-loop)) after-fact (restore n) (perform (op print-stack-statistics)) ;; add (restore continue) (perform (op print-stack-statistics)) ;; add (assign val (op *) (reg n) (reg val)) (goto (reg continue)) base-case (assign val (const 1)) (goto (reg continue)) fact-done))) regsim.scm<feff>> (set-register-contents! fact-machine 'n 3) 'done regsim.scm<feff>> (start fact-machine) '(total-pushes = 1 max-depth = 1 curr-depth = 1) '(total-pushes = 2 max-depth = 2 curr-depth = 2) '(total-pushes = 3 max-depth = 3 curr-depth = 3) '(total-pushes = 4 max-depth = 4 curr-depth = 4) '(total-pushes = 4 max-depth = 4 curr-depth = 3) '(total-pushes = 4 max-depth = 4 curr-depth = 2) '(total-pushes = 4 max-depth = 4 curr-depth = 1) '(total-pushes = 4 max-depth = 4 curr-depth = 0) 'done
current-depthの動きが§5.1で追った通りになっていることがわかる。
問題 5.14
fact-machineを以下のように改造する。
(define fact-machine
(make-machine
'(val n continue)
(list (list '= =)
(list '- -)
(list '* *))
'(controller
+ (perform (op initialize-stack))
(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
+ (perform (op print-stack-statistics))
(assign val (const 1))
(goto (reg continue))
fact-done)))
実行結果は以下の通り。
regsim.scm<feff>> (map (lambda (n) (set-register-contents! fact-machine 'n n) (start fact-machine)) '(1 2 3 4 5 6 7 8 9 10)) '(total-pushes = 0 max-depth = 0 curr-depth = 0) '(total-pushes = 2 max-depth = 2 curr-depth = 2) '(total-pushes = 4 max-depth = 4 curr-depth = 4) '(total-pushes = 6 max-depth = 6 curr-depth = 6) '(total-pushes = 8 max-depth = 8 curr-depth = 8) '(total-pushes = 10 max-depth = 10 curr-depth = 10) '(total-pushes = 12 max-depth = 12 curr-depth = 12) '(total-pushes = 14 max-depth = 14 curr-depth = 14) '(total-pushes = 16 max-depth = 16 curr-depth = 16) '(total-pushes = 18 max-depth = 18 curr-depth = 18) '(done done done done done done done done done done)
よって、結果はnに対し2n-2となる。
問題 5.15
命令計数カウンタ(instruction counter)として、
実行手続きが実行される度に加算されるカウンタを追加すればよい。
(define (make-new-machine)
(let* ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(the-ops (list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(register-table (list (list 'pc pc)
- (list 'flag flag))))
+ (list 'flag flag)))
+ (instruction-count 0))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
((instruction-execution-proc (car insts)))
+ (set! instruction-count (+ instruction-count 1))
(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 'initialize-instruction-count)
+ (set! instruction-count 0))
+ ((eq? message 'get-instruction-count)
+ instruction-count)
実行結果は以下の通り。
(map (lambda (n) (set-register-contents! fact-machine 'n n) (fact-machine 'initialize-instruction-count) (start fact-machine) (pretty-print (list 'n '= n 'instruction-count '= (fact-machine 'get-instruction-count)))) '(1 2 3 4 5 6 7 8 9 10)) '(n = 1 instruction-count = 5) '(n = 2 instruction-count = 16) '(n = 3 instruction-count = 27) '(n = 4 instruction-count = 38) '(n = 5 instruction-count = 49) '(n = 6 instruction-count = 60) '(n = 7 instruction-count = 71) '(n = 8 instruction-count = 82) '(n = 9 instruction-count = 93) '(n = 10 instruction-count = 104)
問題 5.16
trace-flagを追加し、trueの場合はinstruction-textをプリントさせる。
(define (make-new-machine)
(let* ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(the-ops (list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(register-table (list (list 'pc pc)
(list 'flag flag)))
- (instruction-count 0))
+ (instruction-count 0)
+ (trace-flag false))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
- ((instruction-execution-proc (car insts)))
+ (let ((inst (car insts)))
+ (if trace-flag
+ (pretty-print (list 'inst '= (instruction-text inst)))
+ false)
+ ((instruction-execution-proc inst)))
(set! instruction-count (+ instruction-count 1))
(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 'initialize-instruction-count)
(set! instruction-count 0))
((eq? message 'get-instruction-count)
instruction-count)
+ ((eq? message 'trace-on)
+ (set! trace-flag true))
+ ((eq? message 'trace-off)
+ (set! trace-flag false))
fact-machineでの実行結果。
regsim.scm<feff>> (set-register-contents! fact-machine 'n 3) 'done regsim.scm<feff>> (fact-machine 'trace-on) regsim.scm<feff>> (start fact-machine) '(inst = (assign continue (label fact-done))) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(inst = (save continue)) '(inst = (save n)) '(inst = (assign n (op -) (reg n) (const 1))) '(inst = (assign continue (label after-fact))) '(inst = (goto (label fact-loop))) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(inst = (save continue)) '(inst = (save n)) '(inst = (assign n (op -) (reg n) (const 1))) '(inst = (assign continue (label after-fact))) '(inst = (goto (label fact-loop))) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(inst = (assign val (const 1))) '(inst = (goto (reg continue))) '(inst = (restore n)) '(inst = (restore continue)) '(inst = (assign val (op *) (reg n) (reg val))) '(inst = (goto (reg continue))) '(inst = (restore n)) '(inst = (restore continue)) '(inst = (assign val (op *) (reg n) (reg val))) '(inst = (goto (reg continue))) 'done
問題 5.17
実装方法は色々あると思うが、問題5.19のことも考えると ラベル名と命令シーケンスを対で管理しておいた方がよい。
そこで、make-label-entryでラベル名に対する命令シーケンスを紐づける箇所を、
ラベル名と命令シーケンスの対を紐づけるように修正する。
(define (extract-labels ctrl-text recieve)
(if (null? ctrl-text)
(recieve '() '())
(extract-labels (cdr ctrl-text)
(lambda (insts labels)
(let ((next-inst (car ctrl-text)))
(if (symbol? next-inst)
(if (label-insts labels next-inst)
(error "[extract-labels] duplicate label:" next-inst)
(recieve insts
- (cons (make-label-entry next-inst insts)
+ (cons (make-label-entry next-inst
+ (cons next-inst insts))
labels)))
(recieve (cons (make-instruction next-inst)
insts)
labels)))))))
これに合わせてexecuteで命令シーケンスを実行する際に、
ラベル名かどうかのチェックとログの表示処理を追加する。
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
- (begin
- (let ((inst (car insts)))
- (if trace-flag
- (pretty-print (list 'inst '= (instruction-text inst)))
- false)
- ((instruction-execution-proc inst)))
- (set! instruction-count (+ instruction-count 1))
- (execute)))))
+ (if (symbol? (car insts))
+ (begin
+ (if trace-flag
+ (pretty-print (list 'label '= (car insts)))
+ false)
+ (set-contents! pc (cdr insts))
+ (execute))
+ (begin
+ (let ((inst (car insts)))
+ (if trace-flag
+ (pretty-print (list 'inst '= (instruction-text inst)))
+ false)
+ ((instruction-execution-proc inst)))
+ (set! instruction-count (+ instruction-count 1))
+ (execute))))))
さらに命令シーケンスの先頭に対し、最初のラベル名と紐づける。
(define (make-machine register-names ops ctrl-text)
(let ((machine (make-new-machine)))
;; レジスタの登録
(for-each (lambda (register-name)
((machine 'allocate-register) register-name))
register-names)
;; オペレーションの登録
((machine 'install-operations) ops)
;; 命令シーケンスの登録
(let ((inst-seq (assemble ctrl-text machine)))
(pretty-print inst-seq) ;; 命令シーケンスの登録
(let ((inst-seq (assemble ctrl-text machine)))
(pretty-print inst-seq)
- ((machine 'install-instruction-sequence) inst-seq))
+ ((machine 'install-instruction-sequence) (cons (car ctrl-text) inst-seq)))
machine))
fact-machineでの実行結果。§5.1で追ったのと同じ結果になった。
regsim.scm<feff>> (set-register-contents! fact-machine 'n 3) 'done regsim.scm<feff>> (fact-machine 'trace-on) regsim.scm<feff>> (start fact-machine) '(label = controller) '(inst = (assign continue (label fact-done))) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(inst = (save continue)) '(inst = (save n)) '(inst = (assign n (op -) (reg n) (const 1))) '(inst = (assign continue (label after-fact))) '(inst = (goto (label fact-loop))) '(label = fact-loop) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(inst = (save continue)) '(inst = (save n)) '(inst = (assign n (op -) (reg n) (const 1))) '(inst = (assign continue (label after-fact))) '(inst = (goto (label fact-loop))) '(label = fact-loop) '(inst = (test (op =) (reg n) (const 1))) '(inst = (branch (label base-case))) '(label = base-case) '(inst = (assign val (const 1))) '(inst = (goto (reg continue))) '(label = after-fact) '(inst = (restore n)) '(inst = (restore continue)) '(inst = (assign val (op *) (reg n) (reg val))) '(inst = (goto (reg continue))) '(label = after-fact) '(inst = (restore n)) '(inst = (restore continue)) '(inst = (assign val (op *) (reg n) (reg val))) '(inst = (goto (reg continue))) '(label = fact-done) 'done
問題 5.18
命令シーケンスと同じようにレジスタにもトレース機能を持たせる。
(define (make-register name) - (let ((contents '*unassigned*)) + (let ((contents '*unassigned*) + (trace-flag false)) (define (dispatch message) (cond ((eq? message 'get) contents) ((eq? message 'set) - (lambda (value) (set! contents value))) + (lambda (value) + (if trace-flag + (pretty-print (list 'reg '= name ': + contents '=> value)) + false) + (set! contents value))) + ((eq? message 'trace-on) + (set! trace-flag true)) + ((eq? message 'trace-off) + (set! trace-flag false)) (else (error "[register] unknown request:" message)))) dispatch))
レジスタマシン側のインターフェースに紐づける。
(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 'initialize-instruction-count)
(set! instruction-count 0))
((eq? message 'get-instruction-count)
instruction-count)
((eq? message 'trace-on)
(set! trace-flag true))
((eq? message 'trace-off)
(set! trace-flag false))
+ ((eq? message 'trace-register-on)
+ (lambda (reg-name)
+ ((lookup-register reg-name) 'trace-on)))
+ ((eq? message 'trace-register-off)
+ (lambda (reg-name)
+ ((lookup-register reg-name) 'trace-off)))
fact-machineでの実行結果。n!の結果が格納されるvalレジスタが意図通りに動いている。
> (set-register-contents! fact-machine 'n 3) 'done > ((fact-machine 'trace-register-on) 'val) > (start fact-machine) '(reg = val : *unassigned* => 1) '(reg = val : 1 => 2) '(reg = val : 2 => 6) 'done
問題 5.19
これまでのまとめ的な問題。要件をかみくだくと、以下のことができればよさそう。
(<label-name> <line-number>)の形式で、任意の箇所にブレークポイントが張れる- レジスタマシンはブレークポイントに達すると処理を中断する
(proceed-machine <machine>)で、レジスタマシンが中断した箇所から 処理を継続させることができる
まずは、ブレークポイントの管理する変数the-breakpointsを追加。
(define (make-new-machine)
(let* ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(the-ops (list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))))
(register-table (list (list 'pc pc)
(list 'flag flag)))
(instruction-count 0)
- (trace-flag false))
+ (trace-flag false)
+ (the-breakpoints '()))
the-breakpointsには、ブレークポイントを
(<label-name> <line-number>)のリストとして管理する。
(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 'initialize-instruction-count)
(set! instruction-count 0))
((eq? message 'get-instruction-count)
instruction-count)
((eq? message 'trace-on)
(set! trace-flag true))
((eq? message 'trace-off)
(set! trace-flag false))
((eq? message 'trace-register-on)
(lambda (reg-name)
((lookup-register reg-name) 'trace-on)))
((eq? message 'trace-register-off)
(lambda (reg-name)
((lookup-register reg-name) 'trace-off)))
+ ((eq? message 'set-breakpoint)
+ (lambda (label-name line-number)
+ (set! the-breakpoints
+ (cons (cons label-name line-number) the-breakpoints))))
+ ((eq? message 'cancel-breakpoint)
+ (lambda (label-name line-number)
+ (set! the-breakpoints
+ (filter (lambda (item)
+ (not (equal? item (cons label-name line-number))))
+ the-breakpoints))))
+ ((eq? message 'cancel-all-breakpoints)
+ (set! the-breakpoints '()))
+ ((eq? message 'print-breakpoints)
+ (pretty-print (list 'breakpoints '= the-breakpoints)))
現在の実行位置をcurrent-pointとして保持し、
current-pointがthe-breakpointsに含まれる場合はブレークさせる。
(define (make-new-machine)
(let* ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(the-ops (list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))))
(register-table (list (list 'pc pc)
(list 'flag flag)))
(instruction-count 0)
(trace-flag false)
- (the-breakpoints '()))
+ (the-breakpoints '())
+ (current-point '()))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(if (symbol? (car insts))
(begin
(if trace-flag
(pretty-print (list 'label '= (car insts)))
false)
+ (set! current-point (cons (car insts) 0))
(set-contents! pc (cdr insts))
(execute))
(begin
(let ((inst (car insts)))
(if trace-flag
(pretty-print (list 'inst '= (instruction-text inst)))
false)
((instruction-execution-proc inst)))
(set! instruction-count (+ instruction-count 1))
- (execute))))))
+ (set! current-point (cons (car current-point)
+ (add1 (cdr current-point))))
+ (if (member current-point the-breakpoints)
+ 'break!
+ (execute)))))))
ブレーク後に継続させるproceedでは単にexecuteを実行する。
+ ((eq? message 'proceed) + (execute)) (else (error "[machine] unknown request:" message)))) dispatch))
最後にインターフェースを追加する。
+(define (set-breakpoint machine label-name line-number) + ((machine 'set-breakpoint) label-name line-number)) +(define (cancel-breakpoint machine label-name line-number) + ((machine 'cancel-breakpoint) label-name line-number)) +(define (cancel-all-breakpoints machine) + (machine 'cancel-all-breakpoints)) +(define (proceed-machine machine) + (machine 'proceed))
gcd-machineで実行する。
regsim.scm<feff>> (define gcd-machine (make-machine '(a b t) (list (list 'rem remainder) (list '= =)) '(test-b (test (op =) (reg b) (const 0)) (branch (label gcd-done)) (assign t (op rem) (reg a) (reg b)) (assign a (reg b)) (assign b (reg t)) (goto (label test-b)) gcd-done))) regsim.scm<feff>> (set-register-contents! gcd-machine 'a 206) regsim.scm<feff>> (set-register-contents! gcd-machine 'b 40) regsim.scm<feff>> (set-breakpoint gcd-machine 'test-b 4) regsim.scm<feff>> (start gcd-machine) 'break! regsim.scm<feff>> (get-register-contents gcd-machine 'a) 40 regsim.scm<feff>> (proceed-machine gcd-machine) 'break! regsim.scm<feff>> (get-register-contents gcd-machine 'a) 6 regsim.scm<feff>> (proceed-machine gcd-machine) 'break! regsim.scm<feff>> (get-register-contents gcd-machine 'a) 4 regsim.scm<feff>> (proceed-machine gcd-machine) 'break! regsim.scm<feff>> (get-register-contents gcd-machine 'a) 2 regsim.scm<feff>> (proceed-machine gcd-machine) 'done regsim.scm<feff>> (get-register-contents gcd-machine 'a) 2
次回は「§5.3 記憶の割当てとごみ集め」から。
