SICP 4.2.2 An Interpreter with Lazy Evaluation - プログラミング再入門

ノート

プリミティブは正格のまま複合手続きを非正格として評価器を変更する。
評価を遅らせる手続きの引数はサンク（thunk：脚注にその由来。「考えた」）を作る。サンクを評価する事をフォースすると言う。
名前渡し（call-by-name）は引数をそのまま手続き内に埋め込む形。同じ式を何度も評価する。必要渡し（call-by-need）は最初に値が必要になった時に評価し、結果を保存して以降は既に評価された結果を参照する。

Modifying the evaluator

applyはベースLispが持っているものと重なるのでapply-procと名前を変えていた。
operator部分のみは評価して呼び出すべき手続きを決める。
operandは評価せずにそのままapply-procに渡す。

With these changes made, we can start the evaluator and test it.

いやいや、まだforce-itとdelay-itの定義が無いから。ベースLispのレベルで実現している訳ではないので生のforce/delayは使えない。

Representing thunks

サンクの表現。
現在のRacketではset-car!、set-cdr!が使えないのでサンクに限りmpairを使って以下の様に実装する。

#lang racket
(require racket/dict)
(require scheme/mpair)
;…中略

(define (delay-it exp env)
  (mcons 'thunk
         (mcons exp 
                (mcons env '()))))

(define (thunk? obj)
  (tagged-list? obj 'thunk))
(define (thunk-exp thunk) (mcar (mcdr thunk)))
(define (thunk-env thunk) (mcar (mcdr (mcdr thunk))))

(define (evaluated-thunk? obj)
  (tagged-list? obj 'evaluated-thunk))
(define (thunk-value evaluated-thunk) (mcar (mcdr evaluated-thunk)))

(define (force-it obj)
  (cond ((thunk? obj)
         (let ((result (actual-value
                        (thunk-exp obj)
                        (thunk-env obj))))
           (set-mcar! obj 'evaluated-thunk)
           (set-mcar! (mcdr obj) result)  ; replace exp with its value
           (set-mcdr! (mcdr obj) '())     ; forget unneeded env
           result))
        ((evaluated-thunk? obj)
         (thunk-value obj))
        (else obj)))
;
(define (tagged-list? exp tag)
  (cond ((pair? exp) (eq? (car exp) tag))
        ((mpair? exp) (eq? (mcar exp) tag))
        (else false)))

これで漸く実行出来る。

> (driver-loop)
;;; L-Eval input:
(define (try a b)
  (if (= a 0) 1 b))
;;; L-Eval value:
ok
;;; L-Eval input:
(try 0 (/ 1 0))
;;; L-Eval value:
1
;;; L-Eval input:
(define (f x)
    ((lambda (even? odd?)
       (even? even? odd? x))
     (lambda (ev? od? n)
       (if (= n 0) true (od? ev? od? (- n 1))))
     (lambda (ev? od? n)
       (if (= n 0) false (ev? ev? od? (- n 1))))))
;;; L-Eval value:
ok
;;; L-Eval input:
(f 5)
;;; L-Eval value:
#f
;;; L-Eval input:
(f 6)
;;; L-Eval value:
#t
;;; L-Eval input:
.

普通の式の評価にも影響を与えていなさそう。

Exercise 4.27

idは呼ばれた回数をwに記録して引数をそのまま返す手続き。

評価を遅らせられるのは関数の引数なので、wを定義する時に外側のidはoperatorとして評価され、その引数としての(id 10)は評価されない。なのでwを定義した時点でidが呼ばれるのは１回。
wを評価するとサンクとして残っていた(id 10)が評価されるので、値として10が返り、countがもう１回足される。

動作させた結果。

> (driver-loop)
;;; L-Eval input:
(define count 0)
;;; L-Eval value:
ok
;;; L-Eval input:
(define (id x)
  (set! count (+ count 1))
  x)
;;; L-Eval value:
ok
;;; L-Eval input:
(define w (id (id 10)))
;;; L-Eval value:
ok
;;; L-Eval input:
count
;;; L-Eval value:
1
;;; L-Eval input:
w
;;; L-Eval value:
10
;;; L-Eval input:
count
;;; L-Eval value:
2
;;; L-Eval input:
.

期待通り。

Exercise 4.28

applyが受け取る引数procedureはサンクの形ではprimitive-procedure?もcompound-procedure?も判断出来ない。
Scheme固有の書き方だが（（手続きを返す手続き引数1 引数2）引数3 引数4）の様な式を評価する時には「手続きを返す手続き」を評価しないとその次に呼び出す手続きが決まらない。
例えば以下の様な式を考える。

> (driver-loop)
;;; L-Eval input:
(define (op x) (if (= x 0) (lambda (n) n) (lambda (n) (/ n x))))
;;; L-Eval value:
ok
;;; L-Eval input:
((op 2) 10)
;;; L-Eval value:
5
;;; L-Eval input:
((op 0) 10)
;;; L-Eval value:
10
;;; L-Eval input:
.

Evalを以下の様に書き換える。

        ((application? exp)
         (apply-proc (operator exp)
                     (operands exp)
                     env))

実行してみる。

> (driver-loop)
;;; L-Eval input:
(define (op x) (if (= x 0) (lambda (n) n) (lambda (n) (/ n x))))
;;; L-Eval value:
ok
;;; L-Eval input:
((op 2) 10)
. . Unknown procedure type -- APPLY-PROC (op 2)
>

(op 2)が評価されていないのでapply（私のプログラムではapply-proc）が呼び出す手続きを決められない。

Exercise 4.29

メモ化無しで効率が悪くなる例と言えばフィボナッチ。
evalで時間を計ろうとしたらevalは再帰で何回も呼ばれるので、REPLでinputからactual-valueが返って来るまでの時間を表示する。

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read))
        (start (current-inexact-milliseconds)))
    (let ((output
           (actual-value input the-global-environment)))
      (display (- (current-inexact-milliseconds) start)(display "[msec]")(newline))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))

メモ化有りで実行。

> (driver-loop)

;;; L-Eval input:
(define (fib n) (cond ((= n 0) 0)((= n 1) 1)(else (+ (fib (- n 1)) (fib (- n 2))))))
2.451171875[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(fib 10)
255.638916015625[msec]
;;; L-Eval value:
55
;;; L-Eval input:
(fib 11)
393.114013671875[msec]
;;; L-Eval value:
89
;;; L-Eval input:
(fib 12)
673.136962890625[msec]
;;; L-Eval value:
144
;;; L-Eval input:
(fib 13)
1137.049072265625[msec]
;;; L-Eval value:
233
;;; L-Eval input:
(fib 14)
1803.777099609375[msec]
;;; L-Eval value:
377
;;; L-Eval input:
(fib 15)
2833.037109375[msec]
;;; L-Eval value:
610
;;; L-Eval input:
.

メモ化無しで実行。

> (driver-loop)

;;; L-Eval input:
(define (fib n) (cond ((= n 0) 0)((= n 1) 1)(else (+ (fib (- n 1)) (fib (- n 2))))))
3.23193359375[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(fib 10)
595.0400390625[msec]
;;; L-Eval value:
55
;;; L-Eval input:
(fib 11)
1190.075927734375[msec]
;;; L-Eval value:
89
;;; L-Eval input:
(fib 12)
1901.9599609375[msec]
;;; L-Eval value:
144
;;; L-Eval input:
(fib 13)
3267.421875[msec]
;;; L-Eval value:
233
;;; L-Eval input:
(fib 14)
5832.6298828125[msec]
;;; L-Eval value:
377
;;; L-Eval input:
(fib 15)
10242.323974609375[msec]
;;; L-Eval value:
610
;;; L-Eval input:
.

n	メモ化有り	メモ化無し
10	256	595
11	393	1190
12	673	1902
13	1137	3267
14	1804	5833
15	2833	10242

n=10では２倍強だが、n=15になると差はもっと広がる。

squareの例。x=(id 10)としてサンクになり、この値がsquareの中の2箇所で参照される。
メモ化有り。

> (driver-loop)

;;; L-Eval input:
(define count 0)
2.889892578125[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(define (id x)
  (set! count (+ count 1))
  x)
1.760009765625[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(define (square x)
  (* x x))
0.72900390625[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(square (id 10))
5.741943359375[msec]
;;; L-Eval value:
100
;;; L-Eval input:
count
0.069091796875[msec]
;;; L-Eval value:
1
;;; L-Eval input:
.

squareがidを通して10を得るのは１回のみ。

メモ化無し。

> (driver-loop)

;;; L-Eval input:
(define count 0)
1.157958984375[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(define (id x)
  (set! count (+ count 1))
  x)
1.430908203125[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(define (square x)
  (* x x))
0.155029296875[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(square (id 10))
3.220947265625[msec]
;;; L-Eval value:
100
;;; L-Eval input:
count
0.056884765625[msec]
;;; L-Eval value:
2
;;; L-Eval input:
.

メモ化されていないとidを２回呼び出している事が分かる。

Exercise 4.30

Cyの心配：シーケンス内の一つ一つの式（手続き呼び出し）はevalされただけでは引数がサンクになり、例えば引数部分に副作用を伴う手続き呼び出しがあった場合には、その手続きは呼び出されないかもしれない。
a.
Cyの心配とBenの説明が噛み合っているのかいま一つ分からないが、Benの説明には２カ所シーケンスが登場する。
for-eachの定義内にあるbeginブロックと、for-eachを使ったときのlambda。

for-eachの定義で(proc (car items))の部分で(car items)がサンクとなる。このサンクは結局lambdaのxとして渡されdisplayの引数となる。Racketではdisplayはプリミティブではないがいずれ何らかのプリミティブに渡されてそこで評価される事になるので、全ての要素についてちゃんと表示される。
b.
(p1 1)では1がサンクになってxに割り当てられ、p1の本体がeval-sequenceで評価される。
set!は手続きではないので(cons ...)の部分は遅延されずに評価される。更にconsはプリミティブなのでその引数は遅延されずに評価されるので、ここでサンクがフォースされる（list-of-arg-values→actual-value）。

(p2 1)の方もまず1がサンクとなってxに割り当てられる。
次に(p (set! ...))で(set! ...)の部分がサンクとなってeに割り当てられる。
pの本体がeval-sequenceで評価される。
問題はただeと書いてあるだけの部分。ここは変数を参照するのみ。環境からeに割り当てられた値としてサンクが引っ張られては来るが、それ以上の事は何も起きない。
その後のxの参照は元の1のサンクのまま。
なので、ここでCyのeval-sequenceはactual-valueを呼ぶ事によってeを参照する事によって戻って来たサンクをフォースする。これでxは書き替わって、新しいxが返る事になる。

元のeval-sequenceでの実行結果。

> (driver-loop)

;;; L-Eval input:
(define (p1 x)
  (set! x (cons x '(2)))
  x)
4.296875[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(define (p2 x)
  (define (p e)
    e
    x)
  (p (set! x (cons x '(2)))))
0.19091796875[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(p1 1)
4.041015625[msec]
;;; L-Eval value:
(1 2)
;;; L-Eval input:
(p2 1)
0.6279296875[msec]
;;; L-Eval value:
1
;;; L-Eval input:
.

確かにpの中のeは評価されていない模様。
Cyの実装による実行結果。

> (driver-loop)

;;; L-Eval input:
(define (p1 x)
  (set! x (cons x '(2)))
  x)
2.6669921875[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(define (p2 x)
  (define (p e)
    e
    x)
  (p (set! x (cons x '(2)))))
0.671142578125[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(p1 1)
2.541015625[msec]
;;; L-Eval value:
(1 2)
;;; L-Eval input:
(p2 1)
2.876953125[msec]
;;; L-Eval value:
(1 2)
;;; L-Eval input:
.

こちらはちゃんとeが評価されている。
c.
Cyの修正でfor-eachの(proc (car items))の部分を常にフォースする事になるが、

(proc (car items))の部分は手続きの引数ではない元々サンクにはならない。
procはサンクである可能性はあるが、この式のoperatorなので元々この式を評価する時にフォースされる。
lambdaの部分の(newline)はそのそも引数を持たない手続き呼び出しなのでフォースするか否かは関係無い。

なのでCyの変更はfor-eachの挙動には影響を与えない。
d.
第3章で学んだ様に副作用を持つ手続き、特に代入を含む手続きを持ち込むと、プログラム上で時間・順序・タイミングを気にしなければならなくしてしまう。
一方、遅延評価はそれをいつ評価しても結果が変わらない事が前提と考えると、評価するかしないか、あるいはいつ評価するかによって結果が変わってしまう様な状況とは同居させない事が得策。
逆にこの前提が成り立たないのであれば、いつ評価されるか分からない様ではプログラマは自分のプログラムをコントロール出来ないので、評価のタイミングを言語に任せるのではなくプログラマに任せるべき。とは言え、スレッドのコントロールと同じで並の人間がコントロールするのは恐らく無理。

つまり遅延評価と代入は混在させない方が良く、Cyの修正が必要になる様な状況は作るべきではない。
と考えると遅延評価をする言語ではシーケンスそのものは意味が無いかもしれない。最後の式以外は意味を持ち様が無いので。

Exercise 4.31

Schemeに対して上位互換を持たせる為に、手続きの何も指定が無ければ適用順序、lazyが指定されていればメモ化無し遅延評価、lazy-memorizedが指定されていればメモ化有り遅延評価とする。
問題文には

You will have to implement new syntax procedures to handle the new syntax for define.

とあるが、defineではなくlambdaの引数部分の書式が変わる筈。
lambdaはmake-procedureでリストを作るだけなのでこの時点では特にやる事は無し。
問題は手続きを呼び出す段階、つまりprocedureを評価する時点。遅延評価するか否かの情報はprocedureの仮引数リストに有り、実引数はlist-of-delayed-argsで現時点では全てサンクにされている。
この二つの情報が揃うのはmake-frame。私の評価器ではここで仮引数と実引数をペアにしているのでこの時点で、

デフォルトではフォースしてしまう
仮引数がペアでlazyが指定されていたら、サンクのシンボルを'thunk-without-memorizationに書き換える。
仮引数がペアでlazy-memoが指定されていたら、サンクのシンボルを'thunk-with-memorizationに書き換える。

こうした上でフレームの保存すれば良い。
デフォルトでは一旦サンクを作ってから直ぐにフォースする事になるので、ちょっとパフォーマンス的には無駄だが変更は少なそう。

後はforce-itでどちらのサンクかを判断して、普通に評価するか評価して値を保存するかすれば良い。

(define (thunk-with-memorization? obj)
  (tagged-list? obj 'thunk-with-memorization))
(define (thunk-without-memorization? obj)
  (tagged-list? obj 'thunk-without-memorization))

(define (force-it obj)
  (cond ((thunk-without-memorization? obj)
         (actual-value (thunk-exp obj) (thunk-env obj)))
        ((thunk-with-memorization? obj)
         (let ((result (actual-value
                        (thunk-exp obj)
                        (thunk-env obj))))
           (set-mcar! obj 'evaluated-thunk)
           (set-mcar! (mcdr obj) result)  ; replace exp with its value
           (set-mcdr! (mcdr obj) '())     ; forget unneeded env
           result))
        ((evaluated-thunk? obj)
         (thunk-value obj))
        (else obj)))

(define (change-tag obj sym)
  (mcons sym (mcdr obj)))

(define (make-frame variables values)
  (let ((hash (make-hash)))
    (for-each (lambda (a b)
                (cond ((symbol? a)
                       (dict-set! hash a (if (mpair? b)
                                             (force-it (change-tag b 'thunk-without-memorization))
                                             (force-it b))))
                      ((pair? a)
                       (dict-set! hash
                                  (car a) 
                                  (cond ((eq? (cadr a) 'lazy) (change-tag b 'thunk-without-memorization))
                                        ((eq? (cadr a) 'lazy-memo) (change-tag b 'thunk-with-memorization))
                                        (else (error "Unknown specifier of argument" a)))))
                      (else (error "Invalid parameter" a))))
                       variables values)
    hash))

フィボナッチ数計算とテキストのtryでテスト。

> (driver-loop)

;;; L-Eval input:
(define (fib n) (cond ((= n 0) 0)((= n 1) 1)(else (+ (fib (- n 1)) (fib (- n 2))))))
3.843994140625[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(fib 15)
3341.977783203125[msec]
;;; L-Eval value:
610
;;; L-Eval input:
(define (fib (n lazy)) (cond ((= n 0) 0)((= n 1) 1)(else (+ (fib (- n 1)) (fib (- n 2))))))
0.47509765625[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(fib 15)
11372.993896484375[msec]
;;; L-Eval value:
610
;;; L-Eval input:
(define (fib (n lazy-memo)) (cond ((= n 0) 0)((= n 1) 1)(else (+ (fib (- n 1)) (fib (- n 2))))))
0.89111328125[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(fib 15)
3426.266845703125[msec]
;;; L-Eval value:
610
;;; L-Eval input:
(define (try a (b lazy))
  (if (= a 0) 1 b))
0.552978515625[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(try 0 (/ 1 0))
0.535888671875[msec]
;;; L-Eval value:
1
;;; L-Eval input:
(define (try a b)
  (if (= a 0) 1 b))
0.553955078125[msec]
;;; L-Eval value:
ok
;;; L-Eval input:
(try 0 (/ 1 0))
. . /: division by zero
>

メモ化の効果が見られる。メモ化遅延評価と遅延無しはあまり変わらない。
遅延評価だと(/ 1 0)は評価されていないが、遅延無しだと手続き呼び出し前に評価してしまうので０割り算のエラーとなる。