今回は micro Scheme に「末尾再帰最適化」を実装しましょう。Scheme は言語仕様に末尾再帰最適化を行うことが明記されています。ところが Common Lisp の場合、末尾再帰最適化は仕様に含まれてないので、最適化の実装は処理系に依存します。
SBCL は末尾再帰最適化が行われるので、micro Scheme を SBCL で動作させれば、プログラムを修正しなくても末尾再帰は最適化されます。ところが、CLISP で micro Scheme を動作させると、末尾再帰は最適化されません。SBCL の末尾再帰最適化は CLISP よりも優れているようです。
なお、今回のプログラムで継続の実装は行いません。継続と末尾再帰の実装については今後の研究課題にしたいと思います。
CLISP で micro Scheme の末尾呼び出しを最適化する場合、末尾呼び出しは m-eval を呼び出して評価するのではなく、そのときの m-eval の環境を使って評価するようにします。具体的には、m-eval の引数 expr と env を末尾呼び出しのものに書き換えて、それを評価すればいいわけです。末尾呼び出しを評価するとき、残りの処理を実行するための情報を保存する必要がないので、引数 expr と env を書き換えても正常に動作します。
micro Scheme で末尾呼び出しが行われるのは、if を評価する関数 m-if とラムダ式の本体を評価する eval-body の 2 つです。これらの関数を m-eval に埋め込んで処理することもできますが、プログラムが複雑になってしまいます。そこで、m-if と eval-body は末尾の S 式を評価せずに、次のリストに格納して返すことにします。
(tail-call expr env)
expr は評価する S 式で、env はその時点での環境です。m-eval では S 式の評価結果をチェックし、それが (tail-call ...) であれば m-eval の引数 expr と env を書き換えて、それを再度評価することにします。今回は継続のことは考えずに、伝統的なマクロを実装した micro Scheme で末尾再帰最適化をプログラムします。
関数 m-if と eval-body の修正は次のようになります。
リスト : if の処理
(defun m-if (expr env)
(if (true-p (m-eval (cadr expr) env))
(list 'tail-call (caddr expr) env)
(if (null (cdddr expr))
'*undef*
(list 'tail-call (cadddr expr) env))))
リスト : body の評価
(defun eval-body (body env)
(cond ((null (cdr body))
(list 'tail-call (car body) env))
(t
(m-eval (car body) env)
(eval-body (cdr body) env))))
m-if の場合、then 節でも else 節でも末尾呼び出しになるので、評価する S 式と環境をリストに格納して返します。eval-body は最後尾の S 式以外は m-eval で評価します。最後尾の S 式と環境はリストに格納して返します。
m-eval の修正は次のようになります。
リスト : S 式の評価
(defun m-eval (expr env)
(loop
(cond ((self-evaluationp expr) (return expr))
((symbolp expr)
(let ((cell (lookup expr env)))
(if cell
(return (cdr cell))
(error "unbound variable ~S" expr))))
((consp expr)
(let* ((procedure (m-eval (car expr) env))
(value
(case (car procedure)
((syntax) (funcall (cadr procedure) expr env))
((macro)
(m-eval (macro-expand (cdr procedure) (cdr expr)) env))
(t
(m-apply procedure
(mapcar #'(lambda (x) (m-eval x env))
(cdr expr)))))))
(if (and (consp value)
(eq (car value) 'tail-call))
(setq expr (second value)
env (third value))
(return value))))
(t
(error "unknown expression type -- m-eval ~S" expr)))))
m-eval の処理を loop で囲みます。値を返すときは return を使います。expr がリストの場合、それを評価した結果を変数 value にセットします。そして、value がリストで、その先頭要素が tail-call の場合、m-eval の引数 expr と env を value の第 2 要素と第 3 要素に書き換えます。そして、loop で処理の先頭に戻って expr を評価します。tail-call でない場合、return で value を返します。
今まではマクロ展開を行うのに m-apply を呼び出していましたが、tail-call の処理が複雑になるので、マクロ展開を行う専用の関数 macro-expand を作ります。次のリストを見てください。
リスト : マクロ展開
(defun macro-expand (procedure actuals)
(labels ((eval-body (body env)
(cond ((null (cdr body))
(m-eval (car body) env))
(t
(m-eval (car body) env)
(eval-body (cdr body) env)))))
(let ((expr (cadr procedure)))
(eval-body (cddr expr)
(add-binding (cadr expr) actuals (caddr procedure))))))
labels で局所関数 eval-body を定義します。これは今までの eval-body と同じです。したがって、マクロ展開で末尾再帰の最適化は行われません。あとは、add-binding で変数束縛を行ってラムダ式の本体を評価するだけです。
それでは簡単な実行例を示します。なお、簡単にテストできるように、primitive に算術演算子 (+, -, *, /) と比較演算子 (=, <, >, <=, >=) を追加しました。簡単な例として 1 から x までの合計値を求めるプログラムを作ります。次のリストを見てください。
リスト : 1 から x までの合計値を求める
(define sum
(lambda (x)
(if (= x 0)
0
(+ x (sum (- x 1))))))
(define sum1
(lambda (x a)
(if (= x 0)
a
(sum1 (- x 1) (+ a x)))))
関数 sum は末尾再帰になっていないので、大きな値を計算することはできません。関数 sum1 は末尾再帰になっているので、micro Scheme が末尾再帰を最適化すれば、大きな値でも計算することができます。CLISP での実行結果は次のようになりました。
>>> (sum1 100000 0) 5000050000 >>> (sum 100000) *** - Lisp stack overflow. RESET
このように、末尾再帰していない sum ではスタックオーバーフローが発生します。なお、末尾再帰最適化が行われないと、次に示すように sum1 でもスタックオーバーフローが発生します。
>>> (sum1 100000 0) *** - Lisp stack overflow. RESET
Common Lisp で作る micro Scheme (2) で作成したプログラムに算術演算子と比較演算子を追加して実行すると、このようにスタックオーバーフローとなります。
もう一つ簡単な例を示しましょう。数列を生成する関数 iota は n 個の数列を生成する関数です。
iota n [start step]
start から始まり step ずつ増加する数列を生成します。start と step が省略された場合は 0 から始まり 1 ずつ増加する数列になります。プログラムは次のようになります。
リスト : 数列の生成
(define iota
(lambda (n . args)
(let ((start (if (pair? args) (car args) 0))
(step (if (and (pair? args) (pair? (cdr args))) (cadr args) 1)))
(let loop ((m n) (last (+ start (* step (- n 1)))) (a '()))
(if (= m 0)
a
(loop (- m 1) (- last step) (cons last a)))))))
最初に引数 args から start と step の値を取得します。次に、最後尾の値 last を求めます。そして、named let で n 個の要素を生成してリスト a に格納します。このとき、後ろの要素から順番に生成していくことに注意してください。
iota は末尾再帰になっています。micro Scheme が末尾再帰を最適化すれば、引数 n に大きな値を与えてもリストを生成することができます。ところが、Common Lisp で作る micro Scheme (2) で作成した micro Scheme は CLISP で実行すると末尾再帰最適化が行われないので、次のようにスタックオーバーフローが発生します。
>>> (iota 10000) *** - Lisp stack overflow. RESET
今回修正した micro Scheme は CLISP でも正常に動作します。もちろん、次の関数を実行すると CLISP でも無限ループになります。
>>> (define foo (lambda () (foo))) foo >>> (foo) => 無限ループになる
次は「たらいまわし関数」で実行速度を計測してみましょう。Common Lisp にはマクロ time が用意されていて、関数を評価したときのさまざまな情報を表示することができます。このマクロを使うため、次の関数を micro Scheme に追加します。
リスト : 実行時間の計測 (defun m-time (expr env) (time (m-eval (cadr expr) env)))
あとは *global-environment* に (list 'time 'syntax #'m-time) を追加するだけです。これで関数の実行時間を計測することができます。
それでは、実際に試してみましょう。プログラムリストと実行結果を示します。
リスト : たらいまわし関数
(define tarai
(lambda (x y z)
(if (<= x y)
y
(tarai (tarai (- x 1) y z) (tarai (- y 1) z x) (tarai (- z 1) x y)))))
(define tak
(lambda (x y z)
(if (<= x y)
z
(tak (tak (- x 1) y z) (tak (- y 1) z x) (tak (- z 1) x y)))))
表 : たらいまわし関数の実行結果
最適化 : 自動 : 手動
---------------+------+------
(tarai 12 6 0) : 16.1 : 19.5
(tak 16 8 0) : 3.2 : 3.2
単位 : 秒
SBCL (ver 1.4.5), Ubuntu 18.04 (WSL), Intel Core i5-6200U 2.30GHz
実行速度は手動で末尾再帰を最適化した今回のプログラムが遅くなりました。CLISP で実行した場合も、今回のプログラムが遅くなります。コンスセルの消費量も今回のプログラムが多くなりました。その分だけ実行速度も遅くなるようです。今回のような単純な方法では、実行速度まで改善するのは難しいようです。
関数 tarai は「遅延評価 (delayed evaluation または lazy evaluation) 」を行う処理系、たとえば関数型言語の Haskell では高速に実行することができます。また、Scheme でも delay と force を使って遅延評価を行うことができます。
tarai のプログラムを見てください。x <= y のときに y を返しますが、このとき引数 z の値は必要ありませんね。引数 z の値は x > y のときに計算するようにすれば、無駄な計算を省略することができます。なお、関数 tak は x <= y のときに z を返しているため、遅延評価で高速化することはできません。ご注意ください。
Scheme の delay と force は、micro Scheme でもマクロを使って簡単に実装することができます。次のリストを見てください。
リスト : delay と force
(define-macro delay
(lambda (expr)
`(make-promise (lambda () ,expr))))
(define make-promise
(lambda (f)
(let ((flag false) (result false))
(lambda ()
(if (not flag)
(let ((x (f)))
(if (not flag)
(begin (set! flag true)
(set! result x)))))
result))))
(define force
(lambda (promise) (promise)))
リストの delay と force は 参考文献 3 に掲載されているプログラムを micro Scheme で書き直したものです。delay の引数 expr をクロージャに格納して関数 make-promis に渡します。make-promise はクロージャを生成して返します。このデータを Scheme では「プロミス」といいます。force は簡単で、引数 promise を評価するだけです。
make-promise はクロージャを生成し、その中にクロージャ f の評価結果を格納します。flag が false の場合は f を評価していないので、f を評価して返り値を result にセットし、flag の値を true に書き換えます。flag が true ならば f は評価済みなので result を返します。
簡単な使用例を示しましょう。
>>> (define a (delay (+ 10 20))) A >>> (force a) 30
(delay (+ 10 20)) の返り値を変数 a にセットします。このとき、S 式 (+ 10 20) は評価されていません。遅延オブジェクトの値を実際に求める関数が force です。(force a) を評価すると、S 式 (+ 10 20) を評価して値 30 を返します。
また、遅延オブジェクトは式の評価結果をキャッシュします。したがって、(force a) を再度実行すると、同じ式を再評価することなく値を求めることができます。次の例を見てください。
>>> (define b (delay (begin (display "oops! ") (+ 10 20)))) B >>> (force b) oops! 30 >>> (force b) 30
最初に (force b) を実行すると、S 式 (begin (display "oops! ") (+ 10 20)) が評価されるので、画面に oops! が表示されます。次に、(force b) を実行すると、式を評価せずにキャッシュした値を返すので oops! は表示されません。
delay と force を使うと、tarai は次のようになります。
リスト : delay と force による遅延評価
(define tarai
(lambda (x y z)
(if (<= x y)
y
(let ((zz (force z)))
(tarai (tarai (- x 1) y (delay zz))
(tarai (- y 1) zz (delay x))
(delay (tarai (- zz 1) x (delay y))))))))
関数 tarai の引数 z にデータを渡すとき、delay で遅延オブジェクトを生成します。そして、その値を取り出すときは (force z) とします。これで遅延評価を行うことができます。
それでは、実際に実行してみましょう。
(tarai 12 6 (delay 0)) SBCL : 0.005 [s] (tarai 100 50 (delay 0)) SBCL : 0.36s [s]
(tarai 12 6 0) は瞬時に、大きな値でも高速に実行することができました。遅延評価の効果は十分に出ていると思います。
;;;
;;; micro.lsp : micro Scheme with Common Lisp
;;;
;;; (1) 基本機能の実装
;;; (2) 伝統的なマクロの追加
;;; (3) CLISP でも末尾再帰最適化が行われるように修正
;;;
;;; Copyright (C) 2009-2021 Makoto Hiroi
;;;
;;; 関数宣言
(declaim (ftype (function (t list) t) m-eval))
(declaim (ftype (function (list list) t) m-apply))
;;; 大域変数
(defvar *global-environment*)
;;; 変数束縛
(defun add-binding (vars vals env)
(cond ((null vars) env)
((symbolp vars)
(cons (cons vars vals) env))
(t
(cons (cons (car vars) (car vals))
(add-binding (cdr vars) (cdr vals) env)))))
;;; 変数の値を取得
(defun lookup (var env)
(let ((value (assoc var env)))
(if value
value
(assoc var *global-environment*))))
;;;
;;; syntax
;;;
;;; (quote x)
(defun m-quote (expr env)
(declare (ignore env))
(cadr expr))
(defun true-p (x) (not (eq x 'false)))
;;; (if test then eles)
(defun m-if (expr env)
(if (true-p (m-eval (cadr expr) env))
(list 'tail-call (caddr expr) env)
(if (null (cdddr expr))
'*undef*
(list 'tail-call (cadddr expr) env))))
;;; (lambda (args ...) body ...)
(defun m-lambda (expr env)
(list 'closure expr env))
;;; (define name s-expr)
(defun m-define (expr env)
(setf *global-environment*
(cons (cons (cadr expr)
(m-eval (caddr expr) env))
*global-environment*))
(cadr expr))
;;; (set! name value)
(defun m-set! (expr env)
(let ((cell (lookup (cadr expr) env)))
(setf (cdr cell) (m-eval (caddr expr) env))
(cdr cell)))
;;; (time expr)
(defun m-time (expr env)
(time (m-eval (cadr expr) env)))
;;;
;;; マクロ
;;;
;;; (define-macro name s-expr)
(defun m-define-macro (exp env)
;; とりあえず大域変数のみ
(setq *global-environment*
(cons (cons (cadr exp)
(cons 'macro (m-eval (caddr exp) env)))
*global-environment*))
;; symbol を返す
(cadr exp))
;;; backquote
(defun m-backquote (expr env)
(labels ((transfer (ls)
(cond ((consp ls)
(cond ((consp (car ls))
(cond ((eq (caar ls) 'unquote)
(cons (m-eval (cadar ls) env)
(transfer (cdr ls))))
((eq (caar ls) 'splice)
(append (m-eval (cadar ls) env)
(transfer (cdr ls))))
(t (cons (transfer (car ls))
(transfer (cdr ls))))))
(t (cons (car ls) (transfer (cdr ls))))))
(t ls))))
(transfer (cadr expr))))
;;;
;;; 関数適用
;;;
;;; 関数値 : (tag ...)
;;; tag
;;; syntax : シンタックス形式 (syntax m-xxx)
;;; primitive : プリミティブ (primitive #<subr ...>)
;;; closure : クロージャ (closure (lambda (args ...) body ...) env)
;;; body の評価
(defun eval-body (body env)
(cond ((null (cdr body))
(list 'tail-call (car body) env))
(t
(m-eval (car body) env)
(eval-body (cdr body) env))))
;;; apply
(defun m-apply (procedure actuals)
(case (car procedure)
((primitive)
(apply (cadr procedure) actuals))
((closure)
(let ((expr (cadr procedure)))
(eval-body (cddr expr)
(add-binding (cadr expr) actuals (caddr procedure)))))
(t
(error "unknown procedure type -- m-apply ~S" procedure))))
;;; マクロ展開
(defun macro-expand (procedure actuals)
(labels ((eval-body (body env)
(cond ((null (cdr body))
(m-eval (car body) env))
(t
(m-eval (car body) env)
(eval-body (cdr body) env)))))
(let ((expr (cadr procedure)))
(eval-body (cddr expr)
(add-binding (cadr expr) actuals (caddr procedure))))))
;;;
;;; S 式の評価
;;;
;;; 自己評価フォームか
(defun self-evaluationp (expr)
(and (not (consp expr)) (not (symbolp expr))))
;;; eval
(defun m-eval (expr env)
(loop
(cond ((self-evaluationp expr) (return expr))
((symbolp expr)
(let ((cell (lookup expr env)))
(if cell
(return (cdr cell))
(error "unbound variable ~S" expr))))
((consp expr)
(let* ((procedure (m-eval (car expr) env))
(value
(case (car procedure)
((syntax) (funcall (cadr procedure) expr env))
((macro)
(m-eval (macro-expand (cdr procedure) (cdr expr)) env))
(t
(m-apply procedure
(mapcar (lambda (x) (m-eval x env))
(cdr expr)))))))
(if (and (consp value)
(eq (car value) 'tail-call))
(setq expr (second value)
env (third value))
(return value))))
(t
(error "unknown expression type -- m-eval ~S" expr)))))
;;; 初期化
(setf *global-environment*
(list
(cons 'true 'true)
(cons 'false 'false)
(cons 'nil 'nil)
(cons 'quit 'quit)
(list 'car 'primitive (lambda (x)
(if (null x)
(error "type error -- car NIL")
(car x))))
(list 'cdr 'primitive (lambda (x)
(if (null x)
(error "type error -- cdr NIL")
(cdr x))))
(list 'cons 'primitive #'cons)
(list 'eq? 'primitive (lambda (x y) (if (eq x y) 'true 'false)))
(list 'eqv? 'primitive (lambda (x y) (if (eql x y) 'true 'false)))
(list 'pair? 'primitive (lambda (x) (if (consp x) 'true 'false)))
(list 'display 'primitive (lambda (x) (princ x) '*undef*))
(list 'newline 'primitive (lambda () (terpri) '*undef*))
(list '+ 'primitive #'+)
(list '- 'primitive #'-)
(list '* 'primitive #'*)
(list '/ 'primitive #'/)
(list '= 'primitive (lambda (&rest x) (if (apply #'= x) 'true 'false)))
(list '< 'primitive (lambda (&rest x) (if (apply #'< x) 'true 'false)))
(list '> 'primitive (lambda (&rest x) (if (apply #'> x) 'true 'false)))
(list '<= 'primitive (lambda (&rest x) (if (apply #'<= x) 'true 'false)))
(list '>= 'primitive (lambda (&rest x) (if (apply #'>= x) 'true 'false)))
(list 'if 'syntax #'m-if)
(list 'quote 'syntax #'m-quote)
(list 'lambda 'syntax #'m-lambda)
(list 'define 'syntax #'m-define)
(list 'set! 'syntax #'m-set!)
(list 'time 'syntax #'m-time)
(list 'define-macro 'syntax #'m-define-macro)
(list 'backquote 'syntax #'m-backquote)
))
;;;
;;; read-eval-print-loop
;;;
(defun change-readtable ()
(set-macro-character
#\`
(lambda (stream char)
(declare (ignore char))
(list 'backquote (read stream t nil t))))
(set-macro-character
#\,
(lambda (stream char)
(declare (ignore char))
(cond ((char= (peek-char nil stream) #\@)
(read-char stream)
(list 'splice (read stream t nil t)))
(t (list 'unquote (read stream t nil t)))))))
(defun repl (&rest file-list)
(unwind-protect
(progn
(change-readtable)
(dolist (file file-list)
(with-open-file (in file :direction :input)
(do ((output t))
((eq output nil) (terpri))
(setf output (m-eval (read in nil) '()))
(print output))))
(do ((output nil))
((eq output 'quit))
(princ ">>> ")
(force-output)
(handler-case
(progn
(setf output (m-eval (read) '()))
(princ output)
(terpri))
(simple-error (c) (format t "ERROR: ~a~%" c)))))
(setq *readtable* (copy-readtable nil))))