問題5.9-5.11

うーん、3月中に終わらせるとか言ったけどあれはなかったことにします。いやほんと別の用事がいろいろあって…;;;
続き。

5.9

これはmake-operation-expの中でmaka-primitive-expを使って実行手続きを構成してるからです。なので渡す際にそれがlabel式であるかチェックするだけでいいはずです。まずlabelを受け付ける文を確かめてみます。

(define label-test-machine
  (make-machine
   '(n)
   `((print ,print) (newline ,newline))
   '(test-label
       (assign n (const 1))
       (perform (op print) (reg n))
       (perform (op newline))
       (perform (op print) (label test-label))
     done)))

こんなのを作って実行してみます。

> (start label-test-machine)
1
(((assign n (const 1)) . #<procedure>) ((perform (op print) (reg n)) . #<procedure>) ((perform (op newline)) . #<procedure>) ((perform (op print) (label test-label)) . #<procedure>))done

受け付けます。labelは制御図の中にのみ現れるオブジェクトなので機械演算が受け付けるのはシミュレーションとしては不自然です。なのでこれを修正します。

(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 "machine syntax error: label can't be op's argument" e)
                    (make-primitive-exp e machine labels)))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (map (lambda (p) (p)) aprocs)))))

すると

> (define label-test-machine
  (make-machine
   '(n)
   `((print ,print) (newline ,newline))
   '(test-label
       (assign n (const 1))
       (perform (op print) (reg n))
       (perform (op newline))
       (perform (op print) (label test-label))
     done)))
. machine syntax error: label can't be op's argument (label test-label)

エラーを出せました。

5.10

新しい構文を作れとのことです。今回の実装では制御命令列は実行手続きの列に変換されるのでmake-execution-procedureに新しい構文の場合の実行手続き生成の分岐を追加してあげるだけでおけーだと思います。
なのでどんな構文を追加するかだけ悩めばいいです。
適当に調べてみるとアセンブラの命令では算術演算とか論理演算が命令で組み込まれているようです(というかそうじゃないと計算できないのか)。論理演算はちょっと大変そうなので算術演算で特に二引数のみのを組み込んでみます。
まず構文。

(<op> <reg> [(reg <reg>) or (const <num>)] [(reg <reg>) or (const <num>)])

構文の抽出手続き。

(define (math-reg-name inst) (cadr inst))
(define (math-reg1-exp inst) (caddr inst))
(define (math-reg2-exp inst) (cadddr inst))

実行手続き生成手続き。

(define (make-addition inst machine labels pc)
  (let ((target (get-register machine (math-reg-name inst)))
        (reg1-proc (make-primitive-exp (math-reg1-exp inst) machine labels))
        (reg2-proc (make-primitive-exp (math-reg2-exp inst) machine labels)))
    (lambda ()
      (set-contents! target (+ (reg1-proc) (reg2-proc)))
      (advance-pc pc))))

make-execution-procedureに追加。

(define (make-execution-procedure inst labels machine pc flag stack ops)
  (cond ...
        ((eq? (car inst) 'add)
         (make-addition inst machine labels pc))
        (else
         (error "Unknown instruction type -- ASSEMBLE" inst))))

実行。

> (define add-test-machine
    (make-machine
     '(n)
     '()
     '(  (assign n (const 1))
         (add n (reg n) (const 1))
       done)))
> (execute-machine-with add-test-machine () n)
n=2

おけーのようです。
で、sub,mul,divも同じように作れるんでコピペしてちょっと変更してやってもいいですが、make-additionをみれば分かる通り変える場所なんて一ヶ所なので、汎用関数make-math-exec-procを作った方がいいです。上では忘れてましたが、make-primitive-expを使うときにlabelでないことを保障する必要があるのでそれを追加します。あとdivについては0割りを考慮する必要がありますが、実際のアセンブラではOSにエラーを渡したり？してるような感じみたいです。なので今回は何もしません。Lisp評価器が捕捉してくれるはずです。

(define (make-math-exec-proc inst machine labels pc op)
  (let ((target (get-register machine (math-reg-name inst)))
        (reg1-proc 
         (if (label-exp? (math-reg1-exp inst))
             (error "machine syntax error: label can't be op's argument" (math-reg1-exp inst))
             (make-primitive-exp (math-reg1-exp inst) machine labels)))
        (reg2-proc
         (if (label-exp? (math-reg2-exp inst))
             (error "machine syntax error: label can't be op's argument" (math-reg1-exp inst))
             (make-primitive-exp (math-reg2-exp inst) machine labels))))
    (lambda ()
      (set-contents! target (op (reg1-proc) (reg2-proc)))
      (advance-pc pc))))

(define (make-addition inst machine labels pc) (make-math-exec-proc inst machine labels pc +))
(define (make-subtraction inst machine labels pc) (make-math-exec-proc inst machine labels pc -))
(define (make-multiplication inst machine labels pc) (make-math-exec-proc inst machine labels pc *))
(define (make-division inst machine labels pc) (make-math-exec-proc inst machine labels pc /))

でおっけーです。もっと面白い構文の方がよかったかな。

5.11

a.

えーまだあるのか。どこだろう…。

…。

あぁ、afterfib-n-2のとこですね。

(assign n (reg val))
(restore val)

とわざわざ2命令使っているところを

(restore n)

とすることができます。こうするとnにはFib(n-1)が入っていて、valにはFib(n-2)が入ってることになります。どっちにしろ足してvalに入れるだけなので同じことになります。

b.

親切にsaveを変更すればいいと書いてあります。スタックに積まれるデータの形式を変更すればいいだけです。(値 . レジスタ名)みたいな対として表現すればいいと思います。
こんな感じ。

(define (make-save inst machine labels stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (cons (get-contents reg) (stack-inst-reg-name inst)))
      (if *trace-switch*
          (let ((contents (get-contents reg)))
            (if (pair? contents)
                (push *trace-stack* (lookup-label-name labels contents))
                (push *trace-stack* contents))
            (display-stack *trace-stack*)))
      (advance-pc pc))))

(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (let ((obj (pop stack)))
        (if (eq? (cdr obj) (stack-inst-reg-name inst))
            (set-contents! reg (car obj))
            (error "restore wrong register" (stack-inst-reg-name inst))))
      (if *trace-switch*
          (begin
            (pop *trace-stack*)
            (display-stack *trace-stack*)))
      (advance-pc pc))))

> (execute-machine-with factorial-machine ((n 10)) val)
val=3628800
> (execute-machine-with fibonacci-machine ((n 10)) val)
val=55

ちゃんと動きます。この場合、fibonacci-machineにa.の変更を加えるとエラーになります。

> (execute-machine-with fibonacci-machine ((n 10)) val)
. restore wrong register n

c.

make-machineは最初に全部のregisterを引数にとるからそれらについて専用のスタックを用意し、あとは適宜saveとrestoreを変更する必要があります。
なので、まずmake-new-machineのstackを変更します。初期値をnullにし、make-machineの中で各レジスタ毎に(レジスタ名 . )という対を加えてリストとして保持することにします。initialize-stackはリストの全体に対する演算に変更するだけでいいです(そうするとstacksという名前の方がいい気がしますが、変更すると他の部分で変更しないといけない部分が多すぎるのでやめます)。
saveとrestoreはstackの中を走査して同名のスタックに対してpush,popを行うようにします。走査の際、stackは連想リストと同じ構造になっているのでassocが使えます(あるいはregisterのデータ構造を変更してスタックへのポインタを持ってもいいと思います。でもちょっと依存が強すぎるかもしれないんで今回は走査でやります)。
以上を踏まえるとこんな感じになります。

(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each
     (lambda (register-name)
       ((machine 'allocate-register) register-name)
       ((machine 'make-named-stack) register-name)); changed
     register-names)
    ((machine 'install-operations) ops)
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    machine))

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack '())
        (the-instruction-sequence '()))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda ()
                         (map (lambda (named-stack)               ;changed
                                ((cdr named-stack) 'initialize))  ;
                              stack)))))                          ;
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (make-named-stack reg-name)                         ;
        (set! stack (cons (cons reg-name (make-stack)) stack)))   ;
      ...
      (define (dispatch message)
        (cond ...
              ((eq? message 'make-named-stack) make-named-stack)  ;
              ...
      dispatch)))

(define (make-save inst machine labels stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (let ((named-stack (assoc (stack-inst-reg-name inst) stack))); changed
        (push (cdr named-stack) (get-contents reg)))               ;
         ...
      (advance-pc pc))))

(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (let ((named-stack (assoc (stack-inst-reg-name inst) stack))); changed
        (set-contents! reg (pop (cdr named-stack))))               ;
        ...
      (advance-pc pc))))

まずちゃんと動くかどうか確かめます。

> (execute-machine-with factorial-machine ((n 10)) val)
val=3628800
> (execute-machine-with fibonacci-machine ((n 20)) val)
val=6765

動くみたいです。次にスタック毎にpush,popされるのかどうか確かめてみます。

(define test-machine
  (make-machine
   '(a b)
   '()
   '(  (save a)
       (save b)
       (restore a)
       (restore b))))

> (execute-machine-with test-machine ((a 3) (b 8)) a b)
a=3
b=8

最初のバージョンだとaとbのレジスタの内容は入れ替わるはずですが、ちゃんと保持されています。ということでスタック毎にpush,popできているようです。

とりあえずここまで。