CommonLispアセンブラ上にスタック型言語(っぽいもの)
前回のCommonLispアセンブラを使って、アセンブラ上に簡単なスタック型言語(っぽいもの)を組み立てて、それを使ってフィボナッチ数を計算するプログラムを書くと、どのような感じになるかを試してみた。
cl-asmはバージョンを更新して0.0.2を使用*1。
0.0.1(前回)からの大きな変更点としては、ニモニック列をプログラムから操作しやすいように以下のような二つの機能を追加した。
;; 例示用のプログラム (cl-asm:execute '((:push %rbp) (:mov %rbp %rsp) (:push %rdi) (:push %rsi) (:push %rbx) ; 関数呼び出し時の定形処理 ;; 10 + 15 (:mov %eax 10) (:mov %ebx 15) (:add %eax %ebx) (:pop %rbx) (:pop %rsi) (:pop %rdi) (:pop %rbp) ; 関数から返る時の定形処理 :ret) (function int)) --> 25 ;;======================================================================= ;; 追加機能１: (:progn ...) ;; - 複数のニモニックを一つにまとめることが可能 ;; => 追加機能２(eval)と合わせることでニモニック内に任意の関数・変数を埋め込むことが可能 (cl-asm:execute '((:progn (:push %rbp) (:mov %rbp %rsp) (:push %rdi) (:push %rsi) (:push %rbx)) ; 関数呼び出し時の定形処理 ;; 10 + 15 (:progn (:mov %eax 10) (:mov %ebx 15) (:add %eax %ebx)) (:progn (:pop %rbx) (:pop %rsi) (:pop %rdi) (:pop %rbp)) ; 関数から返る時の定形処理 :ret) (function int)) --> 25 ;;======================================================================= ;; 追加機能２: eval ;; - 以下の二つ以外がニモニック列に表れた場合はevalを適用 ;; a: 組み込みの命令(car部がキーワードのリスト) ;; b: ラベル('&'で始まるシンボル) ;; 定形処理を関数にまとめる (defun save-registers () '(:progn (:push %rbp) (:mov %rbp %rsp) (:push %rdi) (:push %rsi) (:push %rbx))) (defun restore-registers () '(:progn (:pop %rbx) (:pop %rsi) (:pop %rdi) (:pop %rbp))) ;; 実行 (cl-asm:execute '((save-registers) ; レジスタ退避 ;; 10 + 15 (:mov %eax 10) (:mov %ebx 15) (:add %eax %ebx) (restore-registers) ; レジスタ復元 :ret) (function int)) --> 25
一応これで少しは、普通のlispプログラムっぽくアセンブリプログラムが書けるようになった。
スタック型言語
以下では、機能的に前々回とほぼ同等のスタック型言語(っぽいもの)をアセンブラ上に作っていく。
まずはデータスタック周りの補助関数を用意。(リターンスタックにはx86の通常のスタックを使用)
;; データスタック用の領域をヒープに確保 & 解放 ;; - スタックサイズは決め打ち ;; - スタックの先頭アドレスの保持にはRCXレジスタを使用 ;; (ちなみにRAX/RBXレジスタは、一時データ保持用に使用) ;; 確保 (defun ready-data-stack () '(:progn (:push %rax) (:push %rdi) ; レジスタ退避 (:mov %edi 102400) ; スタックサイズ (:mov %rax (:extern "malloc")) (:call %rax) ; malloc(102400) (:mov %rcx %rax) ; アドレスをRCXレジスタに保存 (:pop %rdi) (:pop %rax))) ; レジスタ復元 ;; 解放 (defun destroy-data-stack () '(:progn (:push %rax) (:push %rdi) ; レジスタ退避 (:mov %rdi %rcx) (:mov %rax (:extern "free")) (:call %rax) ; free(RCX) (:pop %rdi) (:pop %rax))) ; レジスタ復元 ;; アセンブラ用関数(マクロ)定義マクロ ;; これを使えば引数のシンボルのクォートが不要となり、使用時に(xxx '%eax)ではなく(xxx %eax)のように書ける (defmacro defop (name args &body body) `(defmacro ,name ,args (list 'quote (locally ,@body)))) ;; データスタック用のアクセサ定義 (defop @ds-get (dst index) `(:mov ,dst (:refd %rcx ,(* index -4)))) ; getter (defop @ds-set (index src) `(:mov (:refd %rcx ,(* index -4)) ,src)) ; setter (defop @ds-inc (&optional (n 1)) `(:add %rcx ,(* 4 n))) ; 先頭を進める (defop @ds-dec (&optional (n 1)) `(:sub %rcx ,(* 4 n))) ; 先頭を戻す ;; ついでに全ての定期処理をまとめて生成してくれるマクロを用意 (defmacro body (&rest mnemonics) `'(,(save-registers) ; レジスタ退避 ,(ready-data-stack) ; データスタック用意 ,@mnemonics ; 本体処理 ,(destroy-data-stack) ; データスタック破棄 ,(restore-registers) ; レジスタ復元 :ret)) (cl-asm:execute (body (:mov %eax 10)) (function int)) --> 10
残りはひたすらスタック型言語用の命令(関数)を定義。
;; srcをスタックの先頭に追加 (defop @push (src) `(:progn (@ds-inc) (@ds-set 0 ,src))) ;; スタックの先頭を取り出しdstに格納 (defop @pop (dst) `(:progn (@ds-get ,dst 0) (@ds-dec))) ;; スタックの先頭から二つを要素を取り出し、dst1とdst2に格納 (defop @pop2 (dst1 dst2) `(:progn (@ds-get ,dst1 0) (@ds-get ,dst2 1) (@ds-dec 2))) ;; スタック[index1]とスタック[index2]の要素を交換 (defop @swap-impl (index1 index2) `(:progn (@ds-get %eax ,index1) (@ds-get %ebx ,index2) (@ds-set ,index1 %ebx) (@ds-set ,index2 %eax))) ;; スタックの先頭二つの要素を交換 (defop @swap () '(@swap-impl 0 1)) ;; スタックの先頭要素を複製 (defop @dup () `(:progn (@ds-get %eax 0) (@push %eax))) ;; スタックの先頭要素の破棄 (defop @drop () '(@ds-dec)) ;; スタックの二番目の要素を先頭に複製 (defop @over () `(:progn (@ds-get %eax 1) (@push %eax))) ;; スタックの先頭三つの要素をローテーション (defop @rot () `(:progn (@swap-impl 2 0) (@swap-impl 1 2))) ;; スタックの先頭二つを使った加算 (defop @add () `(:progn (@pop2 %ebx %eax) (:add %eax %ebx) (@push %eax))) ;; スタックの先頭二つを使った減算 (defop @sub () `(:progn (@pop2 %ebx %eax) (:sub %eax %ebx) (@push %eax))) ;; スタックの先頭二つの要素が等しいか (真なら非ゼロがスタックトップに格納) (defop @eql () `(:progn (@pop2 %ebx %eax) (:cmp %eax %ebx) (:mov %eax 0) (:sete %al) (@push %eax))) ;; スタックの先頭要素が二番目の要素よりも小さいか (真なら非ゼロがスタックトップに格納) (defop @less () `(:progn (@pop2 %ebx %eax) (:cmp %eax %ebx) (:mov %eax 0) (:setl %al) (@push %eax))) ;; スタックの先頭が真(非ゼロ)なら、指定位置に遷移 (defop @jump-if (pos) `(:progn (@pop %eax) (:cmp %eax 0) (:jne ,pos))) ;; 指定位置に遷移 (defop @jump (pos) `(:jmp ,pos)) ;; 関数呼び出し (defop @call (pos) `(:call ,pos)) ;; 関数からの復帰 (defop @return () :ret) ;; int値を生成してスタックトップに積む (defop @int (n) `(@push ,n))
実行例。
(cl-asm:execute (body (@push 10) (@push 15) (@add) (@pop %eax)) ; 結果取り出し (function int)) --> 25
フィボナッチ数
フィボナッチ数計算プログラム。
薄いラップの割にはスタック型言語っぽい見た目になっているように思う。
(cl-asm:execute (body (@push %edi) ; 引数取得 (@call &fib-beg) ; (fib 10) (@jump &finish) &fib-beg (@dup) (@int 2) (@less) (@jump-if &fib-end) ; (if (< arg 2) ... ....) (@dup) (@int 2) (@sub) (@call &fib-beg) ; a = (fib (- arg 2)) (@swap) (@int 1) (@sub) (@call &fib-beg) ; b = (fib (- arg 1)) (@add) ; (+ a b) &fib-end (@return) &finish (@pop %eax)) (function int int) 10) --> 55
*1:いずれにせよ、まだまだ実用に堪えるものにはかなりほど遠いけど
アセンブリ言語でフィボナッチ数
前回は、C++で単純なVMを書いて、その上でのフィボナッチ数の計算時間を測定した。
そのVM部分をネイティブコードに置き換えたら、どの程度処理速度が改善するのかを測ってみたかったので、その前にまずネイティブコード(x86)の勉強も兼ねて、common lispでアセンブラを書くことにした。
現状はまだまだ未完成で、以下のような制限があるが、一応フィボナッチ数が計算できるくらいまでには出来たので、その計算時間を参考までに残しておく。
制限:
- 使用可能な命令は mov/ret/push/pop/add/sub/inc/dec/cmp/jmp/jcc/call のみ
- 64bitのみ対応
- エラーチェックとか不十分
- SBCLのみで動作
コード
フィボナッチ数計算用のコード。
(use-package :sb-alien) ;; Fibonacci用のアセンブリコード (defparameter *fib* '((:push %rbp) (:mov %rbp %rsp) (:push %rdi) (:push %rsi) (:push %rbx) ; 関数呼び出し時の定形処理 (:mov %eax %edi) ; 引数取得 (:call &fib-beg) (:pop %rbx) (:pop %rsi) (:pop %rdi) (:pop %rbp) ; 関数から返る時の定形処理 :ret &fib-beg (:cmp %eax 2) ; arg < 2 (:jl &fib-end) (:push %rax) (:sub %eax 2) (:call &fib-beg) ; x = (fib (- arg 2)) (:pop %rbx) (:push %rax) (:mov %eax %ebx) (:dec %eax) (:call &fib-beg) ; y = (fib (- arg 1)) (:pop %rbx) (:add %eax %ebx) ; (+ x y) &fib-end :ret)) --> *FIB* ;; 生成されるマシン語 (cl-asm:assemble *fib*) --> (85 72 137 229 87 86 83 137 248 232 5 0 0 0 91 94 95 93 195 131 248 2 124 23 80 131 232 2 232 242 255 255 255 91 80 137 216 255 200 232 231 255 255 255 91 1 216 195) ;; 実行 (time (cl-asm:execute *fib* (function int int) ; 関数の型 35) ; 引数: (fib 35) Evaluation took: 0.059 seconds of real time 0.060003 seconds of total run time (0.060003 user, 0.000000 system) 101.69% CPU 117,246,804 processor cycles 32,624 bytes consed --> 9227465
簡易スタック型VM(バイトコードインタプリタ)でのフィボナッチ数計算速度
今年はlisp系のプログラミング言語(及びその処理系)を作ってみようと考えていて、かつ(少なくとも)当面の間はスタック型VMを基盤として実装していくことになると思われるので、まずは単純なスタックマシンのバイトコードインタプリタで、どの程度の処理速度がでるのかを計測してみた。
命令一覧と実行サンプル
現状のVMが備える命令一覧*1。必要最小限。
下記、命令セットに関してはForthを少し参考にしている。スタックマシンの動作の詳細に関しては、特に特殊な点もないので説明は割愛。
| 命令 | コード値 | in-stack | out-stack | 意味 |
|---|---|---|---|---|
| int | 1 | n | バイトコード中の後続の四バイト(little-endian)を取り出し、int値を生成 | |
| add | 2 | n1 n2 | n3 | n1 + n2 |
| sub | 3 | n1 n2 | n3 | n1 - n2 |
| mul | 4 | n1 n2 | n3 | n1 * n2 |
| div | 5 | n1 n2 | n3 | n1 / n2 |
| mod | 6 | n1 n2 | n3 | n1 % n2 |
| eql | 7 | n1 n2 | b(1 or 0) | n1 == n2 |
| less | 8 | n1 n2 | b | n1 < n2 |
| dup | 9 | x | x x | スタックの先頭要素を複製 |
| drop | 10 | x | スタックの先頭要素を破棄 | |
| swap | 11 | x1 x2 | x2 x1 | スタックの先頭二つの要素を入れ替え |
| over | 12 | x1 x2 | x1 x2 x1 | スタックの二番目の要素を先頭に複製 |
| rot | 13 | x1 x2 x3 | x2 x3 x1 | スタックの先頭三つの要素をローテーション |
| rpush | 14 | x | スタック(データスタック)の先頭要素をリターンスタックの先頭に移す | |
| rpop | 15 | x | リターンスタックの先頭要素をスタックに移す | |
| rcopy | 16 | x | リターンスタックの先頭要素をスタックに複製 | |
| jump | 17 | n | 無条件分岐。nは分岐先のアドレス | |
| jump_if | 18 | b n | 条件分岐。bが新(非ゼロ)なら分岐する | |
| call | 19 | n | 関数呼び出し。リターンスタックにプログラムカウンタを保存後、無条件分岐 | |
| return | 20 | 関数からの復帰。リターンスタックからプログラムカウンタを取り出し、そこへ無条件分岐 |
末尾にソースコード全体を載せるが、バイトコードインタプリタの実行部は、バイトコードから上記命令に対応するコード値を取得し、命令を実行する、ということをひたすら繰り返すという単純なもの。
// C++ typedef unsigned char octet; /** * バイトコード実行用のクラス */ class executor { public: void execute(const char* filepath) { bytecode_stream in(filepath); // バイトコードストリームの終端に達するまでループ while(in.eos() == false) { octet opcode = in.read_octet(); // 命令コード読み出し op::call(opcode, in, env); // コードに対応する処理を実行 (envにはデータスタックとリターンスタックが保持されている) } } }; class op { public: // コードに対応する命令を実行 static void call(octet opcode, bytecode_stream& in, environment& env) { switch(opcode) { case 1: op_int(in, env); break; // int値構築 case 2: op_add(in, env); break; // + case 3: op_sub(in, env); break; // - case 4: op_mul(in, env); break; // * case 5: op_div(in, env); break; // / case 6: op_mod(in, env); break; // % case 7: op_eql(in, env); break; // == ... 省略 ... default: assert(false); } } }
VM部はC++で記述しているが、VMが解釈可能なバイトコード列を生成するためのアセンブラ(コンパイラ)はcommon lispで作成。
;; common lisp ;; 実行例 (load "pvm-compile") ;; 加算を行うバイトコード列を'add.bc'ファイルに出力する ;; - キーワードは命令を表す (pvmc:compile-to-file "add.bc" '(10 20 :add)) ; 10 + 20 ;; 条件分岐を行うバイトコード列を'jump.bc'ファイルに出力する ;; ;; シンボルはアドレス参照用のラベルを表す ;; (:addr シンボル)形式で参照可能 ;; ※ アドレスはコンパイル時に解決される (pvmc:compile-to-file "jump.bc" '(10 10 :eql ; n1 == n2 ? (:addr then) :jump-if ; 等しいなら then に移動 else 1 2 ; else: スタックに 1と2 を積む (:addr end) :jump then 3 4 ; then: スタックに 3と4 を積む end)) ;; 上の例では以下のようなバイト列が生成される (pvmc::compile-to-bytecodes '(10 10 :eql (:addr then) :jump-if else 1 2 (:addr end) :jump then 3 4 end)) => #(1 10 0 0 0 1 10 0 0 0 7 1 33 0 0 0 18 1 1 0 0 0 1 2 0 0 0 1 43 0 0 0 17 1 3 0 0 0 1 4 0 0 0)
生成したバイトコードはpvmコマンドで実行可能。
# pvmコマンド作成 $ g++ -O2 -o pvm pvm.cc # add.bc $ ./pvm add.bc [data stack] # 実行後のデータスタックとリターンスタックの中身が出力される 0# 30 # 10 + 20 [return stack] # jump.bc $ ./pvm jump.bc [data stack] 0# 4 # then部が実行された 1# 3 [return stack]
実行速度
上のVM上でのフィボナッチ数の計算に要した時間。
以下は35のフィボナッチ数計算用のコード。
(pvmc:compile-to-file "fib.bc" '( 35 ; fib(35) (:addr fib-beg) :call ; fib(25) (:addr finish) :jump fib-beg :dup 2 :less (:addr fib-end) :jump-if ; if(n < 2) :dup 2 :sub (:addr fib-beg) :call ; fib(n - 2) :swap 1 :sub (:addr fib-beg) :call ; fib(n - 1) :add fib-end :return finish)) #| 実行結果: $ time ./pvm fib.bc [data stack] 0# 9227465 [return stack] real 0m3.605s user 0m3.600s sys 0m0.000s |#
他言語との比較。
| 言語 | 所要時間(最適化オプションなし) | 所要時間(最適化オプションあり) |
|---|---|---|
| gcc-4.6.1 | 0.112s | 0.056s |
| sbcl-1.0.54 | 0.320s | 0.110s |
| pvm | 3.600s | |
| ruby1.9.1 | 2.816s | |
| ruby1.8.7 | 14.497s |
現状は本当に単純なインタプリタなので仕方がないとはいえ、Ruby(1.9)よりも遅い・・・。
ちなみに各言語用のソースコードは以下の通り。
// C++ // ファイル名: fib.cc // コンパイル: g++ -O2 -o fib fib.cc // 実行: time fib 35 #include <iostream> #include <cstdlib> int fib(int n) { if(n < 2) { return n; } return fib(n-2) + fib(n-1); } int main(int argc, char** argv) { std::cout << fib(atoi(argv[1])) << std::endl; return 0; }
;; sbcl (defun fib (n) (declare (optimize (speed 3) (safety 0) (debug 0)) (fixnum n)) (if (< n 2) n (the fixnum (+ (fib (- n 2)) (fib (- n 1)))))) ;; 実行 (time (fib 35))
# ruby # ファイル名: fib.rb # 実行: time fib.rb 35 def fib (n) return n if n < 2 fib(n-2) + fib(n-1) end p fib(ARGV[0].to_i)
ソースコード
VM及びコンパイラ用のソースコード。
それぞれ180行、80行程度。
// ファイル名: pvm.hh /** * バイトコードインタプリタ */ #ifndef PVM_HH #define PVM_HH #include <iostream> #include <fstream> #include <cassert> #include <vector> #include <algorithm> namespace pvm { typedef unsigned char octet; typedef std::vector<int> stack_t; /** * バイトコード読み込みストリーム */ class bytecode_stream { public: bytecode_stream(const char* filepath) : bytecodes(NULL), position(0) { std::ifstream in(filepath); assert(in); length = in.rdbuf()->in_avail(); bytecodes = new octet[length]; in.read((char*)bytecodes, length); } ~bytecode_stream() { delete [] bytecodes; } bool eos() const { return position >= length; } octet read_octet () { return bytecodes[position++]; } // sizeof(int) == 4 と仮定 int read_int() { int n = *(int*)(bytecodes + position); position += 4; return n; } // program counter unsigned pc() const { return position; } unsigned& pc() { return position; } private: octet* bytecodes; unsigned length; unsigned position; }; /** * データスタックとリターンスタック */ class environment { public: stack_t& dstack() { return data_stack; } stack_t& rstack() { return return_stack; } const stack_t& dstack() const { return data_stack; } const stack_t& rstack() const { return return_stack; } private: stack_t data_stack; stack_t return_stack; }; /** * 各種操作(命令) */ class op { public: static void call(octet opcode, bytecode_stream& in, environment& env) { switch(opcode) { case 1: op_int(in, env); break; // int値構築 case 2: op_add(in, env); break; // + case 3: op_sub(in, env); break; // - case 4: op_mul(in, env); break; // * case 5: op_div(in, env); break; // / case 6: op_mod(in, env); break; // % case 7: op_eql(in, env); break; // == case 8: op_less(in, env); break;// < case 9: op_dup(in, env); break; // データスタックの先頭要素を複製 case 10: op_drop(in, env); break; // データスタックの先頭要素を破棄 case 11: op_swap(in, env); break; // データスタックの最初の二つの要素を入れ替え case 12: op_over(in, env); break; // データスタックの二番目の要素を先頭にコピーする case 13: op_rot(in, env); break; // データスタックの先頭三つの要素をローテーションする case 14: op_rpush(in, env); break; // データスタックの先頭要素を取り出しリターンスタックに追加する case 15: op_rpop(in, env); break; // リターンスタックの先頭要素を取り出しデータスタックに追加する case 16: op_rcopy(in, env); break; // リターンスタックの先頭要素をデータすタックに追加する case 17: op_jump(in, env); break; // 無条件分岐 case 18: op_jump_if(in, env); break; // 条件分岐 case 19: op_call(in, env); break; // 関数呼び出し case 20: op_return(in, env); break; // 関数から復帰 default: assert(false); } } private: typedef bytecode_stream bcs; typedef environment env; #define DPUSH(x) e.dstack().push_back(x) #define DPOP pop_back(e.dstack()) #define DNTH(nth) e.dstack()[e.dstack().size()-1-nth] #define RPUSH(x) e.rstack().push_back(x) #define RPOP pop_back(e.rstack()) #define RNTH(nth) e.rstack()[e.rstack().size()-1-nth] static void op_int(bcs& in, env& e) { DPUSH(in.read_int()); } static void op_add(bcs& in, env& e) { DPUSH(DPOP + DPOP); } static void op_sub(bcs& in, env& e) { int n = DPOP; DPUSH(DPOP - n); } static void op_mul(bcs& in, env& e) { DPUSH(DPOP * DPOP); } static void op_div(bcs& in, env& e) { int n = DPOP; DPUSH(DPOP / n); } static void op_mod(bcs& in, env& e) { int n = DPOP; DPUSH(DPOP % n); } static void op_eql(bcs& in, env& e) { DPUSH(DPOP == DPOP); } static void op_less(bcs& in, env& e) { DPUSH(DPOP > DPOP); } static void op_dup(bcs& in, env& e) { DPUSH(DNTH(0)); } static void op_drop(bcs& in, env& e) { DPOP; } static void op_swap(bcs& in, env& e) { std::swap(DNTH(0), DNTH(1)); } static void op_over(bcs& in, env& e) { DPUSH(DNTH(1)); } static void op_rot(bcs& in, env& e) { std::swap(DNTH(2), DNTH(0)); std::swap(DNTH(1), DNTH(2)); } static void op_rpush(bcs& in, env& e) { RPUSH(DPOP); } static void op_rpop(bcs& in, env& e) { DPUSH(RPOP); } static void op_rcopy(bcs& in, env& e) { DPUSH(RNTH(0)); } static void op_jump(bcs& in, env& e) { in.pc() = DPOP;} static void op_jump_if(bcs& in, env& e) { int p = DPOP; if(DPOP){ in.pc() = p;} } static void op_call(bcs& in, env& e) { RPUSH(in.pc()); in.pc() = DPOP; } static void op_return(bcs& in, env& e) { in.pc() = RPOP; } #undef DPUSH #undef DPOP #undef DNTH #undef RPUSH #undef RPOP #undef RNTH private: static int pop_back(stack_t& stack) { int x = stack.back(); stack.pop_back(); return x; } }; /** * バイトコード実行 */ class executor { public: void execute(const char* filepath) { bytecode_stream in(filepath); while(in.eos() == false) { octet opcode = in.read_octet(); op::call(opcode, in, env); } } const environment& get_env() const { return env; } private: environment env; }; } #endif
// ファイル名: pvm.cc // バイトコード実行用コマンド #include "pvm.hh" #include <iostream> void show(const char* name, const pvm::stack_t& stack) { std::cout << "[" << name << "]" << std::endl; for(int i = stack.size()-1; i >= 0; i--) { std::cout << " " << (stack.size()-1-i) << "# " << stack[i] << std::endl; } std::cout << std::endl; } int main(int argc, char** argv) { if(argc != 2) { std::cerr << "Usage: pvm BYTECODE_FILEPATH" << std::endl; return 1; } pvm::executor vm; vm.execute(argv[1]); const pvm::environment& rlt = vm.get_env(); show("data stack", rlt.dstack()); show("return stack", rlt.rstack()); return 0; }
;;; ファイル名: pvm-compile.lisp ;;; S式をVM用のバイトコードにコンパイル(アセンブル)する (defpackage pvm-compile (:use :common-lisp) (:nicknames :pvmc) (:export compile-to-file)) (in-package :pvm-compile) ;; 利用可能な操作(命令)のリスト (defparameter *op-list* '((1 :int) (2 :add) (3 :sub) (4 :mul) (5 :div) (6 :mod) (7 :eql) (8 :less) (9 :dup) (10 :drop) (11 :swap) (12 :over) (13 :rot) (14 :rpush) (15 :rpop) (16 :rcopy) (17 :jump) (18 :jump-if) (19 :call) (20 :return))) ;; 数値をリトルエンディアンのバイト列に変換する ;; n -> '(b1 b2 b3 b4) (defun int-to-bytes (n) (loop FOR i FROM 0 BELOW 4 COLLECT (ldb (byte 8 (* i 8)) n))) ;; 操作名に対するコード値を取得する (defun opcode (op) (assert #1=(find op *op-list* :key #'second)) (first #1#)) ;; コンパイル (defun compile-to-bytecodes (codes) (loop WITH unresolves = '() ; 未解決のアドレス参照 WITH labels = '() ; ラベルとアドレスのマッピング FOR code IN codes FOR pos = (length tmps) APPEND (etypecase code (integer `(,(opcode :int) ,@(int-to-bytes code))) ; 整数値構築 (keyword (list (opcode code))) ; 一般的な操作 (symbol (push `(,code ,pos) labels) ; アドレス(PC)参照用のラベル '()) (cons (ecase (first code) ; アドレス参照 (:addr (push `(,(second code) ,(1+ pos)) unresolves) `(,(opcode :int) 0 0 0 0))))) ; この時点では実際のアドレスが不明なので 0 を設定しておく INTO tmps FINALLY (let ((bytecodes (coerce tmps 'vector))) ;; アドレス解決 (loop FOR (label offset) IN unresolves FOR label-addr = (second (assoc label labels)) DO (setf (subseq bytecodes offset (+ offset 4)) (int-to-bytes label-addr))) (return bytecodes)))) ;; コンパイルして結果をファイルに出力する (defun compile-to-file (filepath assembly-codes) (let ((bytecodes (compile-to-bytecodes assembly-codes))) (with-open-file (out filepath :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (write-sequence bytecodes out))) t)
*1:大別すると整数処理系、データスタック操作系、リターンスタック操作系、分岐系の四つ
fletとlabels
CommonLispのfletとlabels的なものを(あらかじめ使えるものはlambdaしかない状況で)自分で実装する必要が出てきたので、その際のメモ。
なお、以下では煩雑になるためfuncall呼び出しの記述を省略している(実際にはScheme処理系で動作確認を行っていた)。
let
flet、labelsの前にまずはlambdaを使ったletの実現方法を考える。
;; 以下のように変換可能 (let ((a 10) (b 20) (c 30)) (list a b c)) ↓ ((lambda (a b c) (list a b c)) 10 20 30)) ; => (10 20 30)
flet
上のようにしてletが使えると仮定した場合、fletと同じ機能を実現するのは簡単。
;; 単に変数に(lambda ...)を束縛すれば良い (let ((hello (lambda (x) (list 'hello x)))) (hello 'world)) ; => (HELLO WORLD)
labels
これがlabels(ローカル関数の再帰呼び出しが可能)になると少し難しくなる。
以下、fletと同様の方法で試した場合。
;; フィボナッチ数を計算 (let ((fib (lambda (n) (if (< n 2) n ;; fibの再帰呼び出し (+ (fib (- n 2)) (fib (- n 1))))))) (fib 10)) ; => ERROR: 再帰呼び出し部分でfib関数が見つからないと云われる
fib変数に束縛したlambdaの本体のコンテキストからは、fib変数が見つからないため、エラーとなる。
再帰呼び出しに使用するfib関数を明示的に引数を渡すようにすれば、問題は解決する。
(let ((fib (lambda (n fib) ; 第二引数に常にfib関数を渡すようにする (if (< n 2) n (+ (fib (- n 2) fib) (fib (- n 1) fib)))))) (fib 10 fib)) ; => 55
ただ、上の方法の引数の形が変わってしまうのが難点。
若干複雑にはなるが、以下のようにクロージャを使って再帰関数を持ち回すようにすれば、引数及び本体の形はほぼ変わらないので、マクロなどで生成するのは楽になる(ように思う)。
(let ((fib-rec (lambda (fib-rec) ; 再帰関数を引数に渡す (lambda (n) (let ((fib (fib-rec fib-rec))) ; 再帰関数の情報を埋め込んだfib関数を返す (if (< n 2) n (+ (fib (- n 2)) (fib (- n 1))))))))) (let ((fib (fib-rec fib-rec))) ; 再帰関数の情報を埋め込んだfib関数を返す (fib 10))) ; => 55
これでローカル関数の再帰呼び出しはできるようになったのでは、マクロを使ってシンタックスを整えれば、labelsが実現できることになる。
- -
以前に、何でCommonLispにはfletとlabelsの二つがあるのか、とかOcamlでletとlet recが分かれているか、とか少し疑問に思ったことがあったように思うけど、少し理由が分かった気がする。
マインスイーパー
端末上で動作するマインスイーパーをCommonLisp(SBCL)で実装してみた。
github: cl-mine-0.0.2
端末操作
端末操作部分のソースコードは以下のような感じ。
基本的には端末のエスケープシーケンスで(カーソル移動や画面クリア、文字色等の)制御を行っている。
ただ、キー入力をリアルタイムで取得可能にするのはエスケープシーケンスでは無理そうだったので、その部分はtcsetattr等のシステムコール(?)を使用している。
(defpackage console (:use :common-lisp :sb-alien) (:shadow :common-lisp format) (:export with-raw-mode clear move set-pos format newline formatln style)) (in-package :console) ;;; types ;;; (deftype direction () '(member :up :down :left :right)) ; カーソル移動の方向 (deftype color () '(member :black :red :green :yellow :blue :magenta :cyan :white :normal)) ; 文字色、背景色 ;;; constants ;;; (defparameter +ESC+ (common-lisp:format nil "~c[" (code-char #8r33))) ; エスケープシーケンスの開始文字列 (defparameter +STDIN_FD+ (sb-sys:fd-stream-fd sb-sys:*stdin*)) ; 標準入力のファイルディスクリプタ ;;; internal functions ;;; ;; 文字色のコード値を取得 (defun color-code (color) (declare (color color)) (ecase color (:black 30) (:red 31) (:green 32) (:yellow 33) (:blue 34) (:magenta 35) (:cyan 36) (:white 37) (:normal 39))) ;; cfmakeraw関数(キー入力リアルタイム取得用)はsb-posixパッケージに存在しないようなので読み込む (define-alien-routine ("cfmakeraw" %cfmakeraw) void (termios* (* t))) (defun cfmakeraw () (let ((termios (sb-posix::allocate-alien-termios))) (%cfmakeraw termios) (unwind-protect (sb-posix::alien-to-termios termios) (sb-posix::free-alien-termios termios)))) ;;; exported functions ;;; ;; 標準のformat関数の薄いラッパー (defmacro format (control-string &rest format-arguments) `(progn (common-lisp:format t ,control-string ,@format-arguments) (force-output))) ;; 改行付きのformat関数 (defmacro formatln (control-string &rest format-arguments) `(progn (format ,control-string ,@format-arguments) (newline))) ;; 改行: tcsetattr関数にcfmakerawの戻り値を渡した場合(rawモード?)、改行には #\Newlineと#\Return の両方が必要 (defun newline () (format "~c~c" #\Newline #\Return)) ;; 文字色、背景色、太字、下線、文字色背景色反転、等を指定した文字列を返す (defun style (x &key (color :normal) (bgcolor :normal) bold inverse underline) (declare (color color bgcolor)) (common-lisp:format nil "~a~{~d;~}~d;~dm~a~a0m" +ESC+ (remove nil (list (and bold 1) (and underline 4) (and inverse 7))) (color-code color) (+ (color-code bgcolor) 10) x +ESC+)) ;; 上下左右へのカーソル移動 (defun move (direction &optional (delta 1)) (declare (direction direction)) (when (plusp delta) (format "~a~d~a" +ESC+ delta (ecase direction (:up "A") (:down "B") (:left "D") (:right "C"))))) ;; 画面クリア。lineがtの場合はカーソル行のみをクリア。 (defun clear (&key line) (if line (format "~a2K" +ESC+) (format "~a2J" +ESC+))) ;; 任意の位置へのカーソル移動 (defun set-pos (x y) (format "~a~d;~dH" +ESC+ y x)) ;; 端末をrawモード(?)に切り替えてbodyを評価する (defmacro with-raw-mode (&body body) (let ((old (gensym))) `(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) (let ((,old (sb-posix:tcgetattr +STDIN_FD+))) (unwind-protect (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) (sb-posix:tcsetattr +STDIN_FD+ sb-posix:tcsadrain (cfmakeraw)) ,@body) (sb-posix:tcsetattr +STDIN_FD+ sb-posix:tcsanow ,old))))))
例えば、端末内をカーソル移動できるようにする場合は、以下のようなコードとなる。
;; 'e': ↑ ;; 'd': ↓ ;; 's': ← ;; 'f': → ;; 'c': exit (console:with-raw-mode (loop (case (read-char) (#\e (console:move :up)) (#\d (console:move :down)) (#\s (console:move :left)) (#\f (console:move :right)) (#\c (return)))))
簡単なUIならこれで十分かもしれない。
N-Queen: 高速化
こちらの記事に刺激を受けて、以前に実装したN-Queenを高速化してみた(Common Lisp版のみ)。
(defvar *fastest* '(optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (deftype max-board-size () '(mod #x100)) (declaim (inline check)) ; inline宣言を追加 (defun check (row queens &optional (r 1) &aux (q (car queens))) (declare #.*fastest* (max-board-size r row q)) (or (null queens) (and (/= q (+ row r) (- row r)) (check row (cdr queens) (1+ r))))) ;; dolistの亜種 ;; - リストの走査時に各要素を変数に束縛するのと同時に、走査中の要素を除いたリストも変数に束縛する ;; ※ 先頭要素は走査対象外 (defmacro dolist2 ((x but-x list) &body body) (multiple-value-bind (recur prev cur next) (values #1=(gensym) #1# #1# #1#) `(let ((,but-x ,list)) (labels ((,recur (,prev &aux (,cur (cdr ,prev))) (when ,cur (destructuring-bind (,x . ,next) ,cur (setf (cdr ,prev) ,next) (locally ,@body) (setf (cdr ,prev) ,cur) (,recur ,cur))))) (,recur ,but-x))))) #| ex: > (dolist2 (x but-x '(:head 1 2 3 a b c)) (print `(:x ,x :but-x ,but-x))) (:X 1 :BUT-X (:HEAD 2 3 A B C)) (:X 2 :BUT-X (:HEAD 1 3 A B C)) (:X 3 :BUT-X (:HEAD 1 2 A B C)) (:X A :BUT-X (:HEAD 1 2 3 B C)) (:X B :BUT-X (:HEAD 1 2 3 A C)) (:X C :BUT-X (:HEAD 1 2 3 A B)) --> NIL |# (defun n-queen (n) (declare #.*fastest* (max-board-size n)) (nlet-acc self (queens (rows (cons :head (loop FOR i FROM 0 BELOW n COLLECT i)))) (if (null (cdr rows)) ; rows == '(:head) (accumulate queens) (dolist2 (row rest-rows rows) (when (check row queens) (self (cons row queens) rest-rows))))))
erl-creole: ユニコード文字列とマルチバイト列の変換ライブラリ
少し必要になったのでErlangでユニコード文字列と各種エンコーディングのマルチバイト列(バイナリ)の相互変換を行うモジュールを作成した。
github: erl-creole-0.0.1
- UTF-8, Shift_JIS, CP932, EUC-JP, eucJP-ms, JIS(ISO-2022-JP), ISO-2022-JP-1
使用例
%% 入力文字列 > S = "Unicode (ユニコード) とは、世界中の多くのコンピュータ上の文字列を一貫した方法で符号化し、表現し、扱うためのコンピュータ業界の標準である。". %% EUC-JPに変換 > creole:from_string(S, eucjp). <<"Unicode (\æ\Ë\³¡¼\É) ¤È¤Ï¡¢À¤³釗Ãæ¤Î¿¤¯¤Î\³\ó\Ô\塼\¿¾å¤Îʸ»úÎó¤ò°ì´Ó¤·¤¿ÊýË¡¤ÇÉä¹æ²½¤·¡¢É½¸½¤·¡¢°·¤釗¤¿¤á¤Î\³\ó\Ô\å¡"...>> %% JIS(ISO-2022-JP)に変換 > Bin = creole:from_string(S, jis). <<"Unicode (\e$B%f%K%3!<%I\e(B) \e$B$H$O!\"@$3&Cf$NB?$/$N%3%s%T%e!<%?>e$NJ8;zNs$r0l4S$7$?J}K!$GId9f2=$7!\"I=8=$7!\"07$&$?$a$N"...>> %% バイト列からユニコード文字列に変換 > creole:to_string(Bin, jis). [85,110,105,99,111,100,101,32,40,12518,12491,12467,12540, 12489,41,32,12392,12399,12289,19990,30028,20013,12398,22810, 12367,12398,12467,12531,12500|...] > io:format("~ts~n", [creole:to_string(Bin, jis)]). Unicode (ユニコード) とは、世界中の多くのコンピュータ上の文字列を一貫した方法で符号化し、表現し、扱うためのコンピュータ業界の標準である。 ok %% 変換不能なバイト列がある場合は、デフォルトでは "?" が代わりに使用される > io:format("~ts~n", [creole:to_string(<<"Unicode (\e$B%~^s^sjaf*(asf7aK%3!<%I">>, jis)]). Unicode (??潁潁裃罟?癈羞疔コード ok %% "?"の代わりに"_"を使用 > io:format("~ts~n", [creole:to_string(<<"Unicode (\e$B%~^s^sjaf*(asf7aK%3!<%I">>, jis, creole:replace($_))]). Unicode (__潁潁裃罟_癈羞疔コード ok
*1:ユニコードと他のエンコーディングのコードポイントの対応は主に http://source.icu-project.org/repos/icu/data/trunk/charset/data/ucm/ を参考にさせてもらった。
