SICP 読み (269) 5.2 レジスタ計算機での計算
この節のゴールはデバッガらしい。breakpoint 設定しちゃってます。
問題 5.17
直前ラベルを印字しなさい、との事。これはムズい。label な情報は assemble の時にそれぞれの手続きの中に隠蔽されちゃってる訳で、これを印字するにはどうしたものか、容量の少ない脳をイタめた夕方だった訳です。
で、出てきた順にアイデアを列挙。基本的には insts なリストの car 部に命令なテキストと一緒にラベルを格納しよう、という事になっております。
- update-insts! の中でなんとかする (具体的には for-each の後又は中)
- labels を先頭から見てって云々。ケツから処理できたらシアワセ
- make-label-entry (extract-labels で呼ばれています) の中で云々
- extra-labels の中の label な処理の中でなんたら
ってコトで、とりあえず試験から作って下から順に動作確認。動いた瞬間検討は止める予定ッス。(を
(use gauche.test)
(add-load-path ".")
(load "ch5-regsim")
(test-start "5.17")
(test-section "assemble")
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(n continue val))
((m 'install-operations) (list (list '= =)
(list '- -)
(list '* *)))
(let ((insts (assemble '(controller
(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)
m)))
(test* "(car (car (car insts)))"
'controller
(car (car (car insts))))
(test* "(cdr (car (car insts)))"
'(assign continue (label fact-done))
(cdr (car (car insts))))
(test* "(car (car (cadr insts)))"
'fact-loop
(car (car (cadr insts))))
)
)
(test-end)とりあえず上記で様子を見て、大丈夫そうなら試験追加とゆー事で。
extract-labels で
extract-labels マワりを以下に修正 (一部のみ
(define (extract-labels text receive)
(if (null? text)
(receive '() '())
(extract-labels (cdr text)
(lambda (insts labels)
(let ((next-inst (car text)))
(if (symbol? next-inst)
(if (assoc next-inst labels)
(error "Dup label entry -- ASSEMBLE" next-inst)
(receive insts
; (cons (make-label-entry next-inst ;; 5.17
; insts) ;; 5.17
(cons (make-label-entry next-inst ;; 5.17
(add-label-name ;; 5.17
next-inst ;; 5.17
insts)) ;; 5.17
labels)))
(receive (cons (make-instruction next-inst)
insts)
labels)))))))
(define (add-label-name label insts)
(for-each
(lambda (inst)
(set-car! inst (cons label (instruction-text inst))))
insts)
insts)上記の試験にパスしない。
$ gosh test-5.17.scm Testing 5.17 ... <assemble>--------------------------------------------------------------------- test (car (car (car insts))), expects controller ==> ok test (cdr (car (car insts))), expects (assign continue (label fact-done)) ==> ok test (car (car (cadr insts))), expects fact-loop ==> ERROR: GOT controller failed. discrepancies found. Errors are: test (car (car (cadr insts))): expects fact-loop => got controller $
ケツから処理してるハズなんですが何故だ、と言いつつカブセてる可能性に気付く。add-label-name を
(define (add-label-name label insts)
(for-each
(lambda (inst)
(if (null? (car (car inst)))
(set-car! inst (cons label (instruction-text inst)))))
insts)
insts)のようにしたら 3 つの試験にはパス。
$ gosh test-5.17.scm Testing 5.17 ... <assemble>--------------------------------------------------------------------- test (car (car (car insts))), expects controller ==> ok test (cdr (car (car insts))), expects (assign continue (label fact-done)) ==> ok test (car (car (cadr insts))), expects fact-loop ==> ok passed. $
で、どう試験したものか、と言いつつ短気を起こして (以下略
$ gosh
gosh> (add-load-path ".")
("." "/usr/share/gauche/site/lib" "/usr/share/gauche/0.8.8/lib")
gosh> (load "ch5-regsim")
#t
gosh> (define m (make-machine '(n continue val)
(list (list '= =)
(list '- -)
(list '* *))
'(controller
(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)))
m
gosh> (m 'trace-on)
#t
gosh> (set-register-contents! m 'n 1)
done
gosh> (m 'start)
(controller assign continue (label fact-done))
(fact-loop test (op =) (reg n) (const 1))
(fact-loop branch (label base-case))
(base-case assign val (const 1))
(base-case goto (reg continue))
done
gosh> (set-register-contents! m 'n 2)
done
gosh> (m 'start)
(controller assign continue (label fact-done))
(fact-loop test (op =) (reg n) (const 1))
(fact-loop branch (label base-case))
(fact-loop save continue)
(fact-loop save n)
(fact-loop assign n (op -) (reg n) (const 1))
(fact-loop assign continue (label after-fact))
(fact-loop goto (label fact-loop))
(fact-loop test (op =) (reg n) (const 1))
(fact-loop branch (label base-case))
(base-case assign val (const 1))
(base-case goto (reg continue))
(after-fact restore n)
(after-fact restore continue)
(after-fact assign val (op *) (reg n) (reg val))
(after-fact goto (reg continue))
done
gosh>もう少し追試します。なんとなくイケてるっぽくはあるのですが。
追記
以下の修正もしてますが、エントリに盛り込むのを忘れとりました (汗
(define (make-instruction text) (cons (cons '() text) '())) (define (instruction-text inst) (cdr (car inst)))
さらに追記
make-new-machine 方面の修正ログも載せていない。とりあえず一部のみ以下に。
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
(if trace ;; 5.16
(begin ;; 5.16
; (display (instruction-text (car insts))) ;; 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)))))うーん。イタい。しかも出力微妙だし。
