SICP 読み (261) 5.2 レジスタ計算機での計算
いやはや。久々にハマッた。少い時間で無理矢理ヤッてるからこうなるのでしょうが、まだまだ修行が足らんな。(何
問題 5.12
一応考えた通りに動作するようになっている模様ですが、まだまだアヤしげ。昨晩書き残したエントリの下書きを入れつつログを以下に。
まず、昨晩ですが微妙な誤りに気がつき要件を整理している。曰く
まず _a list of all instructions_ ですが、これはリストな例で言えば
((assign (((restore n) (restore continue) (assign n (op -) (reg n) (const 2)) (以下略)) ((assign n (reg val)) (restore val) (restore continue) (以下略)))) (goto (((test (op <) (reg n) (const 2)) (以下略)) ((reg continue)))) (branch (略)))
みたいな感じ (assemble された手続きは略して書いてますが) になるはず。
次とその次の _a list of the registers used to hold entry points_ と _a list of the registers that are saved or restored_ はそのままで良いのかな??
最後の _for each register, a list of the sources from which it is assigned_ は
((continue (((restore n) (restore continue) (以下略))
((assign n (reg val)) (restore val) (以下略))))
(n (((op -) (reg n) (const 1))
((op -) (reg n) (const 2))))
(val (以下略)))みたいな感じになるんだとしたら、昨晩エントリな手続きはダウト。
で、正しくは以下、と書いているがこれが大間違い。
(define (set-list-of-inst l)
(let ((elem (assoc (car l) list-of-inst)))
(if elem
(set-car! (cadr elem) (cadr l))
(set! list-of-inst (cons l list-of-inst))))
'done)
(define (set-hold-entry-points l)
(if (dup-element? l hold-entry-points)
(set! hold-entry-points (cons l hold-entry-points)))
'done)
(define (set-saved-or-restored l)
(if (dup-element? l saved-of-restored)
(set! saved-of-restored (cons l saved-of-restored)))
'done)
(define (set-list-of-reg l)
(let ((elem (assoc (car l) list-of-reg)))
(if elem
(if (dup-element? (cadr l) list-of-reg)
(set-car! (cadr elem) (cadr l)))
(set! list-of-reg (cons l list-of-reg))))
'done)上記の内、set-list-of-reg と set-list-of-inst がナニ。あとは上記手続きの呼び出しを make-goto、make-branch、make-primitive-exp と make-assign に盛り込んで make-new-machine の dispatch 手続きも修正入れたのは良いのですが、動作不良で死亡、というのが昨晩のざっくりしたストーリーだったりします。
今回ハマッた件については、scheme に関する理解を深めるためにも、経緯の検証はぜったいヤるべきだと思っていますが、現時点ではそのリキはございません。とりあえず、現時点でのソース及び出力をソースから以下に。
(define (make-machine register-names ops controller-text)
(let ((machine (make-new-machine)))
(for-each (lambda (register-name)
((machine 'allocate-register) register-name))
register-names)
((machine 'install-operations) ops)
((machine 'install-instruction-sequence)
(assemble controller-text machine))
machine))
(define (make-register name)
(let ((contents '*unassigned*))
(define (dispatch message)
(cond ((eq? message 'get) contents)
((eq? message 'set)
(lambda (value) (set! contents value)))
(else
(error "Unknown request -- REGISTER" message))))
dispatch))
(define (get-contents register)
(register 'get))
(define (set-contents! register value)
((register 'set) value))
;;**original (unmonitored) version from section 5.2.1
(define (make-stack)
(let ((s '()))
(define (push x)
(set! s (cons x s)))
(define (pop)
(if (null? s)
(error "Empty stack -- POP")
(let ((top (car s)))
(set! s (cdr s))
top)))
(define (initialize)
(set! s '())
'done)
(define (dispatch message)
(cond ((eq? message 'push) push)
((eq? message 'pop) (pop))
((eq? message 'initialize) (initialize))
(else (error "Unknown request -- STACK"
message))))
dispatch))
(define (pop stack)
(stack 'pop))
(define (push stack value)
((stack 'push) value))
;;**monitored version from section 5.2.4
(define (make-stack)
(let ((s '())
(number-pushes 0)
(max-depth 0)
(current-depth 0))
(define (push x)
(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 "Empty stack -- POP")
(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)
(newline)
(display (list 'total-pushes '= number-pushes
'maximum-depth '= max-depth)))
(define (dispatch message)
(cond ((eq? message 'push) push)
((eq? message 'pop) (pop))
((eq? message 'initialize) (initialize))
((eq? message 'print-statistics)
(print-statistics))
(else
(error "Unknown request -- STACK" message))))
dispatch))
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(list-of-inst '())
(hold-entry-points '())
(saved-or-restored '())
(list-of-reg '()))
(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))))
;; exersize 5.12
(define (get-list-of-inst) list-of-inst)
(define (get-hold-entry-points) hold-entry-points)
(define (get-saved-or-restored) saved-or-restored)
(define (get-list-of-reg) list-of-reg)
(define (dup-element? x y)
(define (dup-elem-iter l)
(cond ((null? l) #f)
((equal? x (car l)) #t)
(else
(dup-elem-iter (cdr l)))))
(dup-elem-iter y))
(define (set-list-of-inst l)
(let ((elem (assoc (car l) list-of-inst)))
(if elem
(if (not (dup-element? (cadr l) (cdr elem)))
(set-cdr! elem (cons (cadr l) (cdr elem))))
(set! list-of-inst (cons l list-of-inst))
))
'done)
(define (set-hold-entry-points l)
(if (not (dup-element? l hold-entry-points))
(set! hold-entry-points (cons l hold-entry-points)))
'done)
(define (set-saved-or-restored l)
(if (not (dup-element? l saved-or-restored))
(set! saved-or-restored (cons l saved-or-restored)))
'done)
(define (set-list-of-reg l)
(let ((elem (assoc (car l) list-of-reg)))
(if elem
(let ((elem-cdr (cdr elem)))
(if (not (dup-element? (cadr l) elem-cdr))
(set-cdr! elem (cons (cadr l) (cdr elem)))))
(set! list-of-reg (cons l list-of-reg))
))
'done)
;; exersize 5.12
(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))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
((instruction-execution-proc (car insts)))
(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)
;; exersize 5.12
((eq? message 'get-inst) (get-list-of-inst))
((eq? message 'get-entry) (get-hold-entry-points))
((eq? message 'get-stack) (get-saved-or-restored))
((eq? message 'get-reg) (get-list-of-reg))
((eq? message 'set-inst) set-list-of-inst)
((eq? message 'set-entry) set-hold-entry-points)
((eq? message 'set-stack) set-saved-or-restored)
((eq? message 'set-reg) set-list-of-reg)
;; exersize 5.12
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
(define (start machine)
(machine 'start))
(define (get-register-contents machine register-name)
(get-contents (get-register machine register-name)))
(define (set-register-contents! machine register-name value)
(set-contents! (get-register machine register-name) value)
'done)
(define (get-register machine reg-name)
((machine 'get-register) reg-name))
(define (assemble controller-text machine)
(extract-labels controller-text
(lambda (insts labels)
(update-insts! insts labels machine)
insts)))
(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
insts)
labels)))
(receive (cons (make-instruction next-inst)
insts)
labels)))))))
(define (update-insts! insts labels machine)
(let ((pc (get-register machine 'pc))
(flag (get-register machine 'flag))
(stack (machine 'stack))
(ops (machine 'operations)))
(for-each
(lambda (inst)
(set-instruction-execution-proc!
inst
(make-execution-procedure
(instruction-text inst) labels machine
pc flag stack ops)))
insts)))
(define (make-instruction text)
(cons text '()))
(define (instruction-text inst)
(car inst))
(define (instruction-execution-proc inst)
(cdr inst))
(define (set-instruction-execution-proc! inst proc)
(set-cdr! inst proc))
(define (make-label-entry label-name insts)
(cons label-name insts))
(define (lookup-label labels label-name)
(let ((val (assoc label-name labels)))
(if val
(cdr val)
(error "Undefined label -- ASSEMBLE" label-name))))
(define (make-execution-procedure inst labels machine
pc flag stack ops)
(cond ((eq? (car inst) 'assign)
(make-assign inst machine labels ops pc))
((eq? (car inst) 'test)
(make-test inst machine labels ops flag pc))
((eq? (car inst) 'branch)
(make-branch inst machine labels flag pc))
((eq? (car inst) 'goto)
(make-goto inst machine labels pc))
((eq? (car inst) 'save)
(make-save inst machine stack pc))
((eq? (car inst) 'restore)
(make-restore inst machine stack pc))
((eq? (car inst) 'perform)
(make-perform inst machine labels ops pc))
(else (error "Unknown instruction type -- ASSEMBLE"
inst))))
(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))))
((machine 'set-reg) (list (assign-reg-name inst) value-exp)) ;; exersize 5.12
(lambda () ; execution procedure for assign
(set-contents! target (value-proc))
(advance-pc pc)))))
(define (assign-reg-name assign-instruction)
(cadr assign-instruction))
(define (assign-value-exp assign-instruction)
(cddr assign-instruction))
(define (advance-pc pc)
(set-contents! pc (cdr (get-contents pc))))
(define (make-test inst machine labels operations flag pc)
(let ((condition (test-condition inst)))
(if (operation-exp? condition)
(let ((condition-proc
(make-operation-exp
condition machine labels operations)))
(lambda ()
(set-contents! flag (condition-proc))
(advance-pc pc)))
(error "Bad TEST instruction -- ASSEMBLE" inst))))
(define (test-condition test-instruction)
(cdr test-instruction))
(define (make-branch inst machine labels flag pc)
(let ((dest (branch-dest inst)))
(if (label-exp? dest)
(let ((insts
(lookup-label labels (label-exp-label dest))))
((machine 'set-inst) (list 'branch (map car insts))) ;; exersize 5.12
(lambda ()
(if (get-contents flag)
(set-contents! pc insts)
(advance-pc pc))))
(error "Bad BRANCH instruction -- ASSEMBLE" inst))))
(define (branch-dest branch-instruction)
(cadr branch-instruction))
(define (make-goto inst machine labels pc)
(let ((dest (goto-dest inst)))
(cond ((label-exp? dest)
(let ((insts
(lookup-label labels
(label-exp-label dest))))
((machine 'set-inst) (list 'goto (map car insts))) ;; exersize 5.12
(lambda () (set-contents! pc insts))))
((register-exp? dest)
(let ((reg
(get-register machine
(register-exp-reg dest))))
((machine 'set-entry) (register-exp-reg dest)) ;; exersize 5.12
(lambda ()
(set-contents! pc (get-contents reg)))))
(else (error "Bad GOTO instruction -- ASSEMBLE"
inst)))))
(define (goto-dest goto-instruction)
(cadr goto-instruction))
(define (make-save inst machine stack pc)
(let ((reg (get-register machine
(stack-inst-reg-name inst))))
((machine 'set-stack) (stack-inst-reg-name inst)) ;; exersize 5.12
(lambda ()
(push stack (get-contents reg))
(advance-pc pc))))
(define (make-restore inst machine stack pc)
(let ((reg (get-register machine
(stack-inst-reg-name inst))))
((machine 'set-stack) (stack-inst-reg-name inst)) ;; exersize 5.12
(lambda ()
(set-contents! reg (pop stack))
(advance-pc pc))))
(define (stack-inst-reg-name stack-instruction)
(cadr stack-instruction))
(define (make-perform inst machine labels operations pc)
(let ((action (perform-action inst)))
(if (operation-exp? action)
(let ((action-proc
(make-operation-exp
action machine labels operations)))
(lambda ()
(action-proc)
(advance-pc pc)))
(error "Bad PERFORM instruction -- ASSEMBLE" inst))))
(define (perform-action inst) (cdr inst))
(define (make-primitive-exp exp machine labels)
(cond ((constant-exp? exp)
(let ((c (constant-exp-value exp)))
(lambda () c)))
((label-exp? exp)
(let ((insts
(lookup-label labels
(label-exp-label exp))))
((machine 'set-inst) (list 'assign (map car insts))) ;; exersize 5.12
(lambda () insts)))
((register-exp? exp)
(let ((r (get-register machine
(register-exp-reg exp))))
(lambda () (get-contents r))))
(else
(error "Unknown expression type -- ASSEMBLE" exp))))
(define (register-exp? exp) (tagged-list? exp 'reg))
(define (register-exp-reg exp) (cadr exp))
(define (constant-exp? exp) (tagged-list? exp 'const))
(define (constant-exp-value exp) (cadr exp))
(define (label-exp? exp) (tagged-list? exp 'label))
(define (label-exp-label exp) (cadr exp))
(define (make-operation-exp exp machine labels operations)
(let ((op (lookup-prim (operation-exp-op exp) operations))
(aprocs
(map (lambda (e)
(if (label-exp? e)
(error "cannot place label element -- ASSEMBLE" e)
(make-primitive-exp e machine labels)))
(operation-exp-operands exp))))
(lambda ()
(apply op (map (lambda (p) (p)) aprocs)))))
(define (operation-exp? exp)
(and (pair? exp) (tagged-list? (car exp) 'op)))
(define (operation-exp-op operation-exp)
(cadr (car operation-exp)))
(define (operation-exp-operands operation-exp)
(cdr operation-exp))
(define (lookup-prim symbol operations)
(let ((val (assoc symbol operations)))
(if val
(cadr val)
(error "Unknown operation -- ASSEMBLE" symbol))))
;; from 4.1
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
; false))
#f))で、この評価器に fib なソレを吸わせてみたのが以下。
gosh> (add-load-path ".")
("." "/usr/share/gauche/site/lib" "/usr/share/gauche/0.8.7/lib")
gosh> (load "ch5-regsim.scm")
#t
gosh> (define m (make-machine
'(n continue val)
(list (list '< <) (list '- -) (list '+ +))
'(controller
(assign continue (label fib-done))
fib-loop
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
;; set up to compute Fib(n - 1)
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
afterfib-n-1
(restore n)
(restore continue)
;; set up to compute Fib(n - 2)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
afterfib-n-2
(assign n (reg val))
(restore val)
(restore continue)
(assign val
(op +) (reg val) (reg n))
(goto (reg continue))
immediate-answer
(assign val (reg n))
(goto (reg continue))
fib-done)))
m
gosh> (m 'get-inst)
((goto
((test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
#0=(restore n)
#1=(restore continue)
#2=(assign n (op -) (reg n) (const 2))
#3=(save continue)
#4=(assign continue (label afterfib-n-2))
#5=(save val)
#6=(goto (label fib-loop))
#7=(assign n (reg val))
#8=(restore val)
#9=(restore continue)
#10=(assign val (op +) (reg val) (reg n))
#11=(goto (reg continue))
#12=(assign val (reg n))
#13=(goto (reg continue))))
(branch (#12# #13#))
(assign (#7# #8# #9# #10# #11# #12# #13#)
(#0# #1# #2# #3# #4# #5# #6# #7# #8# #9# #10# #11# #12# #13#)
()))
;; 整形してみたもの
((goto
((test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
(assign val (reg n))
(goto (reg continue))))
(branch
((assign val (reg n))
(goto (reg continue))))
(assign
((assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
(assign val (reg n))
(goto (reg continue)))
((restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
(assign val (reg n))
(goto (reg continue)))
()))
;; 整形してみたもの
gosh> (m 'get-entry)
(continue)
gosh> (m 'get-stack)
(val n continue)
gosh> (m 'get-reg)
((val
((reg n))
((op +) (reg val) (reg n)))
(n
((reg val))
((op -) (reg n) (const 2))
((op -) (reg n) (const 1)))
(continue
((label afterfib-n-2))
((label afterfib-n-1))
((label fib-done))))
gosh>とりあえず思った通りには動作しているんだと思いたいのですが ...
# 検証は別途で。
