プログラミング再入門

プログラミングをもう一度ちゃんと勉強する読書ノート

SICP 5.5.2 Compiling Expressions

LISP Scheme

ノート

Compiling linkage code

compile-linkageは各式を命令に変換した後、次の命令への繋ぎを生成する。
引数が'returnの時はレジスタcontinueの内容にジャンプ、'nextであれば何もしない、その他であれば引数をラベルとみなしてそのラベルにジャンプする命令を生成する。

Compiling simple expressions

compile-self-evaluating、compile-quoted、compile-variableはほぼ自明。
compile-assignmentは、まず式の部分を評価してvalに保存するようにコンパイルする。compile-definitionも同様。

Compiling conditional expressions

compile-ifのポイントはif式の後がどこに繋がるかで命令が若干変わることと、ラベルをこの式固有のものを生成しなければならない事。

Compiling sequences

シーケンスのコンパイルは再帰的に各式をコンパイルして、再帰の帰り道で全てを接続する。

Compiling lambda expressions

ラムダ式の中身の命令はその場に挿入するが、式の途中などにラムダ式があるような場合には、この部分をジャンプして実行が進むようにしなければならない。

5.5.3 Compiling Combinations

オペレータ、オペランドの評価。引数リストをconsで構築する関係で、引数の評価は最右から行う。

Applying procedures

適用する手続きがプリミティブか否かを判断して適用するコードを生成する。

Applying compiled procedures

複合手続きの呼び出しは、呼び出した後の処理によって生成するコードが変わる。

5.5.4 Combining Instruction Sequences

append-instruction-sequencesは可変長引数を取る。これをappend-2-sequencesで順番に連結して行く。append-2-sequencesでは当然命令を連結するだけではなく、必要としているレジスタのリスト、変更されるレジスタのリストをそれぞれマージする。

ここでpreserving。引数のレジスタのリストに登録されているそれぞれのレジスタについて、二番目の命令列がそれを参照するなら一番目の命令列をsaveとrestoreで囲む。

tack-on-instruction-sequenceはラムダ式で生成した本体を命令列の間に挿入する。挿入にあたってはラムダ式の本体で何のレジスタを使うかとかは考慮する必要はない。

parallel-instruction-sequencesはifとか手続き適用部分で使用する。二つの命令列のどちらかしか通らないので互いのレジスタ使用は無視して連結できる。手続き適用の際にはプリミティブか否かで二つの命令列を用意するので。

5.5.5 An Example of Compiled Code

まずは、サンプルをコンパイルしてみる

> (compile
 '(define (factorial n)
    (if (= n 1)
        1
        (* (factorial (- n 1)) n)))
 'val
 'next)
'((env) ; あらかじめ初期化されている必要があるレジスタ。
  (val) ; ここで変更されるレジスタ。
  ((assign val (op make-compiled-procedure) (label entry1) (reg env)) ; 「手続きですよ」と言うタグが付いたリストを作る。
   (goto (label after-lambda2)) ; 変数factorialを登録するところまでジャンプ
   entry1 ; ここからがラムダ式の本体
   (assign env (op compiled-procedure-env) (reg proc)) ; make-compiled-procedureで作ったリストから環境を取り出す
   (assign env (op extend-environment) (const (n)) (reg argl) (reg env)) ; 環境に引数のnを追加する
   (save continue)
   (save env)
   (assign proc (op lookup-variable-value) (const =) (reg env)) ; (= n 1)式を作る
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc)) ; =を適用
   (branch (label primitive-branch6))
   compiled-branch7
   (assign continue (label after-call8))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch6
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call8 ; =の適用が終わったところ
   (restore env)
   (restore continue)
   (test (op false?) (reg val)) ; ifの条件判断
   (branch (label false-branch4))
   true-branch3 ; ifの条件がtrueの時
   (assign val (const 1))
   (goto (reg continue))
   false-branch4 ; ifの条件がfalseの時
   (assign proc (op lookup-variable-value) (const *) (reg env)) ; (* (factorial (- n 1)) n)式を構築
   (save continue) ; (factorial (- n 1))で必要なレジスタを退避
   (save proc) ; factorialの呼び出しでもprocを使うので一旦退避
   (assign val (op lookup-variable-value) (const n) (reg env)) ; 式の最後のnを引数リストに代入
   (assign argl (op list) (reg val)) ; 最右の引数なのでリストにして代入するだけ
   (save argl) ; factorialの呼び出しでもarglを使うので一旦退避
   (assign proc (op lookup-variable-value) (const factorial) (reg env))
   (save proc) ; (- n 1)の呼び出しでもprocを使うので一旦退避
   (assign proc (op lookup-variable-value) (const -) (reg env)) ; (- n 1)式を構築
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc)) ; -の適用
   (branch (label primitive-branch9))
   compiled-branch10
   (assign continue (label after-call11))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch9
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call11 ; -の適用が終わったところ
   (assign argl (op list) (reg val)) ; (- n 1)の結果をfactorial用の引数リストとして初期化
   (restore proc) ; factorialを戻して
   (test (op primitive-procedure?) (reg proc)) ; factorialを適用
   (branch (label primitive-branch12))
   compiled-branch13
   (assign continue (label after-call14))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch12
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call14 ; factorialの適用が終わったところ
   (restore argl) ; *用の引数リストを復元
   (assign argl (op cons) (reg val) (reg argl)) ; *用の引数リストに(factorial (- n 1))の結果を追加
   (restore proc) ; *を復元
   (restore continue) ; *の適用が終わったら戻るべき場所を復元
   (test (op primitive-procedure?) (reg proc)) ; *の適用
   (branch (label primitive-branch15))
   compiled-branch16
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch15
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   (goto (reg continue))
   after-call17 ; *の適用が終わったところだけど、ここには戻って来ない
   after-if5 ; if式を抜けたところ
   after-lambda2 ; 変数factorialに拘束する
   (perform (op define-variable!) (const factorial) (reg val) (reg env))
   (assign val (const ok))))
>
Exercise 5.33

まずはコンパイルしてみる。

> (compile
 '(define (factorial-alt n)
  (if (= n 1)
      1
      (* n (factorial-alt (- n 1)))))
 'val
 'next)
'((env)
  (val)
  ((assign val (op make-compiled-procedure) (label entry1) (reg env))
   (goto (label after-lambda2))
   entry1
   (assign env (op compiled-procedure-env) (reg proc))
   (assign env (op extend-environment) (const (n)) (reg argl) (reg env))
   (save continue)
   (save env)
   (assign proc (op lookup-variable-value) (const =) (reg env))
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch6))
   compiled-branch7
   (assign continue (label after-call8))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch6
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call8
   (restore env)
   (restore continue)
   (test (op false?) (reg val))
   (branch (label false-branch4))
   true-branch3
   (assign val (const 1))
   (goto (reg continue))
   false-branch4
   (assign proc (op lookup-variable-value) (const *) (reg env))
   (save continue)
   (save proc)
   (save env)
   (assign proc (op lookup-variable-value) (const factorial-alt) (reg env))
   (save proc)
   (assign proc (op lookup-variable-value) (const -) (reg env))
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch9))
   compiled-branch10
   (assign continue (label after-call11))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch9
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call11
   (assign argl (op list) (reg val))
   (restore proc)
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch12))
   compiled-branch13
   (assign continue (label after-call14))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch12
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call14
   (assign argl (op list) (reg val))
   (restore env)
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (restore proc)
   (restore continue)
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch15))
   compiled-branch16
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch15
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   (goto (reg continue))
   after-call17
   after-if5
   after-lambda2
   (perform (op define-variable!) (const factorial-alt) (reg val) (reg env))
   (assign val (const ok))))
>

異なる部分。元のコードでは

   false-branch4 ; ifの条件がfalseの時
   (assign proc (op lookup-variable-value) (const *) (reg env)) ; (* (factorial (- n 1)) n)式を構築
   (save continue) ; (factorial (- n 1))で必要なレジスタを退避
   (save proc) ; factorialの呼び出しでもprocを使うので一旦退避
   (assign val (op lookup-variable-value) (const n) (reg env)) ; 式の最後のnを引数リストに代入
   (assign argl (op list) (reg val)) ; 最右の引数なのでリストにして代入するだけ
   (save argl) ; factorialの呼び出しでもarglを使うので一旦退避
   (assign proc (op lookup-variable-value) (const factorial) (reg env))
   (save proc) ; (- n 1)の呼び出しでもprocを使うので一旦退避
   (assign proc (op lookup-variable-value) (const -) (reg env)) ; (- n 1)式を構築
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc)) ; -の適用
   (branch (label primitive-branch9))
   compiled-branch10
   (assign continue (label after-call11))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch9
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call11 ; -の適用が終わったところ
   (assign argl (op list) (reg val)) ; (- n 1)の結果をfactorial用の引数リストとして初期化
   (restore proc) ; factorialを戻して
   (test (op primitive-procedure?) (reg proc)) ; factorialを適用
   (branch (label primitive-branch12))
   compiled-branch13
   (assign continue (label after-call14))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch12
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call14 ; factorialの適用が終わったところ
   (restore argl) ; *用の引数リストを復元
   (assign argl (op cons) (reg val) (reg argl)) ; *用の引数リストに(factorial (- n 1))の結果を追加

新しいコードでは

   false-branch4
   (assign proc (op lookup-variable-value) (const *) (reg env))
   (save continue)
   (save proc)
   (save env) ; factorial-altを呼び出した後に変数nを参照しなければならないのでenvを退避する必要がある
   (assign proc (op lookup-variable-value) (const factorial-alt) (reg env))
   (save proc)
   (assign proc (op lookup-variable-value) (const -) (reg env))
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch9))
   compiled-branch10
   (assign continue (label after-call11))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch9
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call11
   (assign argl (op list) (reg val)) ; (- n 1)の結果でarglを初期化する
   (restore proc) ; factorial-altを復元
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch12))
   compiled-branch13
   (assign continue (label after-call14))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch12
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call14
   (assign argl (op list) (reg val)) ; ここで初めて*用のarglを初期化する
   (restore env) ; envを戻して変数nを参照してarglに追加する
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op cons) (reg val) (reg argl))

元の定義では掛け算の引数を評価する際にenvを退避する必要がない代わりに、最初にnをarglに入れてしまうのでfactorialを呼び出す前にarglを退避しなければならない。
新しい定義は逆に最初にfactorial-altを呼び出す関係で、envを対ししておく必要がある代わりにfactorial-altの呼び出しが終わってから掛け算のためのarglを用意するので、arglを退避する必要がない。
と言う訳で、効率的には基本的には同じ。

Exercise 5.34

コンパイルしてみる。

> (compile
 '(define (factorial n)
    (define (iter product counter)
      (if (> counter n)
          product
          (iter (* counter product)
                (+ counter 1))))
    (iter 1 1))
 'val
 'next)
'((env)
  (val)
  ((assign val (op make-compiled-procedure) (label entry18) (reg env)) ; 手続きfactorialをvalに代入してafter-lambda19までジャンプ
   (goto (label after-lambda19))
   entry18 ; factorialの本体
   (assign env (op compiled-procedure-env) (reg proc)) ; make-compiled-procedureで作ったリストから環境を取り出す
   (assign env (op extend-environment) (const (n)) (reg argl) (reg env)) ; 環境に引数のnを追加する
   (assign val (op make-compiled-procedure) (label entry20) (reg env)) ; 手続きiterをvalに代入してafter-lambda21までジャンプ
   (goto (label after-lambda21))
   entry20 ; iterの本体
   (assign env (op compiled-procedure-env) (reg proc)) ; make-compiled-procedureで作ったリストから環境を取り出す
   (assign env (op extend-environment) (const (product counter)) (reg argl) (reg env)) ; 環境に引数のproductとcounterを追加する
   (save continue)
   (save env)
   (assign proc (op lookup-variable-value) (const >) (reg env)) ; (> counter n)式を構築
   (assign val (op lookup-variable-value) (const n) (reg env))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const counter) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc)) ; >の適用
   (branch (label primitive-branch25))
   compiled-branch26
   (assign continue (label after-call27))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch25
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call27 ; >の適用が終わったところ
   (restore env)
   (restore continue)
   (test (op false?) (reg val)) ; ifの条件判断
   (branch (label false-branch23))
   true-branch22 ; ifの条件がtrueの時
   (assign val (op lookup-variable-value) (const product) (reg env))
   (goto (reg continue))
   false-branch23 ; ifの条件がfalseの時
   (assign proc (op lookup-variable-value) (const iter) (reg env)) ; (iter (* counter product) (+ counter 1))式の構築
   (save continue)
   (save proc)
   (save env)
   (assign proc (op lookup-variable-value) (const +) (reg env)) ; (+ counter 1)式の構築
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const counter) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc)) ; +の適用
   (branch (label primitive-branch31))
   compiled-branch32
   (assign continue (label after-call33))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch31
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call33 ; +の適用終わり
   (assign argl (op list) (reg val)) ; +の結果をiter用のarglに代入
   (restore env)
   (save argl)
   (assign proc (op lookup-variable-value) (const *) (reg env)) ; (* counter product)式の構築
   (assign val (op lookup-variable-value) (const product) (reg env))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const counter) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc)) ; *の適用
   (branch (label primitive-branch28))
   compiled-branch29
   (assign continue (label after-call30))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch28
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call30 ; *の適用終わり
   (restore argl)
   (assign argl (op cons) (reg val) (reg argl)) ; *の結果をiter用のarglに代入
   (restore proc) ; iterを復元
   (restore continue)
   (test (op primitive-procedure?) (reg proc)) ; iterの適用　※この時点で全てのレジスタが復元されている
   (branch (label primitive-branch34))
   compiled-branch35
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch34
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   (goto (reg continue))
   after-call36 ; iterの適用終わり。でもここには来ない
   after-if24 ; if式の終わり
   after-lambda21; iter定義の終わり
   (perform (op define-variable!) (const iter) (reg val) (reg env)) ; lamda式のエントリーを変数iterとして登録
   (assign val (const ok)) ; iterの定義終わり
   (assign proc (op lookup-variable-value) (const iter) (reg env)) ; (iter 1 1)式の構築
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (const 1))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc)) ; iterの適用
   (branch (label primitive-branch37))
   compiled-branch38
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch37
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   (goto (reg continue))
   after-call39 ; iterの適用終わり
   after-lambda19
   (perform (op define-variable!) (const factorial) (reg val) (reg env)) ; lambda式のエントリーを変数factorialに拘束する
   (assign val (const ok)))) ; factorialの定義終わり
>

再帰のfactorialではfactorialの適用が終わった段階で、argl、proc、continueを復元するのでfactorialを呼び出す数だけこれらのレジスタ用のスタック領域が必要となる。

Exercise 5.35

逆アセンブル問題

  (assign val (op make-compiled-procedure) (label entry16)
                                           (reg env))
  (goto (label after-lambda15))
…
after-lambda15
  (perform (op define-variable!) (const f) (reg val) (reg env))
  (assign val (const ok))

ここはラムダ式を変数fに拘束している。

entry16
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env
          (op extend-environment) (const (x)) (reg argl) (reg env))

ラムダ式の初期化部分。仮引数はxのみ。

  (assign proc (op lookup-variable-value) (const +) (reg env))
  (save continue)
  (save proc)
  (save env)

＋演算の式を構築し始めるけど、これらのレジスタを退避するということは引数にも式がある。

  (assign proc (op lookup-variable-value) (const g) (reg env))
  (save proc)

手続きgを適用する式を作り始めるけど、これも退避するのでgに対する引数に式がある。

  (assign proc (op lookup-variable-value) (const +) (reg env))
  (assign val (const 2))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const x) (reg env))
  (assign argl (op cons) (reg val) (reg argl))

引数リストは右側から構築するので(+ x 2)式を構築。

  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch19))
compiled-branch18
  (assign continue (label after-call17))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch19
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))

(+ x 2)を評価。

after-call17
  (assign argl (op list) (reg val))
  (restore proc)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch22))
compiled-branch21
  (assign continue (label after-call20))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch22
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))

(+ x 2)の結果を引数に復元したproc、即ち手続きgを適用する。

  (assign argl (op list) (reg val))
  (restore env)
  (assign val (op lookup-variable-value) (const x) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (restore proc)

(g (+ x 2))の結果を引数に、さらに引数にxを追加して復元したproc、即ち+を適用する。

  (restore continue)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch25))
compiled-branch24
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch25
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))

continueを復元しているので+の適用が最後の式。
まとめると

(define (f x)
    (+ x (g (+ x 2))))
Exercise 5.36

式のオペランドの処理は右から行われる、つまりright-to-left。「arglに追加するときにconsを使う都合上」とテキストにも書いてある。
この部分の処理はconstruct-arglistで行っている。最初にoperand-codesをreverseして、そのcarに対してcode-to-get-last-argを適用している部分。
left-to-rightにするには、

  1. construct-arglistでreverseをやめる
  2. arglに追加するときにconsではなくadjoin-argを使用する
(define (construct-arglist operand-codes)
  (if (null? operand-codes)
      (make-instruction-sequence '() '(argl)
                                 '((assign argl (const ()))))
      (let ((code-to-get-last-arg
             (append-instruction-sequences
              (car operand-codes)
              (make-instruction-sequence '(val) '(argl)
                                         '((assign argl (op list) (reg val)))))))
        (if (null? (cdr operand-codes))
            code-to-get-last-arg
            (preserving '(env)
                        code-to-get-last-arg
                        (code-to-get-rest-args
                         (cdr operand-codes)))))))
(define (code-to-get-rest-args operand-codes)
  (let ((code-for-next-arg
         (preserving '(argl)
          (car operand-codes)
          (make-instruction-sequence '(val argl) '(argl)
           '((assign argl
              (op adjoin-arg) (reg val) (reg argl))))))) ; Ex 5.36
    (if (null? (cdr operand-codes))
        code-for-next-arg
        (preserving '(env)
         code-for-next-arg
         (code-to-get-rest-args (cdr operand-codes))))))

動作確認

> (compile '(+ x (* y 2)) 'val 'next)
'((env)
  (env proc argl continue val)
  ((assign proc (op lookup-variable-value) (const +) (reg env))
   (save proc)
   (assign val (op lookup-variable-value) (const x) (reg env)) ; xからリストに追加する
   (assign argl (op list) (reg val))
   (save argl)
   (assign proc (op lookup-variable-value) (const *) (reg env)) ; (* y 2)を評価
   (assign val (op lookup-variable-value) (const y) (reg env))
   (assign argl (op list) (reg val))
   (assign val (const 2))
   (assign argl (op adjoin-arg) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch1))
   compiled-branch2
   (assign continue (label after-call3))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch1
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call3
   (restore argl)
   (assign argl (op adjoin-arg) (reg val) (reg argl)) ; adjoin-argで追加
   (restore proc)
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch4))
   compiled-branch5
   (assign continue (label after-call6))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch4
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call6))
>

元のコードでの出力は

> (compile '(+ x (* y 2)) 'val 'next)
'((env)
  (env proc argl continue val)
  ((assign proc (op lookup-variable-value) (const +) (reg env))
   (save proc)
   (save env) ; (* y 2)を評価した後xを参照するのでenvをセーブする必要がある
   (assign proc (op lookup-variable-value) (const *) (reg env)) ; (* y 2)を評価
   (assign val (const 2))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const y) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch1))
   compiled-branch2
   (assign continue (label after-call3))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch1
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call3
   (assign argl (op list) (reg val))
   (restore env)
   (assign val (op lookup-variable-value) (const x) (reg env))
   (assign argl (op cons) (reg val) (reg argl)) ; consで追加
   (restore proc)
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch4))
   compiled-branch5
   (assign continue (label after-call6))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   primitive-branch4
   (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call6))
>
  1. コンパイル時にreverseしなくなる分、コンパイル時間はほんの少しだけ早くなる
  2. consに比べてadjoin-argはappendを使うのでリストを操作する分、実行時のパフォーマンスは落ちる

code-to-get-last-argと言う変数の名前は変えた方が良いかもしれないけど。

Exercise 5.37

preservingのコードの以下の部分

        (if (and (needs-register? seq2 first-reg)
                 (modifies-register? seq1 first-reg))

「あるレジスタが二番目の命令列で必要としていて、かつ、最初の命令列で変更する場合にのみ」の条件分岐を取り除けば、preservingに渡されれるレジスタは全て保存される。

(define (preserving regs seq1 seq2)
  (if (null? regs)
      (append-instruction-sequences seq1 seq2)
      (let ((first-reg (car regs)))
            (preserving (cdr regs)
             (make-instruction-sequence
              (list-union (list first-reg)
                          (registers-needed seq1))
              (list-difference (registers-modified seq1)
                               (list first-reg))
              (append `((save ,first-reg))
                      (statements seq1)
                      `((restore ,first-reg))))
             seq2))))

実行してみる。
まずは元のコードの出力。

> (compile '(+ 1 2) 'var 'next)
'((env)
  (env proc val argl continue var)
  ((assign proc (op lookup-variable-value) (const +) (reg env))
   (assign val (const 2))
   (assign argl (op list) (reg val))
   (assign val (const 1))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch1))
   compiled-branch2
   (assign continue (label proc-return4))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   proc-return4
   (assign var (reg val))
   (goto (label after-call3))
   primitive-branch1
   (assign var (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call3))
>

定数だけなので実は全くsave/restoreは不要。
冗長なコードの出力。そもそも全てのsave/restoreは不要。

> (compile '(+ 1 2) 'var 'next)
'((env continue) ; continueは使うけどlinkageがnextなので破壊して良い
  (env proc val argl continue var)
  ((save continue) ; continue保存する必要なし
   (save env) ; 変数は使っていないのでenvを参照する事はないし、よって保存する必要もなし
   (save continue) ; なんの変更もせずcontinueを２回セーブする。そもそもprocを設定するのにcontinueを保存する必要なし
   (assign proc (op lookup-variable-value) (const +) (reg env))
   (restore continue)
   (restore env)
   (restore continue)
   (save continue) ; restoreしたばかりなのにまたセーブ
   (save proc) ; これ以降procは全く書き換えられないので保存する必要なし
   (save env)
   (save continue) ; valに定数2を代入するのにcontinueを保存する必要なし
   (assign val (const 2))
   (restore continue)
   (assign argl (op list) (reg val))
   (restore env)
   (save argl) ; valに定数1を代入するのにarglを保存する必要なし
   (save continue) ; valに定数1を代入するのにcontinueを保存する必要なし
   (assign val (const 1))
   (restore continue)
   (restore argl)
   (assign argl (op cons) (reg val) (reg argl))
   (restore proc)
   (restore continue)
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch1))
   compiled-branch2
   (assign continue (label proc-return4))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   proc-return4
   (assign var (reg val))
   (goto (label after-call3))
   primitive-branch1
   (save continue)
   (assign var (op apply-primitive-procedure) (reg proc) (reg argl))
   (restore continue)
   after-call3))
>
Exercise 5.38

現に(+ a 1)をコンパイルすると

> (compile '(+ a 1) 'var 'next)
'((env)
  (env proc val argl continue var)
  ((assign proc (op lookup-variable-value) (const +) (reg env))
   (assign val (const 1))
   (assign argl (op list) (reg val))
   (assign val (op lookup-variable-value) (const a) (reg env))
   (assign argl (op cons) (reg val) (reg argl))
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch1))
   compiled-branch2
   (assign continue (label proc-return4))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   proc-return4
   (assign var (reg val))
   (goto (label after-call3))
   primitive-branch1
   (assign var (op apply-primitive-procedure) (reg proc) (reg argl))
   after-call3))
>

コンパイラが特定の演算子についてはインラインにコードを展開する様にコンパイラを改造する。
arglに入っている引数に対してprocを適用するのではなく、新しい二つのレジスタarg1およびarg2を使い、プリミティブのオペレーションを使って演算するコードを生成する。

a.
オペランドのリストを受け取り、それぞれをarg1およびarg2をターゲットにしてコンパイルする。
元のcompile-applicationからconstruct-arglistに渡すコンパイルされたそれぞれの引数を評価するコードのリストを生成する部分

        (operand-codes
         (map (lambda (operand) (compile operand 'val 'next))
              (operands exp))))

に相当する。

オペランドの数は二つに限定するので、それぞれを引数として受け取る事にする。

(define (spread-arguments exp1 exp2)
  (list (compile exp1 'arg1 'next)
        (compile exp2 'arg2 'next)))

保存する必要がある可能性があるのはarg2だが、それは

  1. arg1の値を生成するコードがarg2を破壊する
  2. 演算を行うコードがarg2を必要としている

ので。とするとpreservingを呼び出すのは演算を行うコードを生成する時点。なのでここではない。

疑問点：

  1. なぜレジスタを保存する必要があるかもしれないとa.の方に書いてあるのか不明。
  2. 演算のコードを生成する時にループを回す訳でもないので、コンパイルした二つのコードをリストに纏めても有り難みが無い。

b.
compile-applicationに相当する手続き。引数は式、ターゲット、リンク。
compile-procedure-callの部分は不要で、ここが単にopで手続きを呼び出して結果をvalに代入するだけの命令列を生成する。compile-procedure-callのプリミティブを呼び出す部分を参考にする。

arg2の値を生成するコードと、arg2を保存したままarg1を生成するコードと演算を行うコードを連結したものを連結する。

(define (compile-open-code-primitive exp target linkage)
  (if (= (length exp) 3)
      (let* ((operator (car exp))
            (operand-codes (spread-arguments (cadr exp) (caddr exp)))
            (operand1 (car operand-codes))
            (operand2 (cadr operand-codes)))
        (end-with-linkage
         linkage
         (append-instruction-sequences
          operand2
          (preserving
           '(arg2)
           operand1
           (make-instruction-sequence
            '(arg1 arg2)
            (list target)
            `((assign ,target
                      (op ,operator)
                      (reg arg1)
                      (reg arg2))))))))
      (error "Arity mismatch -- COMPILE-OPEN-CODE-PRIMITIVE" exp))) ; raise compile time error

ここまでを単純な例で実行してみる。

>  (compile-open-code-primitive '(+ 1 2) 'val 'next)
'(() (arg2 arg1 val) ((assign arg2 (const 2)) (assign arg1 (const 1)) (assign val (op +) (reg arg1) (reg arg2))))
>

ディスパッチする部分

(define (compile exp target linkage)
  (cond ((self-evaluating? exp)
        …
        ((cond? exp) (compile (cond->if exp) target linkage))
        ((open-code-primitive? exp)
         (compile-open-code-primitive exp target linkage))
        ((application? exp)
         (compile-application exp target linkage))
        (else
         (error "Unknown expression type -- COMPILE" exp))))

(define (open-code-primitive? exp)
  (memq (car exp) '(= * - +)))

複合の式で試してみる。

> (compile '(+ (+ 1 2) 3) 'val 'next)
'(()
  (arg2 arg1 val)
  ((assign arg2 (const 3))
   (save arg2)
   (assign arg2 (const 2))
   (assign arg1 (const 1))
   (assign arg1 (op +) (reg arg1) (reg arg2))
   (restore arg2)
   (assign val (op +) (reg arg1) (reg arg2))))
>

c.

> (compile
 '(define (factorial n)
    (if (= n 1)
        1
        (* (factorial (- n 1)) n)))
 'val
 'next)
'((env)
  (val)
  ((assign val (op make-compiled-procedure) (label entry1) (reg env))
   (goto (label after-lambda2))
   entry1
   (assign env (op compiled-procedure-env) (reg proc))
   (assign env (op extend-environment) (const (n)) (reg argl) (reg env))
   (assign arg2 (const 1)) ; ここから
   (assign arg1 (op lookup-variable-value) (const n) (reg env))
   (assign val (op =) (reg arg1) (reg arg2)) ; ここが短くなった
   (test (op false?) (reg val))
   (branch (label false-branch4))
   true-branch3
   (assign val (const 1))
   (goto (reg continue))
   false-branch4
   (save continue)
   (assign arg2 (op lookup-variable-value) (const n) (reg env)) ; nをarg2に入れて退避
   (save arg2)
   (assign proc (op lookup-variable-value) (const factorial) (reg env))
   (assign arg2 (const 1)) ; ここから
   (assign arg1 (op lookup-variable-value) (const n) (reg env))
   (assign val (op -) (reg arg1) (reg arg2)) ; ここも短くなった
   (assign argl (op list) (reg val))
   (test (op primitive-procedure?) (reg proc))
   (branch (label primitive-branch6))
   compiled-branch7
   (assign continue (label proc-return9))
   (assign val (op compiled-procedure-entry) (reg proc))
   (goto (reg val))
   proc-return9
   (assign arg1 (reg val))
   (goto (label after-call8))
   primitive-branch6
   (assign arg1 (op apply-primitive-procedure) (reg proc) (reg argl)) ; レジスタvalを使わず
   after-call8
   (restore arg2) ; 退避していたnを復元
   (assign val (op *) (reg arg1) (reg arg2)) ; 演算部分が短くなった
   (restore continue)
   (goto (reg continue))
   after-if5
   after-lambda2
   (perform (op define-variable!) (const factorial) (reg val) (reg env))
   (assign val (const ok))))
>

d.
入力の式を変形する事を考える。

(define (make-nest exp)
  (let ((op (car exp)))
    (define (aug operands)
      (if (= (length operands) 2)
          (cons op operands)
          (list op (car operands) (aug (cdr operands)))))
    (aug (cdr exp))))

動作は

> (make-nest '(+ 1 2 3 4 5))
'(+ 1 (+ 2 (+ 3 (+ 4 5))))
>

面倒なのでopen-codeにするのは+と*だけにして

(define (open-code-primitive? exp)
  (memq (car exp) '(* +)))

compile-open-code-primitiveでは一旦式を変換してからコンパイルする

(define (compile-open-code-primitive exp target linkage)
  (let ((exp (make-nest exp)))
    (let* ((operator (car exp))
           (operand-codes (spread-arguments (cadr exp) (caddr exp)))
           (operand1 (car operand-codes))
           (operand2 (cadr operand-codes)))
      (end-with-linkage
       linkage
       (append-instruction-sequences
        operand2
        (preserving
         '(arg2)
         operand1
         (make-instruction-sequence
          '(arg1 arg2)
          (list target)
          `((assign ,target
                    (op ,operator)
                    (reg arg1)
                    (reg arg2))))))))))

動作確認

> (compile '(+ 1 2 3 4) 'val 'next)
'(()
  (arg2 arg1 val)
  ((assign arg2 (const 4))
   (assign arg1 (const 3))
   (assign arg2 (op +) (reg arg1) (reg arg2))
   (assign arg1 (const 2))
   (assign arg2 (op +) (reg arg1) (reg arg2))
   (assign arg1 (const 1))
   (assign val (op +) (reg arg1) (reg arg2))))
>