問題5.14-5.17

シミュレータを作ると、設計したレジスタ計算機の正当性の評価だけではなく、性能の評価もできるよ、ということですね。続き。

5.14

(define factorial-machine
  (make-machine
   (list (list '- -) (list '* *) (list '= =))
   '( (test (op initialize-stack))
      (assign continue (label fact-done))
     ...
     fact-done
      (test (op print-stack-statistics)))))

先頭と最後にinitialize-stackとprint-stack-statisticsを追加します。execute-machine-withで適当にやってみます。

> (execute-machine-with factorial-machine ((n 2)) val)
(total-pushes = 2 maximum-depth = 2)
val=2
> (execute-machine-with factorial-machine ((n 3)) val)
(total-pushes = 4 maximum-depth = 4)
val=6
> (execute-machine-with factorial-machine ((n 4)) val)
(total-pushes = 6 maximum-depth = 6)
val=24
> (execute-machine-with factorial-machine ((n 5)) val)
(total-pushes = 8 maximum-depth = 8)
val=120
> (execute-machine-with factorial-machine ((n 6)) val)
(total-pushes = 10 maximum-depth = 10)
val=720
> (execute-machine-with factorial-machine ((n 20)) val)
(total-pushes = 38 maximum-depth = 38)
val=2432902008176640000
> (execute-machine-with factorial-machine ((n 100)) val)
(total-pushes = 198 maximum-depth = 198)
val=93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000

ということで、どちらも2n-2ですね。

5.15

命令計数の追加。これはプログラムカウンタの変更時を捕捉すればいいと思うので、make-new-machineの中にinst-countなる変数を追加して、the-opsにinitalize-inst-count,print-inst-count手続きを追加して、execute手続きを少し変更してやればいいと思います。

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        ...
        (inst-count 0))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))
                 (list 'initialize-inst-count
                       (lambda () (set! inst-count 0)))
                 (list 'print-inst-count
                       (lambda () (display (list 'inst-count '= inst-count)) (newline)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      ...
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                (set! inst-count (+ inst-count 1))
                ((instruction-execution-proc (car insts)))
                (execute)))))
      ...
      dispatch)))

こんな感じで。前問題と同様factorial-machineで試してみます。最初と最後にinitialize-inst-count,print-inst-countを追加して実行します。

> (execute-machine-with factorial-machine ((n 5)) val)
(total-pushes = 8 maximum-depth = 8)
(inst-count = 51)
val=120
> (execute-machine-with factorial-machine ((n 10)) val)
(total-pushes = 18 maximum-depth = 18)
(inst-count = 106)
val=3628800
> (execute-machine-with factorial-machine ((n 20)) val)
(total-pushes = 38 maximum-depth = 38)
(inst-count = 216)
val=2432902008176640000

大丈夫そうです。

5.16

命令をトレースできるようにします。trace-switchを作っておき、execute手続きの中でいちいちこれを見るようにすればいいです。この時、executeのinstsは連想リスト形式でcarに命令のテキスト、cdrに実行命令が入っていました。instruction-textとinstruction-execution-procで抽象していたのでこれを使います。the-opsにはtrace-onとtrace-offを追加しておきます。

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        ...
        (trace-switch false))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 ...
                 (list 'trace-on
                       (lambda () (set! trace-switch true)))
                 (list 'trace-off
                       (lambda () (set! trace-switch false)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                (set! inst-count (+ inst-count 1))
                (if trace-switch
                    (begin (display (instruction-text (car insts))) (newline)))
                ((instruction-execution-proc (car insts)))
                (execute)))))
      ...
      dispatch)))

うーんどんどん縦長になってくな。実行します。例のごとくfactorial-machineの最初と最後にtrace-on,trace-offを追加して試します。

> (execute-machine-with factorial-machine ((n 3)) val)
(assign continue (label fact-done))
(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))
(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))
(test (op =) (reg n) (const 1))
(branch (label base-case))
(assign val (const 1))
(goto (reg continue))
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
(test (op trace-off))
(total-pushes = 4 maximum-depth = 4)
(inst-count = 31)
val=6

まあよさそうです。

5.17

5.16を拡張します。いろいろ方法がありますが、まず一番楽そうな現在のラベル情報を保持する変数current-labelを作る方向で考えてみます。ラベル変更時の補足がちょっとやっかいかもしれません。branchやgoto命令の時は簡単に捕捉できますが、単純に(つまり上から下の順番そのままで)次のラベルに行った場合の捕捉が面倒な気がします。ラベルと命令列の対応表を作って保持しておけばいいのですが、そうするとこれはプログラムの大きさの2乗に比例する比較回数が必要になるような気がします。計算スペース的にもあまりよろしくないような感じ。
なので、別のアプローチにします。instsの形式を若干変更する方向で考えてみます。
いままではinstsには命令しか入れていませんでしたが、ここにlabel情報を入れてみます。もともとの制御器のテキストには含まれているのですが、これは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 (cons next-inst insts)
                            (cons (make-label-entry next-inst (cons next-inst insts)) labels)))
               (receive (cons (make-instruction next-inst) insts)
                        labels)))))))

こんな風にして、instsにラベル情報を含むようにします。そうするとこのinstsはassembleを通してupdate-insts!に渡ります。update-insts!ではinstsの要素をmake-execution-procedureに渡していきます。このとき、instruction-textは実質的にはcarなので、symbolであるlabel情報に適用するとエラーになる。これを回避する必要があります。こんな感じ。

(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)
       (if (symbol? inst)
           'no-action
           (set-instruction-execution-proc!
            inst
            (make-execution-procedure
             (instruction-text inst) labels machine pc flag stack ops))))
     insts)))

次にmake-execution-procedureを考える必要があります。さっきのextract-labelsの変更で、labelsはlabel名と先頭がlabel名のシンボルになった命令列の対になっています。なのでbranch命令やgoto命令によってmake-execution-procedureにlabelのシンボルが渡る可能性があるので、cond節に追加の記述が要ります。

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

これでラベルだけ読み飛ばすようになりました。するとmake-new-machineの中のexecute手続き内でpcの先頭がラベルを指している場合があり、この時がラベル変更を捕捉する時になります。5.15で追加した命令計数のカウントはpcがラベルを指しているときには行わないように注意しつつ、またpcを更新するのを忘れないようにしつつ、execute手続きをこんな感じに書きます。

(define (execute)
  (let ((insts (get-contents pc)))
    (if (null? insts)
        'done
        (begin
          (if (symbol? (car insts))
              (begin
                (if trace-switch
                    (begin (display (car insts)) (newline)))
                (advance-pc pc)
                (execute))
              (begin
                (set! inst-count (+ inst-count 1))
                (if trace-switch
                    (begin (display (instruction-text (car insts)))
                           (newline)))
                ((instruction-execution-proc (car insts)))
                (execute)))))))

以上の変更をしたあと、5.16のfactorial-machineを使って実行してみます。

> (execute-machine-with factorial-machine ((n 3)) val)
(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))
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))
fact-loop
(test (op =) (reg n) (const 1))
(branch (label base-case))
base-case
(assign val (const 1))
(goto (reg continue))
after-fact
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
after-fact
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
fact-done
(test (op trace-off))
(total-pushes = 4 maximum-depth = 4)
(inst-count = 31)
val=6

ということで、label情報を表示することができるようになりました。

この辺は問題を解くごとにコードが汚くなっていくのがなんかいやですね。でもあと二問あるみたいなので次もどんどん汚いコードを書くと思います。とりあえずここまで。