問題5.12-5.13

久しぶりすぎて何やってたっけ状態です。
…、ああ、アセンブリ言語っぽいことをやってたんでした。最近大学で似たようなことやってるので食傷ぎみです。
あとデュアルディスプレイ環境入れたら、blog編集しながらScheme弄れたり、firefoxみながら何か書けたりするのですごく楽です。もっと早く入れればよかった。

5.12

inst-list,address-registers,saved-registers,register-sourcesというリスト保持変数をmake-new-machineの中につくり、machineから同名のメッセージで参照できるようにします。また、これらへの代入を実現するメッセージを接頭語としてset-をつけ最後に!をつけたもので表現します。これらに入れる情報はアセンブルする時に取得します。なおmake-new-machineの仕様は問題5.11aのものとします。えーと、だからmake-new-machineはこんな感じ。

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (inst-list '())
        (address-registers '())
        (saved-registers '())
        (register-sources '()))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (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)
              ((eq? message 'inst-list) inst-list)
              ((eq? message 'set-inst-list!)
               (lambda (x) (set! inst-list x)))
              ((eq? message 'address-registers) address-registers)
              ((eq? message 'set-address-registers!)
               (lambda (x) (set! address-registers x)))
              ((eq? message 'saved-registers) saved-registers)
              ((eq? message 'set-saved-registers!)
               (lambda (x) (set! saved-registers x)))
              ((eq? message 'register-sources) register-sources)
              ((eq? message 'set-register-sources!)
               (lambda (x) (set! register-sources x)))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

inst-list,address-registers,saved-registersは単純なリストとして実装します。register-sourcesは、その先頭要素をレジスタと同名のタグとして、その後に代入元がくるようなリストのリストとします。((n (reg a)) (val (const 1) ((op *) (reg n) (reg val)))...)のような感じ。
どのリストにも、異なる要素を追加する必要があり、つまり重複するものを入れない必要があります。なのでリストを集合と見て、次のような集合演算を作っておくと楽そうです。

(define (add-to-set x lst)
  (cond ((null? lst) (cons x '()))
        ((equal? x (car lst)) lst)
        (else (cons (car lst) (add-to-set x (cdr lst))))))

次に、アセンブル時の挙動を変更して、各集合への追加を行います。実効手続きを作るmake-execution-procedure時に行うのが簡単です。cond節の前に一回実行すればいいので、別の関数analyze-machine-inst-infoを作り、cond節の前に(analyze-machine-inst-info inst machine)を挿入するといいと思います(しかしこれは関数的ではないかも)。この時必要な情報はinstとmachineのみになります。

(define (analyze-machine-inst-info inst machine)
  (define (add-to-tagged-set tag x lst)
    (cond ((null? lst)
           (add-to-set (list tag x) lst))
          ((eq? tag (caar lst))
           (cons (cons tag (add-to-set x (cdar lst))) (cdr lst)))
          (else
           (cons (car lst) (add-to-tagged-set tag x (cdr lst))))))
  ((machine 'set-inst-list!) (add-to-set inst (machine 'inst-list)))
  (cond ((and (eq? (car inst) 'goto) (eq? (caadr inst) 'reg))
         ((machine 'set-address-registers!)
          (add-to-set (cadadr inst) (machine 'address-registers))))
        ((eq? (car inst) 'save)
         ((machine 'set-saved-registers!)
          (add-to-set (cadr inst) (machine 'saved-registers))))
        ((eq? (car inst) 'assign)
         ((machine 'set-register-sources!)
          (if (= (length (cddr inst)) 1)
              (add-to-tagged-set (cadr inst) (caddr inst) (machine 'register-sources))
              (add-to-tagged-set (cadr inst) (cddr inst) (machine 'register-sources)))))
        (else 'noact)))

saved-registersですが、今回はsaveのみを拾う対象にします。
register-sourcesはタグ付けされた集合なので、内部手続きでadd-to-tagged-setというものを別に作っておきます。またregister-sourceとなるものは、例えば(assign n (reg a))や(assign continue (label done))など、sourceが一要素のものと、(assign n (op -) (reg n) (const 1))などの複数のものがあり、これらを格納する時に区別する必要があります。区別しないでどちらもリストとして格納すれば問題はないですが、見にくくなるので今回はlengthを使って、単sourceの場合は単体で格納するようにしています。
効率はおそらくあんまりよくないです。まあプログラムが大きくなければそんなにコストも大きくはならないはずなのでいいや。
ということでこれが正しく動くかどうか確かめてみます。まずinst-list。

> (fibonacci-machine 'inst-list)
((assign continue (label fib-done))
 (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)
 (assign n (op -) (reg n) (const 2))
 (assign continue (label afterfib-n-2))
 (save val)
 (assign n (reg val))
 (restore val)
 (restore continue)
 (assign val (op +) (reg val) (reg n))
 (goto (reg continue))
 (assign val (reg n)))

重複した命令列が含まれてなくて、かつ全ての命令列が含まれていればいいはずです。問題なさそうです。次、address-registersとsaved-registers。

> (fibonacci-machine 'address-registers)
(continue)
> (fibonacci-machine 'saved-registers)
(continue n val)

問題なさそうです。最後にregister-sources。

> (fibonacci-machine 'register-sources)
((continue (label fib-done) (label afterfib-n-1) (label afterfib-n-2))
 (n ((op -) (reg n) (const 1)) ((op -) (reg n) (const 2)) (reg val))
 (val ((op +) (reg val) (reg n)) (reg n)))

うん、問題ないですね。最後のregister-sourcesなんかはデータパス図を描くときに役立ちそうです。

で、次の5.13を解いてて思ったのですが、このmachineの解析はmake-execution-procedureとは機能的に独立なので、このなかに書くよりもむしろmake-machineのところで処理するのが適当なんじゃないでしょうか。
ということで、少し変更して、controller-textからinstの列を生成するような関数とfor-eachとanalyze-machine-inst-infoを使って改変してみます。

(define (analyze-machine-info controller-text machine)
  (define (controller->insts controller-text)
    (cond ((null? controller-text) '())
          ((symbol? (car controller-text))
           (controller->insts (cdr controller-text)))
          (else (cons (car controller-text)
                      (controller->insts (cdr controller-text))))))
  (for-each (lambda (inst) 
              (analyze-machine-inst-info inst machine))
            (controller->insts controller-text)))

(define (add-to-set x lst)
  (cond ((null? lst) (cons x '()))
        ((equal? x (car lst)) lst)
        (else (cons (car lst) (add-to-set x (cdr lst))))))

(define (analyze-machine-inst-info inst machine)
  (define (add-to-tagged-set tag x lst)
    (cond ((null? lst)
           (add-to-set (list tag x) lst))
          ((eq? tag (caar lst))
           (cons (cons tag (add-to-set x (cdar lst))) (cdr lst)))
          (else
           (cons (car lst) (add-to-tagged-set tag x (cdr lst))))))
  ((machine 'set-inst-list!) (add-to-set inst (machine 'inst-list)))
  (cond ((and (eq? (car inst) 'goto) (eq? (caadr inst) 'reg))
         ((machine 'set-address-registers!)
          (add-to-set (cadadr inst) (machine 'address-registers))))
        ((eq? (car inst) 'save)
         ((machine 'set-saved-registers!)
          (add-to-set (cadr inst) (machine 'saved-registers))))
        ((eq? (car inst) 'assign)
         ((machine 'set-register-sources!)
          (if (= (length (cddr inst)) 1)
              (add-to-tagged-set (cadr inst) (caddr inst) (machine 'register-sources))
              (add-to-tagged-set (cadr inst) (cddr inst) (machine 'register-sources)))))
        (else 'noact)))

あとは、make-machineに(analyze-machine-info controller-text machine)を挿入すればいいです。

> (execute-machine-with sqrt-machine ((x 2)) guess)
guess=1.4142156862745097

ちゃんと動きます。

5.13

make-machineでレジスタを指定しなくてもいいようにしようということです。
いくつか方法があります。register nameが来るのは、assign,save,restoreの第二引数と、その他はregでtag付けされているところで、前者は各実行手続き生成の前、後者はmake-primitive-expの部分で新しくレジスタを作ればいいです。
でもそうすると記述が分散して面倒なので、5.12同様make-machine-registersという関数にまとめてしまうことにします。
5.12で重複しない命令列inst-listを作りました。これを使います。
以下がコード。

(define (make-machine-registers machine)
  (for-each (lambda (register-name)
              ((machine 'allocate-register) register-name))
            (get-register-names machine)))

(define (get-register-names machine)
  (define (extract-register-name-from-inst inst)
    (let iter ((inst inst) (reg-name-list '()))
      (cond ((null? inst) reg-name-list)
            ((or (eq? (car inst) 'assign)
                 (eq? (car inst) 'save)
                 (eq? (car inst) 'restore))
             (iter (cddr inst) (add-to-set (cadr inst) reg-name-list)))
            ((and (pair? (car inst)) (eq? (caar inst) 'reg))
             (iter (cdr inst) (add-to-set (cadar inst) reg-name-list)))
            (else
             (iter (cdr inst) reg-name-list)))))
  (define (add-list-to-set lst set)
    (if (null? lst) set (add-list-to-set (cdr lst) (add-to-set (car lst) set))))
  (let ((reg-name-list '()))
    (map (lambda (inst)
           (set! reg-name-list
                 (add-list-to-set (extract-register-name-from-inst inst)
                                  reg-name-list)))
         (machine 'inst-list))
    reg-name-list))

extract-register-name-from-instは重複を避けるためにadd-to-setを使いたいので反復で記述します。add-to-setは5.12を見てください。
これでmake-machineを次のようにかけます。

(define (make-machine ops controller-text)
  (let ((machine (make-new-machine)))
    (analyze-machine-info controller-text machine)
    (make-machine-registers machine)
    ((machine 'install-operations) ops)
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    machine))

registerの列挙をする必要がなくなりました。でもしてたほうがわかりやすかったような気もする。
実行もちゃんとできます。

> (execute-machine-with factorial-machine ((n 20)) val)
val=2432902008176640000
> (execute-machine-with gcd-machine ((a 38) (b 102)) a)
a=2
> (execute-machine-with fibonacci-machine ((n 24)) val)
val=46368

なんか忙しいからって全然やらないと終わりそうもないんで、空いてる時間に少しずつ解いて、溜まったらアップすることにします。