問題5.4-5.8

sicp

レジスタ計算機続き。execute-machine-withは昨日の日記を見てください。

5.4

再帰をスタックを使って表現するとこですね。図は省略で。でもちゃんと描いてます。描いた方がわかりやすいです。

a.
(define expt-machine
  (make-machine
   '(b n val continue)
   `((* ,*) (- ,-) (= ,=))
   '(  (assign continue (label done))
     expt-loop
       (test (op =) (reg n) (const 0))
       (branch (label test-true))
       (save b)
       (save continue)
       (assign continue (label expt-*-loop))
       (assign n (op -) (reg n) (const 1))
       (goto (label expt-loop))
     expt-*-loop
       (restore continue)
       (restore b)
       (assign val (op *) (reg b) (reg val))
       (goto (reg continue))
     test-true
       (assign val (const 1))
       (goto (reg continue))
     done)))

こうかな。スタックのとこが少しややこしい。

> (execute-machine-with expt-machine ((b 2) (n 0)) val)
val=1
> (execute-machine-with expt-machine ((b 2) (n 1)) val)
val=2
> (execute-machine-with expt-machine ((b 2) (n 4)) val)
val=16
> (execute-machine-with expt-machine ((b 2) (n 10)) val)
val=1024
> (execute-machine-with expt-machine ((b 5) (n 23)) val)
val=11920928955078125
> (execute-machine-with expt-machine ((b 5) (n 10)) val)
val=9765625
> (execute-machine-with expt-machine ((b 5) (n 0)) val)
val=1

おけーのようです。

b.

反復の方はスタックいらないから簡単です。1章の方でやった再帰的プロセスと反復的プロセスの計算スペースの消費量の違いがちゃんと分かるようになってていいですね。

(define expt-iter-machine
  (make-machine
   '(n c p b)
   `((- ,-) (* ,*) (= ,=))
   '(  (assign c (reg n))
       (assign p (const 1))
     expt-iter
       (test (op =) (reg c) (const 0))
       (branch (label done))
       (assign c (op -) (reg c) (const 1))
       (assign p (op *) (reg b) (reg p))
       (goto (label expt-iter))
     done)))

registerが多くなるけど再帰より簡単に書けます。

> (execute-machine-with expt-iter-machine ((b 2) (n 10)) p)
p=1024
> (execute-machine-with expt-iter-machine ((b 2) (n 0)) p)
p=1
> (execute-machine-with expt-iter-machine ((b 2) (n 20)) p)
p=1048576
> (execute-machine-with expt-iter-machine ((b 10) (n 3)) p)
p=1000
> (execute-machine-with expt-iter-machine ((b 10) (n 8)) p)
p=100000000

結果も大丈夫のようです。

5.5

うわー面倒くさそう。面倒だからスタックの状態が変化したとこを捕捉して表示すればいいじゃん、と思ったら後ろの方の問題に似たようなのありますね。とりあえずスタックに自身を表示するだけの関数display-stackを追加して、saveとrestoreの実行手続きの中でそれを呼び出すようにしてみます。
というわけでmake-stackにこんなのを追加。

(define (display-stack)
  (display "stack = ")
  (display s)
  (newline))

(define (dispatch message)
  (cond ...
        ((eq? message 'display-stack) display-stack)
        ...

関数的に書きたいのでこんな糖衣構文を追加。

(define (display-stack stack) ((stack 'display-stack)))

make-saveとmake-restoreをこんな風に変更。

(define (make-save inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (get-contents reg))
      (display-stack stack)
      (advance-pc pc))))

(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (set-contents! reg (pop stack))
      (display-stack stack)
      (advance-pc pc))))

これで実行時にスタックを表示してくれるはず。

> (execute-machine-with factorial-machine ((n 3)) val)
stack = (())
stack = (3 ())
stack = ((((restore n) . #<procedure>) ((restore continue) . #<procedure>) ((assign val (op *) (reg n) (reg val)) . #<procedure>) ((goto (reg continue)) . #<procedure>) ((assign val (const 1)) . #<procedure>) ((goto (reg continue)) . #<procedure>)) 3 ())
stack = (2 (((restore n) . #<procedure>) ((restore continue) . #<procedure>) ((assign val (op *) (reg n) (reg val)) . #<procedure>) ((goto (reg continue)) . #<procedure>) ((assign val (const 1)) . #<procedure>) ((goto (reg continue)) . #<procedure>)) 3 ())
stack = ((((restore n) . #<procedure>) ((restore continue) . #<procedure>) ((assign val (op *) (reg n) (reg val)) . #<procedure>) ((goto (reg continue)) . #<procedure>) ((assign val (const 1)) . #<procedure>) ((goto (reg continue)) . #<procedure>)) 3 ())
stack = (3 ())
stack = (())
stack = ()
val=6

おう…。そうでした、labelは次の実行列のポインタなので表示してもこんなんにしかならないんだった。じゃあグローバルに勝手にスタックを作って、実行列はシンボル'exe-procに変換し、自己評価的な値、というかアトムはそのままでsave時に積んで表示するようにしてみます。

(define *trace-stack* (make-stack))

(define (make-save inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (get-contents reg))
      (if (pair? (get-contents reg))
          (push *trace-stack* 'exe-proc)
          (push *trace-stack* (get-contents reg)))
      (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 ()
      (set-contents! reg (pop stack))
      (pop *trace-stack*)
      (display-stack *trace-stack*)
      (advance-pc pc))))

今度は

> (execute-machine-with factorial-machine ((n 4)) val)
stack = (())
stack = (4 ())
stack = (exe-proc 4 ())
stack = (3 exe-proc 4 ())
stack = (exe-proc 3 exe-proc 4 ())
stack = (2 exe-proc 3 exe-proc 4 ())
stack = (exe-proc 3 exe-proc 4 ())
stack = (3 exe-proc 4 ())
stack = (exe-proc 4 ())
stack = (4 ())
stack = (())
stack = ()
val=24

うん、大丈夫そうです。でもexe-procではなくlabelの名前を表示できればもっといいです。結構コストが重いですが、labelsの中を上ではexe-procに置き換えてる実行手続きで走査して一致したlabelの名前を返す関数があればいいように思います。make-saveはlabelsを引数にとらないのでこれを渡してやる必要があります。そうするとmake-saveを呼ぶmake-execution-procedureの呼び出し部分も変える必要があります。

(define (val-assoc value records)
  (cond ((null? records) false)
        ((equal? value (cdar records)) (car records))
        (else (val-assoc value (cdr records)))))

(define (lookup-label-name labels exe-proc)
  (let ((recode (val-assoc exe-proc labels)))
    (if recode
        (car recode)
        'unknowned-exe-proc)))

(define (make-save inst machine labels stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (get-contents reg))
      (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-execution-procedure inst labels machine pc flag stack ops)
  (cond ...
        ((eq? (car inst) 'save)
         (make-save inst machine labels stack pc))
        ...

うーんどんどん原形から離れてく…。実行してみます。

> (execute-machine-with factorial-machine ((n 4)) val)
stack = (())
stack = (4 ())
stack = (after-fact 4 ())
stack = (3 after-fact 4 ())
stack = (after-fact 3 after-fact 4 ())
stack = (2 after-fact 3 after-fact 4 ())
stack = (after-fact 3 after-fact 4 ())
stack = (3 after-fact 4 ())
stack = (after-fact 4 ())
stack = (4 ())
stack = (())
stack = ()
val=24

> (execute-machine-with fibonacci-machine ((n 4)) val)
stack = (())
stack = (4 ())
stack = (afterfib-n-1 4 ())
stack = (3 afterfib-n-1 4 ())
stack = (afterfib-n-1 3 afterfib-n-1 4 ())
stack = (2 afterfib-n-1 3 afterfib-n-1 4 ())
stack = (afterfib-n-1 3 afterfib-n-1 4 ())
stack = (3 afterfib-n-1 4 ())
stack = (afterfib-n-1 3 afterfib-n-1 4 ())
stack = (1 afterfib-n-1 3 afterfib-n-1 4 ())
stack = (afterfib-n-1 3 afterfib-n-1 4 ())
stack = (3 afterfib-n-1 4 ())
stack = (afterfib-n-1 4 ())
stack = (4 ())
stack = (afterfib-n-1 4 ())
stack = (1 afterfib-n-1 4 ())
stack = (afterfib-n-1 4 ())
stack = (4 ())
stack = (())
stack = ()
stack = (())
stack = (2 ())
stack = (afterfib-n-2 2 ())
stack = (2 afterfib-n-2 2 ())
stack = (afterfib-n-2 2 ())
stack = (2 ())
stack = (afterfib-n-2 2 ())
stack = (1 afterfib-n-2 2 ())
stack = (afterfib-n-2 2 ())
stack = (2 ())
stack = (())
stack = ()
val=3

まあわかりやすくなりました。さらにわかりやすくトレースするためにはstackの変化時にレジスタの値も表示できるようにすればいいと思います。でもやりません。毎回stackのトレースをするのは邪魔だし遅くなるので、*trace-switch*なんかを作ってtraceするかどうか分岐させるといいと思います。

> (set! *trace-switch* false)
> (execute-machine-with factorial-machine ((n 3)) val)
val=6
> (set! *trace-switch* true)
> (execute-machine-with factorial-machine ((n 3)) val)
stack = (())
stack = (3 ())
stack = (after-fact 3 ())
stack = (2 after-fact 3 ())
stack = (after-fact 3 ())
stack = (3 ())
stack = (())
stack = ()
val=6

この問題はこんな感じで。机上シミュレートしてないけど。

5.6

fibonacci machineに余分なsaveとrestoreがあるようです。よく読んでみるとafter-fib-n-1のところでcontinueをrestoreしたあとsaveしてるのでstackの内容は全然変わりません。そうするとrestoreしたcontinueの値を使うのかと思いきや、そのあとcontinueにafterfib-n-2をassignしてます。だからここのrestoreとsaveは全然意味ないです。ここを削ってみてstackが減るのをn=3の場合で確認してみます。まず削らない場合。

> (execute-machine-with fibonacci-machine ((n 3)) val)
stack = (())
stack = (3 ())
stack = (afterfib-n-1 3 ())
stack = (2 afterfib-n-1 3 ())
stack = (afterfib-n-1 3 ())     ;
stack = (3 ())                  ;
stack = (afterfib-n-1 3 ())     ;
stack = (1 afterfib-n-1 3 ())
stack = (afterfib-n-1 3 ())
stack = (3 ())
stack = (())    ;
stack = ()      ;
stack = (())    ;
stack = (1 ())
stack = (())
stack = ()
val=2

削った場合。

> (execute-machine-with fibonacci-machine ((n 3)) val)
stack = (())
stack = (3 ())
stack = (afterfib-n-1 3 ())
stack = (2 afterfib-n-1 3 ())
stack = (afterfib-n-1 3 ())
stack = (1 afterfib-n-1 3 ())
stack = (afterfib-n-1 3 ())
stack = (3 ())
stack = (())
stack = (1 ())
stack = (())
stack = ()
val=2

で減ってますね。結果も変わりないです。上の削らなかった場合でセミコロンのついてる行が一つにまとめられるので無駄が減ってます。実際どれくらい減ってるんでしょう。timeで調べてみます。
削らない場合。

> (time (execute-machine-with fibonacci-machine ((n 23)) val))
val=28657
cpu time: 8285 real time: 8282 gc time: 96
> (time (execute-machine-with fibonacci-machine ((n 24)) val))
val=46368
cpu time: 14640 real time: 14644 gc time: 264
> (time (execute-machine-with fibonacci-machine ((n 25)) val))
val=75025
cpu time: 24770 real time: 24860 gc time: 348

削った場合。

> (time (execute-machine-with fibonacci-machine ((n 23)) val))
val=28657
cpu time: 7460 real time: 7462 gc time: 140
> (time (execute-machine-with fibonacci-machine ((n 24)) val))
val=46368
cpu time: 12597 real time: 12671 gc time: 224
> (time (execute-machine-with fibonacci-machine ((n 25)) val))
val=75025
cpu time: 21173 real time: 21171 gc time: 308

うーん、13%くらい削れたのかな。まあ早くなりました。

5.7

もうやりましたー。

5.8

labelを複数回定義するとどうなるか。です。

> (define test-machine
    (make-machine
     '(a)
     '()
     '(start
         (goto (label here))
       here
         (assign a (const 3))
         (goto (label there))
       here
         (assign a (const 4))
         (goto (label there))
       there)))
> (execute-machine-with test-machine () a)
a=3

今のシミュレータだと前の方にきてるラベルが優先されるようです。これはextract-labelsでlabelをlabelsに集めるときに先に出てきたラベルが先にくるようになってるからです。
複数回の定義を発見するには、計算量とか何も考えないならlabelsへの追加時に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 "can't define same labels -- EXTRACT-LABELS" next-inst)
                   (receive insts
                            (cons (make-label-entry next-inst insts) labels)))
               (receive (cons (make-instruction next-inst) insts)
                        labels)))))))

> (define test-machine
    (make-machine
     '(a)
     '()
     '(start
         (goto (label here))
       here
         (assign a (const 3))
         (goto (label there))
       here
         (assign a (const 4))
         (goto (label there))
       there)))
. can't define same labels -- EXTRACT-LABELS here

エラーしてくれます。


きりがいいのでここまで。