今まで作成した micro Scheme コンパイラは、命令 ldg, gset で大域変数にアクセスするとき、大域変数の環境 *global-environment* を関数 assoc で線形探索していました。プログラムの実行時に探索を行うと、実行時間はどうしても遅くなります。コンパイル時に大域変数の配置を決めておくと、実行時間はもう少し速くなると思われます。
micro Scheme コンパイラで一番簡単な修正方法は、コンパイル時に変数 sym を環境 *global-environment* から探索し、見つけた場合は sym ではなくセル (sym . value) を ldg, gset 命令に渡すようにコンパイルすることです。そうすると、ldg はセルの CDR 部の値 value をスタックに積むだけ、gset はセルの CDR 部をスタックトップの値に書き換えるだけで実現できます。
変数 sym が見つからない場合、セル (sym . *undef*) を生成して環境に追加することにします。*undef* は未束縛の変数であることを表すシンボルとして使います。これで define, define-macro を処理する命令 def, defm に対応することができます。*undef* のチェックは ldg, gset 命令で行えばいいでしょう。もちろん、コンパイル時にエラーチェックしてもかまいませんが、今回は簡単な方法を選びました。
それではプログラムを修正しましょう。最初に、環境から大域変数を格納したセルを求める関数 location-gvar を作ります。
リスト : 大域変数の配置を求める
;;; 大域変数の配置を求める
(define (location-gvar expr)
(let ((cell (assoc expr *global-environment*)))
(unless cell
(set! cell (cons expr '*undef*))
(push! *global-environment* cell))
cell))
;;; 大域変数の値を求める
(define (get-gvar expr)
(cdr (location-gvar expr)))
location-gvar は環境 *global-environment* から引数 expr を assoc で探索します。見つからない場合、(cons expr '*undef*) で expr 用のセルを生成し、それを環境に追加します。最後にそのセル cell を返します。関数 get-gvar は大域変数 expr の値を返します。location-gvar でセルを求め、その CDR 部の値を返します。
次はコンパイル処理を修正します。次のリストを見てください。
リスト : コンパイラの修正
・・・・・
((symbol? expr) ; 変数
(let ((pos (location expr env)))
(if pos
;; 局所変数
(list* 'ld pos code)
;; 大域変数
(list* 'ldg (location-gvar expr) code))))
・・・・・
((eq? (car expr) 'define)
(comp (caddr expr) env (list* 'def (location-gvar (cadr expr)) code) #f))
((eq? (car expr) 'define-macro)
(comp (caddr expr) env (list* 'defm (location-gvar (cadr expr)) code) #f))
((eq? (car expr) 'set!)
(let ((pos (location (cadr expr) env)))
(if pos
;; 局所変数
(comp (caddr expr) env (list* 'lset pos code) #f)
;; 大域変数
(comp (caddr expr) env (list* 'gset (location-gvar (cadr expr)) code) #f))))
・・・・・
変数のアクセスで、大域変数の場合は location-gvar で大域変数のセルを求めて ldg のあとにセットします。set! も同様にコンパイルします。define, define-macro も修正が必要で、def, defm 命令のあとに location-gvar の返り値をセットします。
次は仮想マシン vm を修正します。次のリストを見てください。
リスト : 仮想マシンの修正
・・・・・
((ldg)
(let ((v (cdar c)))
(when (eq? v '*undef*)
(error "unbound variable " (caar c)))
(vm (cons v s) e (cdr c) d)))
・・・・・
((gset)
(when (eq? (cdar c) '*undef*)
(error "unbound variable " (caar c)))
(set-cdr! (car c) (car s))
(vm s e (cdr c) d))
・・・・・
((def)
(let ((cell (car c)))
(set-cdr! cell (car s))
(vm (cons (car cell) (cdr s)) e (cdr c) d)))
((defm)
(let ((cell (car c)))
(set-cdr! cell (cons 'macro (car s)))
(vm (cons (car cell) (cdr s)) e (cdr c) d)))
・・・・・
ldg の場合、c の先頭に大域変数のセルが格納されているので、(cdar c) で変数の値 v を求め、それが *undef* ならばエラーを送出します。そうでなければ v をスタックに積むだけです。gset の場合も c の先頭に大域変数のセルが格納されているので、その CDR 部を set-cdr! でスタックトップの値 (car s) に書き換えるだけです。def と defm は gset と同様に大域変数のセル (cell) の CDR 部を書き換えて、変数名 (car cell) をスタックに積むだけです。
修正はこれだけです。プログラムの詳細はプログラムリスト２をお読みください。
それでは実行してみましょう。1 から n までの和を求める関数 sum1 (末尾再帰版) とたらいまわし関数で試してみました。
表 : 実行結果
| A | B
-----------------+-------+--------
(sum1 1000000 0) | 12.00 | 7.67
(tarai 10 5 0) | 3.80 | 2.29
(tak 14 7 0) | 3.83 | 2.64
A : 改良前
B : 改良後
単位 : 秒
実行環境 : Gauche version 0.9.10, Ubunts 18.04 (WSL), Intel Core i5-6200U 2.30GHz
大域変数のアクセス方法を改良することで、実行時間は少し速くなりました。簡単な方法ですが、関数を呼び出すときに ldg 命令を使っているので、その効果はけっこう大きいようです。
なお、今回の修正方法がベストというわけではありません。たとえば、他の言語で実装する場合、シンボルを表すデータ構造を作り、その中に大域変数の値を格納する領域を用意します。そうすると、ldg, gset, def, defm 命令にはシンボルを渡すだけで、大域変数の値にアクセスすることができます。いろいろな方法を考えて試してみるのも面白いと思います。
;;;
;;; secd.scm : SECD 仮想マシンによる Scheme コンパイラ (R7RS-small 対応版)
;;;
;;; (1) 基本機能の実装
;;; (2) 伝統的なマクロの実装
;;; (3) 継続の実装
;;; (4) 末尾再帰最適化
;;; (5) ldg, gset 命令の改良
;;;
;;; Copyright (C) 2009-2021 Makoto Hiroi
;;;
(import (scheme base) (scheme cxr) (scheme write) (scheme read)
(scheme file) (scheme process-context) (scheme time))
;;; データの追加
(define-syntax push!
(syntax-rules ()
((_ place x) (set! place (cons x place)))))
;;; データの取得
(define-syntax pop!
(syntax-rules ()
((_ place)
(let ((x (car place)))
(set! place (cdr place))
x))))
;;; ドットリストの生成
(define (list* . xs)
(if (null? (cdr xs))
(car xs)
(cons (car xs) (apply list* (cdr xs)))))
;;; 変数の位置を求める
(define (position-var sym ls)
(let loop ((i 0) (ls ls))
(cond ((null? ls) #f)
((symbol? ls)
(if (eq? sym ls) (- (+ i 1)) #f))
((eq? sym (car ls)) i)
(else
(loop (+ i 1) (cdr ls))))))
;;; フレームと変数の位置を求める
(define (location sym ls)
(let loop ((i 0) (ls ls))
(if (null? ls)
#f
(let ((j (position-var sym (car ls))))
(if j
(cons i j)
(loop (+ i 1) (cdr ls)))))))
;;; 大域変数の配置を求める
(define (location-gvar expr)
(let ((cell (assoc expr *global-environment*)))
(unless cell
(set! cell (cons expr '*undef*))
(push! *global-environment* cell))
cell))
;;; 大域変数の値を求める
(define (get-gvar expr)
(cdr (location-gvar expr)))
;;; 自己評価フォームか
(define (self-evaluation? expr)
(and (not (pair? expr)) (not (symbol? expr))))
;;; マクロか
(define (macro? expr)
(let ((val (assoc expr *global-environment*)))
(and val (pair? (cdr val)) (eq? 'macro (cadr val)))))
;;; マクロのコードを取得する
(define (get-macro-code expr)
(caddr (get-gvar expr)))
;;; S 式をコンパイルする
(define (compile expr)
(comp expr '() '(stop) #f))
;;; コンパイル本体
(define (comp expr env code tail)
(cond ((self-evaluation? expr) ; 自己評価フォーム
(list* 'ldc expr code))
((symbol? expr) ; 変数
(let ((pos (location expr env)))
(if pos
;; 局所変数
(list* 'ld pos code)
;; 大域変数
(list* 'ldg (location-gvar expr) code))))
((eq? (car expr) 'quote)
(list* 'ldc (cadr expr) code))
((eq? (car expr) 'if)
(if tail
;; 末尾呼び出し
(let ((t-clause (comp (caddr expr) env '(rtn) #t))
(f-clause
(if (null? (cdddr expr))
(list 'ldc '*undef 'rtn)
(comp (cadddr expr) env '(rtn) #t))))
(comp (cadr expr) env (list* 'selr t-clause f-clause (cdr code)) #f))
(let ((t-clause (comp (caddr expr) env '(join) #f))
(f-clause
(if (null? (cdddr expr))
(list 'ldc '*undef 'join)
(comp (cadddr expr) env '(join) #f))))
(comp (cadr expr) env (list* 'sel t-clause f-clause code) #f))))
((eq? (car expr) 'lambda)
(let ((body (comp-body (cddr expr) (cons (cadr expr) env) '(rtn))))
(list* 'ldf body code)))
((eq? (car expr) 'define)
(comp (caddr expr) env (list* 'def (location-gvar (cadr expr)) code) #f))
((eq? (car expr) 'define-macro)
(comp (caddr expr) env (list* 'defm (location-gvar (cadr expr)) code) #f))
((eq? (car expr) 'set!)
(let ((pos (location (cadr expr) env)))
(if pos
;; 局所変数
(comp (caddr expr) env (list* 'lset pos code) #f)
;; 大域変数
(comp (caddr expr) env (list* 'gset (location-gvar (cadr expr)) code) #f))))
((eq? (car expr) 'call/cc)
(list* 'ldct code 'args 1 (comp (cadr expr) env (cons 'app code) #f)))
((eq? (car expr) 'apply)
(complis (cddr expr)
env
(list* 'args-ap
(length (cddr expr))
(comp (cadr expr) env (cons 'app code) #f))))
((macro? (car expr))
;; マクロ展開してからコンパイルする
(let ((new-expr (vm '()
(list (cdr expr))
(get-macro-code (car expr))
(list (list '() '() '(stop))))))
(comp new-expr env code #f)))
(else ; 関数呼び出し
(complis (cdr expr)
env
(list* 'args
(length (cdr expr))
(comp (car expr) env (cons (if tail 'tapp 'app) code) #f))))))
;;; ラムダ式本体のコンパイル
(define (comp-body body env code)
(if (null? (cdr body))
(comp (car body) env code #t)
(comp (car body)
env
(list* 'pop
(comp-body (cdr body) env code))
#f)))
;;; 引数を評価するコードを生成
(define (complis expr env code)
(if (null? expr)
code
(comp (car expr) env (complis (cdr expr) env code) #f)))
;;;
;;; 仮想マシン
;;;
;;; ls の先頭から n 個の要素を取り除く
(define (drop ls n)
(if (zero? n)
ls
(drop (cdr ls) (- n 1))))
;;; 局所変数の値を求める
(define (get-lvar e i j)
(if (<= 0 j)
(list-ref (list-ref e i) j)
(drop (list-ref e i) (- (+ j 1)))))
;;; 局所変数の値を更新する
(define (set-lvar! e i j val)
(if (<= 0 j)
(set-car! (drop (list-ref e i) j) val)
(if (= j -1)
(set-car! (drop e i) val)
(set-cdr! (drop (list-ref e i) (- (+ j 2))) val))))
;;; 仮想マシンでコードを実行する
(define (vm s e c d)
(case (pop! c)
((ld)
(let ((pos (car c)))
(vm (cons (get-lvar e (car pos) (cdr pos)) s) e (cdr c) d)))
((ldc)
(vm (cons (car c) s) e (cdr c) d))
((ldg)
(let ((v (cdar c)))
(when (eq? v '*undef*)
(error "unbound variable " (caar c)))
(vm (cons v s) e (cdr c) d)))
((ldf)
(vm (cons (list 'closure (car c) e) s) e (cdr c) d))
((ldct)
(vm (cons (list 'continuation s e (car c) d) s) e (cdr c) d))
((lset)
(let ((pos (car c)))
(set-lvar! e (car pos) (cdr pos) (car s))
(vm s e (cdr c) d)))
((gset)
(when (eq? (cdar c) '*undef*)
(error "unbound variable " (caar c)))
(set-cdr! (car c) (car s))
(vm s e (cdr c) d))
((app)
(let ((clo (car s)) (lvar (cadr s)))
(case (pop! clo)
((primitive)
(vm (cons (apply (car clo) lvar) (cddr s)) e c d))
((continuation)
(vm (cons (car lvar) (car clo)) (cadr clo) (caddr clo) (cadddr clo)))
(else
(vm '() (cons lvar (cadr clo)) (car clo) (cons (list (cddr s) e c) d))))))
((tapp)
(let ((clo (car s)) (lvar (cadr s)))
(case (pop! clo)
((primitive)
(vm (cons (apply (car clo) lvar) (cddr s)) e c d))
((continuation)
(vm (cons (car lvar) (car clo)) (cadr clo) (caddr clo) (cadddr clo)))
(else
(vm (cddr s) (cons lvar (cadr clo)) (car clo) d)))))
((rtn)
(let ((save (car d)))
(vm (cons (car s) (car save)) (cadr save) (caddr save) (cdr d))))
((sel)
(let ((t-clause (car c))
(e-clause (cadr c)))
(if (car s)
(vm (cdr s) e t-clause (cons (cddr c) d))
(vm (cdr s) e e-clause (cons (cddr c) d)))))
((selr)
(let ((t-clause (car c))
(e-clause (cadr c)))
(if (car s)
(vm (cdr s) e t-clause d)
(vm (cdr s) e e-clause d))))
((join)
(vm s e (car d) (cdr d)))
((pop)
(vm (cdr s) e c d))
((args)
(let loop ((n (car c)) (a '()))
(if (zero? n)
(vm (cons a s) e (cdr c) d)
(loop (- n 1) (cons (pop! s) a)))))
((args-ap)
(let loop ((n (- (car c) 1)) (a (list-copy (pop! s))))
(if (zero? n)
(vm (cons a s) e (cdr c) d)
(loop (- n 1) (cons (pop! s) a)))))
((def)
(let ((cell (car c)))
(set-cdr! cell (car s))
(vm (cons (car cell) (cdr s)) e (cdr c) d)))
((defm)
(let ((cell (car c)))
(set-cdr! cell (cons 'macro (car s)))
(vm (cons (car cell) (cdr s)) e (cdr c) d)))
((stop) (car s))
(else (error "unknown opcode"))))
;;; 大域変数
(define *global-environment*
(list
(list 'car 'primitive car)
(list 'cdr 'primitive cdr)
(list 'cons 'primitive cons)
(list 'eq? 'primitive eq?)
(list 'eqv? 'primitive eqv?)
(list 'pair? 'primitive pair?)
(list 'exit 'primitive exit)
(list 'error 'primitive error)
(list 'display 'primitive display)
(list 'newline 'primitive newline)
(list '+ 'primitive +)
(list '- 'primitive -)
(list '* 'primitive *)
(list '/ 'primitive /)
(list '= 'primitive =)
(list '< 'primitive <)
(list '> 'primitive >)
(list '<= 'primitive <=)
(list '>= 'primitive >=)
))
;;; read-eval-print-loop
(define (repl)
(let loop ()
(display "\n>>> ")
(guard (err
(else (display "ERROR: ")
(display (error-object-message err))
(unless
(null? (error-object-irritants err))
(display (car (error-object-irritants err))))
(newline)))
(let* ((expr (compile (read)))
(s (current-jiffy))
(v (vm '() '() expr '())))
(when (eof-object? v) (exit))
(display v)
(newline)
(display (inexact (/ (- (current-jiffy) s) (jiffies-per-second))))
(newline)))
(loop)))
;;; ファイルの読み込み
(for-each
(lambda (name)
(with-input-from-file name
(lambda ()
(let loop ()
(let ((output (vm '() '() (compile (read)) '())))
(display output)
(newline)
(if (not (eof-object? output))
(loop)
#f))))))
(cdr (command-line)))
;;; 実行
(repl)