`(Hello ,world)

ツッコミ、添削大歓迎です。いろいろ教えてください。

2008-05-05

3impで任意個の引数に対応させたい

| 00:40

マクロは組み込んだ。だからいろいろやらせよう…と思ったけど、関数への引数が定義した数でしか受け取れないので、let のボディとか cond とかが作れない。これは辛い。なので任意個の引数を受け取れるようにする。

引数を rib に積んでくときに呼び出し側で対処できればいいんだけど、まだ定義されてない関数があったりするとまずいので、呼び出された側で対処することに。

lambda のコンパイルのときに引数リストにドットペアがあるかどうか調べて、あったらその位置と、実行時の環境の lookup 時に普通にインデクスが取れるようにドットペアから普通のリストに直して作った環境で lambda 式の本体をコンパイルする:

(define compile
  (lambda (x e next)
     ...
               (record-case x
                            ...
                            (lambda (vars)
                              (let ((body (cddr x)))
                                (let ((rest (rest-param? vars)))
                                  (if rest
                                      (compile-lambda (car rest) (cdr rest) body e next)
                                    (compile-lambda #f vars body e next)))))

(define (compile-lambda rest vars body e next)
  (list 'CLOSE
        (cons rest
              (compile-block body (extend e vars) '(RETURN)))
        next))

(define (rest-param? vars)
  (let ((pos (dotted-pos vars 0)))
    (if pos
        (if (zero? pos)
            (cons 0 (cons vars '()))
          (let ((last (last-pair vars)))
            (set-cdr! last (cons (cdr last) '()))
            (cons pos vars)))
      pos)))

(define (dotted-pos ls pos)
  (cond ((null? ls) #f)
        ((pair? ls) (dotted-pos (cdr ls) (+ pos 1)))
        (else pos)))

VM実行時には関数適用のときに、保存された情報を見てレストパラメータがあったら rib を作り変える:

(define VM
  (lambda (a x e r s)
    (record-case x
                 ...
                 (APPLY ()
                        (record a (body e)
                                (VM a (cdr body) (extend e (modify-args (car body) r)) '() s)))

(define (modify-args pos r)
  (if pos
      (if (zero? pos)
          (list r)
        (let ((last (list-tail r (- pos 1))))
          (set-cdr! last (list (cdr last)))
          r))
    r))

できた。

プロファイラで計測

| 22:04

ヒープベース実装がなんとなく動くようになってきた。せっかくなのでcygwin上のgccでも実行できるようにした。せっかくなので、VCでのプロファイルの取り方はよくわからないけどgccならできるだろうということでやってみた。

まずは、コンパイルオプションとリンクオプションに '-pg' をつけてmakeすると、プロファイル結果を出力する実行ファイルができる。

できたファイルを実行させると gmon.out というファイルが出力される。

gprof "実行ファイル名" gmon.out として出力されたファイルを食わせると、プロファイル結果を出力してくれる。

テストで、フィボナッチ数を計算させてみる。

(define (fib n)
  (if (< n 2)
      n
    (+ (fib (- n 1))
       (fib (- n 2)))))
(print (fib 30))

実行結果:

$ time ./mlisp.exe test_fib.scm
832040

real    0m32.662s
user    0m32.486s
sys     0m0.010s

30計算させたらむちゃむちゃかかった…。

gprof の結果は

Each sample counts as 0.01 seconds.
  %   cumulative   self              self     total           
 time   seconds   seconds    calls   s/call   s/call  name    
 26.92      3.57     3.57 372916732     0.00     0.00  cdr
 16.89      5.81     2.24 238289809     0.00     0.00  car
 10.33      7.18     1.37        1     1.37    11.42  vm
  9.58      8.45     1.27 16155222     0.00     0.00  lookup(SExp, SExp, bool)
  4.60      9.06     0.61 196555520     0.00     0.00  nilp
  4.52      9.66     0.60 84815050     0.00     0.00  type_of
  4.52     10.26     0.60                             GC_mark_from
  4.30     10.83     0.57                             GC_malloc
  4.00     11.36     0.53 51158423     0.00     0.00  cons
  2.41     11.68     0.32 51158423     0.00     0.00  Cell* alloc_sexpext<Cell>(Cell*, SAllocator&, SType, unsigned int, bool)
  1.89     11.93     0.25  8077649     0.00     0.00  list
  1.36     12.11     0.18 24232922     0.00     0.00  rplacd
  1.21     12.27     0.16 51158484     0.00     0.00  my_gc_malloc(unsigned int, int)
  1.21     12.43     0.16                             GC_build_fl_clear4
  1.13     12.58     0.15                             GC_reclaim_clear4
  0.90     12.70     0.12  2692537     0.00     0.00  builtin_lt(SExp)
  0.90     12.82     0.12  2692536     0.00     0.00  builtin_difference(SExp)
  0.60     12.90     0.08  1346268     0.00     0.00  builtin_plus(SExp)
  0.38     12.95     0.05                             GC_next_used_block
  0.30     12.99     0.04                             GC_apply_to_all_blocks
  0.30     13.03     0.04                             GC_clear_stack_inner
  0.30     13.07     0.04                             GC_start_reclaim
  0.23     13.10     0.03                             GC_allochblk_nth
  0.23     13.13     0.03                             GC_clear_hdr_marks
  0.15     13.15     0.02                             GC_adj_words_allocd
  0.15     13.17     0.02                             GC_block_empty
  0.15     13.19     0.02                             GC_find_start
  0.15     13.21     0.02                             GC_finish_collection
  0.08     13.22     0.01                             GC_allochblk
  0.08     13.23     0.01                             GC_allocobj
  0.08     13.24     0.01                             GC_generic_malloc_inner
  0.08     13.25     0.01                             GC_get_first_part
  0.08     13.26     0.01                             GC_is_black_listed
  0.00     13.26     0.00      383     0.00     0.00  FileStream::getch()
  0.00     13.26     0.00      142     0.00     0.00  std::_Rb_tree<char const*, std::pair<char const* const, SExp>, std::_Select1st<std::pair<char const* const, SExp> >, SymbolTable::StrCmp, std::allocator<std::pair<char const* const, SExp> > >::find(char const* const&)
  0.00     13.26     0.00      142     0.00     0.00  intern
  0.00     13.26     0.00       62     0.00     0.00  FileStream::ungetch(int)
  0.00     13.26     0.00       38     0.00     0.00  std::_Rb_tree<char const*, std::pair<char const* const, SExp>, std::_Select1st<std::pair<char const* const, SExp> >, SymbolTable::StrCmp, std::allocator<std::pair<char const* const, SExp> > >::lower_bound(char const* const&)
  0.00     13.26     0.00       38     0.00     0.00  std::_Rb_tree<char const*, std::pair<char const* const, SExp>, std::_Select1st<std::pair<char const* const, SExp> >, SymbolTable::StrCmp, std::allocator<std::pair<char const* const, SExp> > >::insert_unique(std::_Rb_tree_iterator<std::pair<char const* const, SExp> >, std::pair<char const* const, SExp> const&)
  0.00     13.26     0.00       38     0.00     0.00  std::_Rb_tree<char const*, std::pair<char const* const, SExp>, std::_Select1st<std::pair<char const* const, SExp> >, SymbolTable::StrCmp, std::allocator<std::pair<char const* const, SExp> > >::_M_insert(std::_Rb_tree_node_base*, std::_Rb_tree_node_base*, std::pair<char const* const, SExp> const&)
  0.00     13.26     0.00       36     0.00     0.00  Symbol* alloc_sexpext<Symbol>(Symbol*, SAllocator&, SType, unsigned int, bool)
  0.00     13.26     0.00       25     0.00     0.00  Procedure* alloc_sexpext<Procedure>(Procedure*, SAllocator&, SType, unsigned int, bool)
  0.00     13.26     0.00       24     0.00     0.00  gen_cfunc
  0.00     13.26     0.00       15     0.00     0.00  compile
  0.00     13.26     0.00       13     0.00     0.00  compile_lookup(SExp, SExp)
  0.00     13.26     0.00       11     0.00     0.00  assoc
  0.00     13.26     0.00        8     0.00     0.00  compile_pair_loop(SExp, SExp, SExp, SExp)
  0.00     13.26     0.00        5     0.00     0.00  singlep
  0.00     13.26     0.00        4     0.00     0.00  rplaca
  0.00     13.26     0.00        3     0.00     0.00  read_rec(Stream*)
  0.00     13.26     0.00        3     0.00     0.00  std::_Rb_tree<char const*, std::pair<char const* const, SExp>, std::_Select1st<std::pair<char const* const, SExp> >, SymbolTable::StrCmp, std::allocator<std::pair<char const* const, SExp> > >::_M_erase(std::_Rb_tree_node<std::pair<char const* const, SExp> >*)
  0.00     13.26     0.00        3     0.00     0.00  read_from_file
  0.00     13.26     0.00        2     0.00     0.00  __static_initialization_and_destruction_0(int, int)
  0.00     13.26     0.00        2     0.00     0.00  compile_block
  0.00     13.26     0.00        2     0.00     0.00  last_pair
  0.00     13.26     0.00        1     0.00     0.00  compile_file(char const*)
  0.00     13.26     0.00        1     0.00     0.00  builtin_print(SExp)
  0.00     13.26     0.00        1     0.00     0.00  compile_define_var(SExp, SExp)
  0.00     13.26     0.00        1     0.00     0.00  print_rec(SExp)
  0.00     13.26     0.00        1     0.00     0.00  std::_Rb_tree<char const*, std::pair<char const* const, SExp>, std::_Select1st<std::pair<char const* const, SExp> >, SymbolTable::StrCmp, std::allocator<std::pair<char const* const, SExp> > >::insert_unique(std::pair<char const* const, SExp> const&)
  0.00     13.26     0.00        1     0.00     0.00  gen_closure
  0.00     13.26     0.00        1     0.00     0.00  init_compile
  0.00     13.26     0.00        1     0.00     0.00  length
  0.00     13.26     0.00        1     0.00     0.00  mlisp_delete
  0.00     13.26     0.00        1     0.00     0.00  mlisp_new
  0.00     13.26     0.00        1     0.00     0.00  nreverse
  0.00     13.26     0.00        1     0.00     0.00  print
  0.00     13.26     0.00        1     0.00     0.00  replicate

car, cdr や nil かどうか判定する nilp が上位ということに。こんだけ呼び出される関数はインラインにしたほうがいいかねぇ?という結果に。バイトコードもなにもかもS式だから、なにをするにも呼び出されるしね。cons も結構きてる。ちなみに GC は BoehmGC を使用。

追記:car と cdr と nilp をインラインにしてみた。cons はちょっと外に出せなかったのでそのままに。時間は 13.033 秒に短縮。vm が一番時間がかかってるという、ある意味望ましい結果に。ただ、vm の self seconds は 3.45 に増えてたので、今まで car や cons にかかっていたのが分散されただけかも知れず。

速いといわれるLuaでも試してみた:

function fib(n)
	if n < 2 then
		return n
	else
		return fib(n - 1) + fib(n - 2)
	end
end
print(fib(30))
$ lua -v
Lua 5.0.2  Copyright (C) 1994-2004 Tecgraf, PUC-Rio

$ time lua fib.lua
832040

real    0m0.575s
user    0m0.020s
sys     0m0.000s

Lua の数値は double だから、これは速いといえるかも。あらかじめコンパイルしたファイルを食わせてもみたけど、結果は全く変わらず。コンパイル時間なんて屁のようなもんですか。

Cでも試してみた:

int fib(int n) {
	if (n < 2)	return n;
	else		return fib(n - 1) + fib(n - 2);
}
main() {
	printf("%d\n", fib(30));
}
$ time ./fib.exe
832040

real    0m0.075s
user    0m0.050s
sys     0m0.010s

おぉ、ネイティブの威力はさすがですな。

トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20080505