SICP 問題 5.46

5.45と同様に今度はフィボナッチ数列の計算でそれぞれ比べる．

gosh> (define fib  ;;一回目以外は省略
        (make-machine
         (list (list '< <)
               (list '- -)
               (list '+ +))
         '(controller
           (assign continue (label fib-done))
           fib-loop
           (test (op <) (reg n) (const 2))
           (branch (label immediate-answer))
           ;; Fib(n-1)を計算するよう設定
           (save continue)
           (assign continue (label afterfib-n-1))
           (save n)                      ;n の昔の値を退避
           (assign n (op -) (reg n) (const 1))   ;n を n-1 に変える
           (goto (label fib-loop))               ;再帰呼び出しを実行
           afterfib-n-1                ;戻った時 Fib(n-1) は val にある
           (restore n)
           (restore continue)
           ;; Fib(n-2)を計算するよう設定
           (assign n (op -) (reg n) (const 2))
           (save continue)
           (assign continue (label afterfib-n-2))
           (save val)                    ;Fib(n-1) を退避
           (goto (label fib-loop))
           afterfib-n-2            ;戻った時 Fib(n-2) の値は val にある
           (assign n (reg val))    ;n には Fib(n-2) がある
           (restore val)           ;val には Fib(n-1) がある
           (restore continue)
           (assign val                   ;Fib(n-1) + Fib(n-2)
                   (op +) (reg val) (reg n))
           (goto (reg continue))   ;呼び出し側に戻る．答えは val にある
           immediate-answer
           (assign val (reg n))          ;基底の場合: Fib(n)=n
           (goto (reg continue))
           fib-done
           (perform (op print-stack-statistics)))))

fib
gosh> (set-register-contents! fib 'n 1)
done
gosh> (start fib)

(total-pushes = 0 maximum-depth = 0)done
gosh> (get-register-contents fib 'val)
1

gosh> (set-register-contents! fib 'n 2)
done
gosh> (start fib)

(total-pushes = 4 maximum-depth = 2)done
gosh> (get-register-contents fib 'val)
1
gosh> (set-register-contents! fib 'n 3)
done
gosh> (start fib)

(total-pushes = 8 maximum-depth = 4)done
gosh> (get-register-contents fib 'val)
2
gosh> (set-register-contents! fib 'n 4)
done
gosh> (start fib)

(total-pushes = 16 maximum-depth = 6)done
gosh> (get-register-contents fib 'val)
3
gosh> (set-register-contents! fib 'n 5)
done
gosh> (start fib)

(total-pushes = 28 maximum-depth = 8)done
gosh> (get-register-contents fib 'val)
5
gosh> (set-register-contents! fib 'n 5)
done
gosh> (start fib)

(total-pushes = 28 maximum-depth = 8)done
gosh> (get-register-contents fib 'val)
5
gosh> (set-register-contents! fib 'n 6)
done
gosh> (start fib)

(total-pushes = 48 maximum-depth = 10)done
gosh> (get-register-contents fib 'val)
8
gosh> (set-register-contents! fib 'n 7)
done
gosh> (start fib)

(total-pushes = 80 maximum-depth = 12)done
gosh> (get-register-contents fib 'val)
13
gosh> (set-register-contents! fib 'n 8)
done
gosh> (start fib)

(total-pushes = 132 maximum-depth = 14)done
gosh> (get-register-contents fib 'val)
21
gosh> (set-register-contents! fib 'n 9)
done
gosh> (start fib)

(total-pushes = 216 maximum-depth = 16)done
gosh> (get-register-contents fib 'val)
34
gosh> (set-register-contents! fib 'n 10)
done
gosh> (start fib)

(total-pushes = 352 maximum-depth = 18)done
gosh> (get-register-contents fib 'val)
55

　
翻訳系

gosh> (compile-and-go
       '(define (fib n)
          (if (< n 2)
              n
              (+ (fib (- n 1)) (fib (- n 2))))))

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(fib 1)

(total-pushes = 7 maximum-depth = 3)
;;; EC-Eval value:
1

;;; EC-Eval input:
(fib 2)

(total-pushes = 15 maximum-depth = 5)
;;; EC-Eval value:
1

;;; EC-Eval input:
(fib 3)

(total-pushes = 23 maximum-depth = 7)
;;; EC-Eval value:
2

;;; EC-Eval input:
(fib 4)

(total-pushes = 39 maximum-depth = 9)
;;; EC-Eval value:
3

;;; EC-Eval input:
(fib 5)

(total-pushes = 63 maximum-depth = 11)
;;; EC-Eval value:
5

;;; EC-Eval input:
(fib 6)

(total-pushes = 103 maximum-depth = 13)
;;; EC-Eval value:
8

;;; EC-Eval input:
(fib 7)

(total-pushes = 167 maximum-depth = 15)
;;; EC-Eval value:
13

;;; EC-Eval input:
(fib 8)

(total-pushes = 271 maximum-depth = 17)
;;; EC-Eval value:
21

;;; EC-Eval input:
(fib 9)

(total-pushes = 439 maximum-depth = 19)
;;; EC-Eval value:
34

;;; EC-Eval input:
(fib 10)

(total-pushes = 711 maximum-depth = 21)
;;; EC-Eval value:
55

　
積極制御評価器

;;; EC-Eval input:
(define (ec-fib n)
  (if (< n 2)
      n
      (+ (ec-fib (- n 1)) (ec-fib (- n 2)))))

(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(ec-fib 1)

(total-pushes = 16 maximum-depth = 8)
;;; EC-Eval value:
1

;;; EC-Eval input:
(ec-fib 2)

(total-pushes = 72 maximum-depth = 13)
;;; EC-Eval value:
1

;;; EC-Eval input:
(ec-fib 3)

(total-pushes = 128 maximum-depth = 18)
;;; EC-Eval value:
2

;;; EC-Eval input:
(ec-fib 4)

(total-pushes = 240 maximum-depth = 23)
;;; EC-Eval value:
3

;;; EC-Eval input:
(ec-fib 5)

(total-pushes = 408 maximum-depth = 28)
;;; EC-Eval value:
5

;;; EC-Eval input:
(ec-fib 6)

(total-pushes = 688 maximum-depth = 33)
;;; EC-Eval value:
8

;;; EC-Eval input:
(ec-fib 7)

(total-pushes = 1136 maximum-depth = 38)
;;; EC-Eval value:
13

;;; EC-Eval input:
(ec-fib 8)

(total-pushes = 1864 maximum-depth = 43)
;;; EC-Eval value:
21

;;; EC-Eval input:
(ec-fib 9)

(total-pushes = 3040 maximum-depth = 48)
;;; EC-Eval value:
34

;;; EC-Eval input:
(ec-fib 10)

(total-pushes = 4944 maximum-depth = 53)
;;; EC-Eval value:
55

プッシュ数

n	計算機	翻訳系	評価器	評/機	翻/機
3	8	23	128	16.0	2.87
4	16	39	240	15.0	2.43
5	28	63	408	14.57	2.25
6	48	103	688	14.33	2.14
7	80	167	1136	14.2	2.08
8	132	271	1864	14.12	2.05
9	216	439	3040	14.07	2.03
10	352	711	4944	14.04	2.01|
20	43780	87567	612936	14.0	2.0

　
最大スタック深さ

計算機	翻訳系	評価器	評/機	翻/機
2n-2	2n+1	5n+3	2.500	1.00

SICP 問題 5.45

コンパイルした階乗計算，積極制御評価器の階乗計算，特殊目的計算機のプッシュ数，最大スタック深さを調べて比較する．

まずはコンパイルしたものから

gosh> (compile-and-go
       '(define (factorial n)
          (if (= n 1)
              1
              (* (factorial (- n 1)) n))))

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok


;;; EC-Eval input:
(factorial 1)

(total-pushes = 5 maximum-depth = 3)
;;; EC-Eval value:
1

;;; EC-Eval input:
(factorial 2)

(total-pushes = 7 maximum-depth = 3)
;;; EC-Eval value:
2

;;; EC-Eval input:
(factorial 3)

(total-pushes = 9 maximum-depth = 4)
;;; EC-Eval value:
6

;;; EC-Eval input:
(factorial 4)

(total-pushes = 11 maximum-depth = 6)
;;; EC-Eval value:
24

;;; EC-Eval input:
(factorial 5)

(total-pushes = 13 maximum-depth = 8)
;;; EC-Eval value:
120

;;; EC-Eval input:
(factorial 6)

(total-pushes = 15 maximum-depth = 10)
;;; EC-Eval value:
720

;;; EC-Eval input:
(factorial 7)

(total-pushes = 17 maximum-depth = 12)
;;; EC-Eval value:
5040

;;; EC-Eval input:
(factorial 8)

(total-pushes = 19 maximum-depth = 14)
;;; EC-Eval value:
40320

;;; EC-Eval input:
(factorial 9)

(total-pushes = 21 maximum-depth = 16)
;;; EC-Eval value:
362880

;;; EC-Eval input:
(factorial 10)

(total-pushes = 23 maximum-depth = 18)
;;; EC-Eval value:
3628800

プッシュ数は2n+3
最大スタック深さは2n-2
　
次に積極制御評価器で計測する．

;;; EC-Eval input:
(define (ec-factorial n)
  (if (= n 1)
      1
      (* (ec-factorial (- n 1)) n)))

(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(ec-factorial 1)

(total-pushes = 16 maximum-depth = 8)
;;; EC-Eval value:
1

;;; EC-Eval input:
(ec-factorial 2)

(total-pushes = 48 maximum-depth = 13)
;;; EC-Eval value:
2

;;; EC-Eval input:
(ec-factorial 3)

(total-pushes = 80 maximum-depth = 18)
;;; EC-Eval value:
6

;;; EC-Eval input:
(ec-factorial 4)

(total-pushes = 112 maximum-depth = 23)
;;; EC-Eval value:
24

;;; EC-Eval input:
(ec-factorial 5)

(total-pushes = 144 maximum-depth = 28)
;;; EC-Eval value:
120

;;; EC-Eval input:
(ec-factorial 6)

(total-pushes = 176 maximum-depth = 33)
;;; EC-Eval value:
720

;;; EC-Eval input:
(ec-factorial 7)

(total-pushes = 208 maximum-depth = 38)
;;; EC-Eval value:
5040

;;; EC-Eval input:
(ec-factorial 8)

(total-pushes = 240 maximum-depth = 43)
;;; EC-Eval value:
40320

;;; EC-Eval input:
(ec-factorial 9)

(total-pushes = 272 maximum-depth = 48)
;;; EC-Eval value:
362880

;;; EC-Eval input:
(ec-factorial 10)

(total-pushes = 304 maximum-depth = 53)
;;; EC-Eval value:
3628800

プッシュ数は32n-16
最大スタック深さは5n+3
　
最後に階乗計算のための特殊計算機で計測する．

gosh> (define fact  ;; 二回目以降の初期化は省略
        (make-machine
         (list (list '* *)
               (list '= =)
               (list '- -))
         '(controller
           (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))
           after-fact
           (restore n)
           (restore continue)
           (assign val (op *) (reg n) (reg val))
           (goto (reg continue))
           base-case
           (assign val (const 1))
           (goto (reg continue))
           fact-done
           (perform (op print-stack-statistics)))))
fact
gosh> (set-register-contents! fact 'n 1)
done
gosh> (start fact)

(total-pushes = 0 maximum-depth = 0)done
gosh> (get-register-contents fact 'val)
1
gosh> (set-register-contents! fact 'n 2)
done
gosh> (start fact)

(total-pushes = 2 maximum-depth = 2)done
gosh> (get-register-contents fact 'val)
2
gosh> (set-register-contents! fact 'n 3)
done
gosh> (start fact)

(total-pushes = 4 maximum-depth = 4)done
gosh> (get-register-contents fact 'val)
6
gosh> (set-register-contents! fact 'n 4)
done
gosh> (start fact)

(total-pushes = 6 maximum-depth = 6)done
gosh> (get-register-contents fact 'val)
24
gosh> (set-register-contents! fact 'n 5)
done
gosh> (start fact)

(total-pushes = 8 maximum-depth = 8)done
gosh> (get-register-contents fact 'val)
120
gosh> (set-register-contents! fact 'n 6)
done
gosh> (start fact)

(total-pushes = 10 maximum-depth = 10)done
gosh> (get-register-contents fact 'val)
720
gosh> (set-register-contents! fact 'n 7)
done
gosh> (start fact)

(total-pushes = 12 maximum-depth = 12)done
gosh> (get-register-contents fact 'val)
5040
gosh> (set-register-contents! fact 'n 8)
done
gosh> (start fact)

(total-pushes = 14 maximum-depth = 14)done
gosh> (get-register-contents fact 'val)
40320
gosh> (set-register-contents! fact 'n 9)
done
gosh> (start fact)

(total-pushes = 16 maximum-depth = 16)done
gosh> (get-register-contents fact 'val)
362880
gosh> (set-register-contents! fact 'n 10)
done
gosh> (start fact)

(total-pushes = 18 maximum-depth = 18)done
gosh> (get-register-contents fact 'val)
3628800

プッシュ数が2n-2 最大スタック深さが2n-2．

比べると，積極制御評価器は
total: 32n-16
max: 5n+3
　
翻訳系は
total: 2n+3
max: 2n-2
　
階乗計算機は
total: 2n-2
max: 2n-2
　
本来はここで翻訳系と階乗計算機のほうがはるかに優れていることを確認するはずが
ここまでの問題で最適化したため，ほとんど性能差がなくなっている．
比率を出すと積極制御評価器とは
totalが1:16
maxは2:5の性能差になる．

ここで本当に翻訳系が2nで収まっているのか確認のためにコンパイルした命令列を出力させる．
saveしているところを確認する．

gosh> (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 arg1 (op lexical-address-lookup) (const (0 0)) (reg env))
        (assign arg2 (const 1))
        (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)  ;; false-branchのcontinue
        (save env)          ;; false-branchのenv
        (assign proc (op get-global-environment))
        (assign proc (op lookup-variable-value) (const factorial) (reg proc))
        (assign arg1 (op lexical-address-lookup) (const (0 0)) (reg env))
        (assign arg2 (const 1))
        (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))
        after-call8
        (restore env)
        (assign arg2 (op lexical-address-lookup) (const (0 0)) (reg env))
        (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))))

false-branchでcontinueとenvをsaveしているだけなので最大スタック深さが2n-2なのは確かなようだ．
プッシュ数が2n+3なのは(factorial 1)でも5回プッシュされてるところを見ると，
引数を適用する段階でされているのでこれ以上は無理だろう．
factorialは基本計算しか使っていないので，open-code最適化がかなり効いてるためのこれだけ性能がよくなってると思われる．

SICP 問題 5.44

基本手続きの名前を含む式の正しいコードを翻訳するため，翻訳時環境を調べるようにする．

  (cond ((self-evaluating? exp)
         (compile-self-evaluating exp target linkage))
        ((variable? exp)
         (compile-variable exp target linkage ct-env))
        ((quoted? exp) (compile-quoted exp target linkage))
        ((assignment? exp)
         (compile-assignment exp target linkage ct-env))
        ((definition? exp)
         (compile-definition exp target linkage ct-env))
        ((if? exp) (compile-if exp target linkage ct-env))
        ((lambda? exp)
         (compile-lambda exp target linkage ct-env))
        ((let? exp)
         (compile (let->combination exp) target linkage ct-env))
        ((begin? exp)
         (compile-sequence (begin-actions exp)
                           target linkage ct-env))
        ((cond? exp) (compile (cond->if exp) target linkage ct-env))
        ((open-code? exp ct-env)           ;ct-envも渡して翻訳時環境に上書きされていないか調べる
         (compile-open-code exp target linkage ct-env))
        ((application? exp)
         (compile-application exp target linkage ct-env))
        (else
         (error "Unknown expression type -- COMPILE" exp))))

(define (not-overwrite? op ct-env)
  (let ((address (find-variable op ct-env )))
    (eq? address 'not-found)))

(define (open-code? exp ct-env)
  (and (memq (car exp) '(= * - +))
       (not-overwrite? (car exp) ct-env)))

test

((env)
 (val)
 ((assign val (op make-compiled-procedure) (label entry14) (reg env))
  (goto (label after-lambda15))
  entry14
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (+ * a b x y)) (reg argl) (reg env))
  (assign proc (op lexical-address-lookup) (const (0 0)) (const ((+ * a b x y)))) ;;ここで+を探すのにct-envの中身から探しているので成功.open-codeになっていない．
  (save continue)
  (save proc)
  (assign proc (op lexical-address-lookup) (const (0 1)) (const ((+ * a b x y))))
  (assign val (op lexical-address-lookup) (const (0 5)) (const ((+ * a b x y))))
  (assign argl (op list) (reg val))
  (assign val (op lexical-address-lookup) (const (0 3)) (const ((+ * a b x y))))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch19))
  compiled-branch20
  (assign continue (label after-call21))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch19
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  after-call21
  (assign argl (op list) (reg val))
  (save argl)
  (assign proc (op lexical-address-lookup) (const (0 1)) (const ((+ * a b x y))))
  (assign val (op lexical-address-lookup) (const (0 4)) (const ((+ * a b x y))))
  (assign argl (op list) (reg val))
  (assign val (op lexical-address-lookup) (const (0 2)) (const ((+ * a b x y))))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch16))
  compiled-branch17
  (assign continue (label after-call18))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch16
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  after-call18
  (restore argl)
  (assign argl (op cons) (reg val) (reg argl))
  (restore proc)
  (restore continue)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch22))
  compiled-branch23
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch22
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
  after-call24
  after-lambda15
  ))

SICP 問題 5.43

内部定義を吐き出してコンパイルする．
まず4.16で作ったscan-out-definesがこれ．

(define (scan-out-defines body)
  (define (split-defines proc-body defines non-defines)
    (cond ((null? proc-body)
           (cons (reverse defines) (reverse non-defines)))
          ((definition? (car proc-body))
           (split-defines (cdr proc-body)
                          (cons (car proc-body) defines) non-defines))
          (else (split-defines (cdr proc-body) defines (cons (car proc-body) non-defines)))))
  (let ((splits (split-defines body '() '())))
    (let ((defines (car splits))
          (non-defines (cdr splits)))
      (if (null? defines)
          non-defines
         (list (make-let (map (lambda (x) (list (definition-variable x) ''*unassigned*))
                              defines)
                         (append (map (lambda (x) (list 'set! (definition-variable x)
                                                        (definition-value x)))
                                      defines)
                                 non-defines)))))))

　
これをcompile-lambda-bodyで使う

(define (compile-lambda-body exp proc-entry ct-env)
  (let ((formals (lambda-parameters exp)))
    (append-instruction-sequences
     (make-instruction-sequence
      '(env proc argl) '(env)

      `(,proc-entry
        (assign env (op compiled-procedure-env) (reg proc))
        (assign env
                (op extend-environment)
                (const ,formals)
                (reg argl)
                (reg env))))
     ;; ここでscan-out-definesでlambda-bodyを変換してからcompile-sequenceに渡す
     (compile-sequence (scan-out-defines (lambda-body exp)) 'val 'return (cons formals ct-env)))))

　　
これはletに変換するのでcompileにletを追加する．

(define (compile exp target linkage ct-env)
  (cond ((self-evaluating? exp)
         (compile-self-evaluating exp target linkage))
        ((quoted? exp) (compile-quoted exp target linkage))
        ((variable? exp)
         (compile-variable exp target linkage ct-env))
        ((assignment? exp)
         (compile-assignment exp target linkage ct-env))
        ((definition? exp)
         (compile-definition exp target linkage ct-env))
        ((if? exp) (compile-if exp target linkage ct-env))
        ((lambda? exp)
         (compile-lambda exp target linkage ct-env))
        ((let? exp)                           ; letの追加
         (compile (let->combination exp) target linkage ct-env))
        ((begin? exp)
         (compile-sequence (begin-actions exp)
                           target linkage ct-env))
        ((cond? exp) (compile (cond->if exp) target linkage ct-env))
        ((open-code? exp)               ;open-code?でdispatch
         (compile-open-code exp target linkage ct-env))
        ((application? exp)
         (compile-application exp target linkage ct-env))
        (else
         (error "Unknown expression type -- COMPILE" exp))))

test まずはscan-out-definesから．

gosh> (scan-out-defines (lambda-body '(lambda (a b)
                                        (define x 1)
                                        (define (y c) (+ x c))
                                        (+ a b y))))
((let
     ((x '*unassigned*)
      (y '*unassigned*))
   (set! x 1)
   (set! y (lambda (c) (+ x c)))
   (+ a b y)))

　
期待通りに動いている．
次にcompile．
コンパイル後の命令列を追ったのでコメントをつけた．

gosh> (compile '((lambda (a b)
                   (define x 1)
                   (define (y c) (+ x c))
                   (+ a b (y 2))) 5 6) 'val 'next '())
      ((env)
       (env proc argl continue val)
       ;; procにentry56の手続き
       ((assign proc (op make-compiled-procedure) (label entry56) (reg env))
        (goto (label after-lambda57))
        entry56
        (assign env (op compiled-procedure-env) (reg proc))
        ;; (a b)を(5 6)に対応して拡張
        (assign env (op extend-environment) (const (a b)) (reg argl) (reg env))
        ;; proc: entry58
        (assign proc (op make-compiled-procedure) (label entry58) (reg env))
        (goto (label after-lambda59))
        entry58
        (assign env (op compiled-procedure-env) (reg proc))
        ;; (x y)に(*unassigned* *unassigned*)を対応付け
        (assign env (op extend-environment) (const (x y)) (reg argl) (reg env))
        (assign val (const 1))
        ;; x のオブジェクトを1にする
        (perform (op lexical-address-set!) (const (0 0)) (reg val) (const ((x y) (a b))))
        (assign val (const ok))
        ;; val: entry60
        (assign val (op make-compiled-procedure) (label entry60) (reg env))
        (goto (label after-lambda61))
        entry60
        (assign env (op compiled-procedure-env) (reg proc))
        ;; ((c) (6))
        (assign env (op extend-environment) (const (c)) (reg argl) (reg env))
        ;; arg1: 1
        (assign arg1 (op lexical-address-lookup) (const (1 0)) (const ((c) (x y) (a b))))
        ;; arg2: 2
        (assign arg2 (op lexical-address-lookup) (const (0 0)) (const ((c) (x y) (a b))))
        ;; val: (+ 1 2) = 3
        (assign val (op +) (reg arg1) (reg arg2))
        (goto (reg continue))
        after-lambda61
        ;; y <= entry60
        (perform (op lexical-address-set!) (const (0 1)) (reg val) (const ((x y) (a b))))
        (assign val (const ok))
        (save continue)                 ;aftercall71
        (assign arg1 (op lexical-address-lookup) (const (1 0)) (const ((x y) (a b))))
        (assign arg2 (op lexical-address-lookup) (const (1 1)) (const ((x y) (a b))))
        (assign arg1 (op +) (reg arg1) (reg arg2)) ;(+ a b) =>(+ 5 6) => 11
        (assign proc (op lexical-address-lookup) (const (0 1)) (const ((x y) (a b))))
        (assign val (const 2))
        (assign argl (op list) (reg val)) ;argl: (2)
        (test (op primitive-procedure?) (reg proc))
        (branch (label primitive-branch62))
        compiled-branch63
        (assign continue (label proc-return65)) ;continue: proc-return65
        (assign val (op compiled-procedure-entry) (reg proc))
        (goto (reg val))
        proc-return65
        ;; arg2: 7
        (assign arg2 (reg val))
        (goto (label after-call64))
        primitive-branch62
        (assign arg2 (op apply-primitive-procedure) (reg proc) (reg argl))
        after-call64
        ;; val: (+ 11 3) = 14
        (assin val (op +) (reg arg1) (reg arg2))
        (restore continue)              ;aftercall71
        (goto (reg continue))
        after-lambda59
        (assign val (const *unassigned*))
        (assign argl (op list) (reg val))
        (assign val (const *unassigned*))
        (assign argl (op cons) (reg val) (reg argl)) ;argl: (*unassigned* *unassigned*)
        (test (op primitive-procedure?) (reg proc))
        (branch (label primitive-branch66))
        compiled-branch67
        (assign val (op compiled-procedure-entry) (reg proc)) ;val: entry58
        (goto (reg val))
        primitive-branch66
        (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
        (goto (reg continue))
        after-call68
        after-lambda57
        (assign val (const 6))          ;val: 6
        (assign argl (op list) (reg val)) ;argl: (6)
        (assign val (const 5))          ;val: 5
        (assign argl (op cons) (reg val) (reg argl)) ;argl: (5 6)
        (test (op primitive-procedure?) (reg proc)) ;no
        (branch (label primitive-branch69))
        compiled-branch70
        (assign continue (label after-call71)) ;continue: aftercall71
        (assign val (op compiled-procedure-entry) (reg proc)) ;val: entry56
        (goto (reg val))
        primitive-branch69
        (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
        after-call71                    ;val 14
        ))

期待通りに内部定義を吐き出してlambdaでunassignedとして受け取り，
bodyで実際の値（手続き）にset!している．

SICP 問題 5.42

compile-variableとcompile-assignmentを文面アドレスを使った検索に対応

(define (compile-variable exp target linkage ct-env)
  (let ((address (find-variable exp ct-env)))
    (end-with-linkage
     linkage
     (if (eq? address 'not-found)
         (make-instruction-sequence
          '(env) (list target)
          ;; targetなら変更しても問題ないので一時的に帯域環境を入れる
          `((assign ,target (op get-global-environment))
            (assign ,target
                    (op lookup-variable-value)
                    (const ,exp)
                    (reg ,target))))
         (make-instruction-sequence
          '() (list target)
          `((assign ,target
                    (op lexical-address-lookup)
                    (const ,address)
                    (reg env))))))))

(define (compile-assignment exp target linkage ct-env)
  (let ((var (assignment-variable exp))
        (get-value-code                 ;valを求めるための命令．
         (compile (assignment-value exp) 'val 'next ct-env)))
    (let ((address (find-variable var ct-env)))
     (end-with-linkage
      linkage
      (append-instruction-sequences
                  get-value-code ;代入する値を求め，valに代入される．seq1
                  ;; valに代入された値をvarに代入する．seq2
                  (if (eq? address 'not-found)
                      (make-instruction-sequence
                       '(env val)
                       (list target)
                       ;; 一度targetにglobal-environmentを代入してからsetする
                       `((assign target (op get-global-environment))
                         (perform (op set-variable-value!)
                                  (const ,var)
                                  (reg val)
                                  (reg ,target))
                         (assign ,target (const ok))))
                      (make-instruction-sequence
                       '(env val)
                       (list target)
                       `((perform (op lexical-address-set!)
                                  (const ,address)
                                  (reg val)
                                  (reg env))
                         (assign ,target (const ok))))))))))

test
このschemeの式自体はバグってる．
ただし，test自体は出来るのでそのまま

gosh> (compile
       '(lambda (x y)
          (lambda (a b)
            (+
             (+ x a)
             (* y b)
             (set! x a) ;; +の中でset!してるので 'okが返ってバグる
             (set! z b))))
       'val
       'next
       '())
((env)
 (val)
 ((assign val (op make-compiled-procedure) (label entry24) (reg env))
  (goto (label after-lambda25))
  entry24
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (x y)) (reg argl) (reg env))
  (assign val (op make-compiled-procedure) (label entry26) (reg env))
  (goto (reg continue))
  entry26
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (a b)) (reg argl) (reg env))
  (assign arg1 (op lexical-address-lookup) (const (1 0)) (const ((a b) (x y))))
  (assign arg2 (op lexical-address-lookup) (const (0 0)) (const ((a b) (x y))))
  (assign arg1 (op +) (reg arg1) (reg arg2))
  (save arg1)
  (assign arg1 (op lexical-address-lookup) (const (1 1)) (const ((a b) (x y))))
  (assign arg2 (op lexical-address-lookup) (const (0 1)) (const ((a b) (x y))))
  (assign arg2 (op *) (reg arg1) (reg arg2))
  (restore arg1)
  (assign arg1 (op +) (reg arg1) (reg arg2))
  (assign val (op lexical-address-lookup) (const (0 0)) (const ((a b) (x y))))
  (perform (op lexical-address-set!) (const (1 0)) (reg val) (const ((a b) (x y))))
  (assign arg2 (const ok)) ;; arg2 = ok
  (assign arg1 (op +) (reg arg1) (reg arg2)) ;; (+ arg1 ok)なのでバグる
  (assign val (op lexical-address-lookup) (const (0 1)) (const ((a b) (x y))))
  (assign env (op get-global-environment))
  (perform (op set-variable-value!) (const z) (reg val) (reg env))
  (assign arg2 (const ok))
  (assin val (op +) (reg arg1) (reg arg2))
  (goto (reg continue))
  after-lambda27
  after-lambda25))

SICP 問題 5.41

翻訳時環境に対する変数の文面アドレスを返す手続きfind-variableの実装

(define (find-variable var ct-env)
  (define (env-loop frame-address env)
    (define (scan variable-address frame)
      (cond ((null? frame)
             (env-loop (+ frame-address 1) (enclosing-environment env)))
            ((eq? (car frame) var)
             (list frame-address variable-address))
            (else
             (scan (+ variable-address 1) (cdr frame)))))
    (if (null? env)
        'not-found
        (let ((frame (first-frame env)))
          (scan 0 frame))))
  (env-loop 0 ct-env))

test

gosh> (find-variable 'c '((y z) (a b c d e) (x y)))
(1 2)
gosh> (find-variable 'x '((y z) (a b c d e) (x y)))
(2 0)
gosh> (find-variable 'w '((y z) (a b c d e) (x y)))
not-found

SICP 問題 5.40

翻訳時環境を維持し，compile-lambda-bodyで拡張するように変更する．

(define (compile-lambda-body exp proc-entry ct-env) ;; ct-envを追加
  (let ((formals (lambda-parameters exp)))
    (append-instruction-sequences
     (make-instruction-sequence
      '(env proc argl) '(env)

      `(,proc-entry
        (assign env (op compiled-procedure-env) (reg proc))
        (assign env
                (op extend-environment)
                (const ,formals)
                (reg argl)
                (reg env))))
       (compile-sequence (lambda-body exp) 'val 'return (cons formals ct-env))))) ;; ct-envを拡張

後はcompileするときに引数にct-envを取るように書く手続きを変更する．