Toy VM (14) - SECD マシン

ようやく少しまとまったので github に置いておきます。
LispMe の SECD マシンを、勉強のため Common Lisp で実装したものです。ただし現時点では LispMe の一部しか実装されていません。R5RS 準拠などはほど遠い状態です。

主要な関数/マクロは以下です。

• secd.asd : ASDF ファイル。
• package.lisp: パッケージ定義。
• match.lisp: SECD マシンの定義のために書かれたパターンマッチユーティリティ。
• compile.lisp : comp 関数 S-式を SECD マシンの命令にコンパイルする。
• interp.lisp : deftransition マクロ SECD マシンを定義するマクロ。
• interp.lisp : secd-eval 関数 S-式を SECD マシンで評価する。
• defsecd.lisp : secd マシンの定義。

分かったこと

• SECD マシンは、シンプルな状態遷移表だけで定義できる、ということ。
• （速度を気にしなければ）scheme コンパイラは難しくない、ということ。
• 「継続」は実装したら分かると思って実装したのですが、まだよく使い方が分かっていません。ただ、どこにも魔法的なものは無いということが分かりました。うまく表現できませんが、継続はかなり静的に動作が決まっている、とか。

この後

• R5RS を目指すのも正当だと思うのですが、 Common Lisp にべったりの、しかも遅い scheme コンパイラに存在価値があるか？というのは疑問。
• テストをもっと足して理解を確認する、というのもまっとうな方向。
• Common Lisp のコンスセルを使わず自分でメモリ管理を行う。
• Gauche の vm 。（とほほ、一年くらい掛かってまだたどり着いていない）

SECD マシン定義

(deftransition secd (s e c d)
  (:transitions
   ( s e (:NIL . c) d                            -> (nil . s) e c d )
   ( s e (:LD (m . n) . c) d                     -> (x . s) e c d where x = (locate m n e) )
   ( s e (:LDC x . c) d                          -> (x . s) e c d )
   ( s e (:LDF |c'| . c) d                       -> ((:clos |c'| . e) . s) e c d )
   ( ((:clos |c'| . |e'|) v . s) e (:AP . c) d   -> nil (v . |e'|) |c'| (s e c . d) )
   ( ((:cont s e c . d) (v) . |s'|) |e'| (:AP . |c'|) |d'| -> (v . s) e c d)
   ( ((:clos |c'| . |e'|) v . s) e (:TAP) d      -> s (v . |e'|) |c'| d )
   ( ((:cont s e c . d) (v) . |s'|) |e'| (:TAP) |d'| -> (v . s) e c d )
   ( (x . z) |e'| (:RTN . |c'|) (s e c . d)      -> (x . s) e c d )
   ( (x . s) e (:SEL cT cF . c) d                -> s e cX (c . d) where cX = (if x cT cF) )
   ( (x . s) e (:SELR cT cF) d                   -> s e cX d where cX = (if x cT cF) )
   ( s e (:JOIN . c) (cr . d)                    -> s e cr d )
   ( ((:clos |c'| . |e'|) v . s) (nil . e) (:RAP . c) d -> nil |e''| |c'| (s e c . d) where |e''| = (rplaca |e'| v))
   ( s e (:DUM . c) d                            -> s (nil . e) c d)
   ( s e (:LDCT |c'| . c) d                      -> ( ((:cont s e |c'| . d)) . s) e c d )
   ( (b a . s) e (:CONS . c) d                   -> ((b . a) . s) e c d )
   ( ((a . b) . s) e (:CAR . c) d                -> (a . s) e c d )
   ( ((a . b) . s) e (:CDR . c) d                -> (b . s) e c d )
   ( (x . s) e (:CONSP . c) d                    -> (p . s) e c d where p = (consp x) )
   ( ((:clos |c'| . |e'|) v . s) (nil . e) (:RTAP . c) d -> nil |e''| |c'| d where |e''| = (rplaca |e'| v))
   ( (x . s) e (:SET (m . n) . c) d              -> s |e'| c d where |e'| = (progn (setf (locate m n e) x) e))
   ( (a b . s) e (:+ . c) d                      -> (x . s) e c d where x = (+ a b) )
   ( (a b . s) e (:- . c) d                      -> (x . s) e c d where x = (- a b) )
   ( (a b . s) e (:* . c) d                      -> (x . s) e c d where x = (* a b) )
   ( (a b . s) e (:= . c) d                      -> (x . s) e c d where x = (= a b) )
   ( (a b . s) e (:> . c) d                      -> (x . s) e c d where x = (> a b) )
   ( (a b . s) e (:>= . c) d                     -> (x . s) e c d where x = (>= a b) )
   ( (a b . s) e (:< . c) d                      -> (x . s) e c d where x = (< a b) )
   ( (a b . s) e (:<= . c) d                     -> (x . s) e c d where x = (<= a b) )
   ( (a b . s) e (:mod . c) d                    -> (x . s) e c d where x = (mod a b) )
   ( (v . s) e (:VLEN . c) d                     -> (x . s) e c d where x = (length v))
   ( (l . s) e (:L2V . c) d                      -> (v . s) e c d where v = (make-vector l))
   ( (v n . s) e (:VREF . c) d                   -> (x . s) e c d where x = (aref v n))
   ( (v n x . s) e (:VSET . c) d                 -> (v . s) e c d where v = (progn (setf (aref v n) x) v))
   ( (x . s) e (:WRITE . c) d                    -> s e c d where dum = (format t ";; ~s~%" x) ))
  (:last-value
   (lambda (s e c d) (if (consp s) (car s)))))

            INITIAL STATE                                                  TRANSFORMED STATE
S                             E           C                   D                S                           E           C    D             

















































































































































































































































































-








































































































































s                             e           (nil . c)           d             -> (nil . s)                   e           c    d             
s                             e           (ld (m . n) . c)    d             -> (x . s)                     e           c    d             
                                                                               where x = (locate m n e)
s                             e           (ldc x . c)         d             -> (x . s)                     e           c    d             
s                             e           (ldf c' . c)        d             -> *1 . s)   e           c    d             
(b a . s)                     e           (cons . c)          d             -> ((b . a) . s)               e           c    d             
((a . b) . s)                 e           (car . c)           d             -> (a . s)                     e           c    d             
((a . b) . s)                 e           (cdr . c)           d             -> (b . s)                     e           c    d             
(x . s)                       e           (consp . c)         d             -> (p . s)                     e           c    d             
                                                                               where p = (consp x)
((clos c' . e') v . s)        (nil . e)   (rtap . c)          d             -> nil                         e''         c'   d             
                                                                               where e'' = (rplaca e' v)
(x . s)                       e           (set (m . n) . c)   d             -> s                           e'          c    d             
                                                                               where e' = (progn (setf (locate m n e) x) e)
(a b . s)                     e           (+ . c)             d             -> (x . s)                     e           c    d             
                                                                               where x = (+ a b)
(a b . s)                     e           (- . c)             d             -> (x . s)                     e           c    d             
                                                                               where x = (- a b)
(a b . s)                     e           (* . c)             d             -> (x . s)                     e           c    d             
                                                                               where x = (* a b)
(a b . s)                     e           (= . c)             d             -> (x . s)                     e           c    d             
                                                                               where x = (= a b)
(a b . s)                     e           (> . c)             d             -> (x . s)                     e           c    d             
                                                                               where x = (> a b)
(a b . s)                     e           (>= . c)            d             -> (x . s)                     e           c    d             
                                                                               where x = (>= a b)
(a b . s)                     e           (< . c)             d             -> (x . s)                     e           c    d             
                                                                               where x = (< a b)
(a b . s)                     e           (<= . c)            d             -> (x . s)                     e           c    d             
                                                                               where x = (<= a b)
(a b . s)                     e           (mod . c)           d             -> (x . s)                     e           c    d             
                                                                               where x = (mod a b)
(v . s)                       e           (vlen . c)          d             -> (x . s)                     e           c    d             
                                                                               where x = (length v)
(l . s)                       e           (l2v . c)           d             -> (v . s)                     e           c    d             
                                                                               where v = (make-vector l)
(v n . s)                     e           (vref . c)          d             -> (x . s)                     e           c    d             
                                                                               where x = (aref v n)
(v n x . s)                   e           (vset . c)          d             -> (v . s)                     e           c    d             
                                                                               where v = (progn (setf (aref v n) x) v)
(x . s)                       e           (write . c)         d             -> s                           e           c    d             
                                                                               where dum = (format t ;; ~s~% x)

















































































































































































































































































-

Github

http://github.com/cranebird/secd/

※ ユニットテストの部分で com.gigamonkeyes.test-system に依存しています。

*1:clos c' . e) . s) e c d ((clos c' . e') v . s) e (ap . c) d -> nil (v . e') c' (s e c . d) ((cont s e c . d) (v) . s') e' (ap . c') d' -> (v . s) e c d ((clos c' . e') v . s) e (tap) d -> s (v . e') c' d ((cont s e c . d) (v) . s') e' (tap) d' -> (v . s) e c d (x . z) e' (rtn . c') (s e c . d) -> (x . s) e c d (x . s) e (sel ct cf . c) d -> s e cx (c . d) where cx = (if x ct cf) (x . s) e (selr ct cf) d -> s e cx d where cx = (if x ct cf) s e (join . c) (cr . d) -> s e cr d ((clos c' . e') v . s) (nil . e) (rap . c) d -> nil e'' c' (s e c . d) where e'' = (rplaca e' v) s e (dum . c) d -> s (nil . e) c d s e (ldct c' . c) d -> (((cont s e c' . d