`(Hello ,world)

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

2008-05-20

末尾最適化のついたスタックベースのcall/ccでエラー

| 07:03

3imp スタックベース4.6の末尾最適化をした実装で、call/cc を使うとうまく動かない場合がある。

(call/cc
 (lambda (cc)
   (cc 1234)))

は動いて、それに一段かまして呼び出してみると

((lambda (a)
   (call/cc
    (lambda (cc)
      (cc a))))
 1234)

NUATE 後にスタックに 1234 が積んであって RETURN でおかしな値をひっぱってきてしまう。コンパイルしたコードはこのとおり:

(FRAME
 (HALT)
 (CONSTANT
  1234
  (ARGUMENT
   (CLOSE
    0
    (CONTI
     (ARGUMENT
      (REFER-LOCAL
       0
       (ARGUMENT
        (CLOSE
         1
         (REFER-FREE
          0
          (ARGUMENT
           (REFER-LOCAL
            0
            (SHIFT
             1
             1
             (APPLY)))))
         (SHIFT
          1
          1
          (APPLY)))))))
    (APPLY)))))

CONTI の呼び出しが末尾最適化で FRAME が作られてないので、continuation の中で

(list 'NUATE (save-stack s) '(RETURN 0)) 

と RETURN をそのまま呼び出してしまっているのはまずくて、SHIFT をしないといけない。その辺BiwaSchemeはどうしてるのかなーと動かしてみると、

[frame
   [constant 1234
   [argument
   [close 0
      [conti 1
      [argument
      [refer-local 0
      [argument
      [close 1
         [refer-free 0
         [argument
         [refer-local 0
         [shift 1 1
         [apply 1]]]]]
      [shift 1 1
      [apply 1]]]]]]]
   [apply 1]]]]
[halt]]

conti に上のスタックフレームの引数の数らしきパラメータが追加されている。これを使って shift-args させているんだろう。

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

2008-05-15

evalのときにスタックが壊れる

| 08:11

スタックベースにevalを組み込んだら、vm 実行中に再び vm が呼び出されて、それ自体は特にいいんだけど、静的に取ってるスタックは同じものを使うからスタックの中身がぶっこわれる。

現在のスタックポインタを引き継いで使えばいいんだけど、マクロを実装した場合 compile 内部から vm が呼び出されるので、スタックポインタを引き回すわけにも行かず。

スタックと同様に、グローバルにしてしまえばいいのか。

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

2008-05-14

Monar

23:37

Google Code Archive - Long-term storage for Google Code Project Hosting.

Scheme 処理系 「Mosh 0.0.1」 をリリースしました (higepon @ cybozu labs)

公開されていたので、チラッと見た。3impを読んでたから、それベースなのかと思ってたら全然違ってビックリした。そしてあの量…絶望した!

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

2008-05-13

スタックベースで任意個の引数

| 08:42

引数の数をスタックの一番最後に積むようにした。それがあれば RETURN や SHIFT へのパラメータは必要なくなるので削除。

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

2008-05-12

ニワトリとタマゴ

08:10

Gambit-Cを一から作ってみる。

INSTALL.txt:

  % ./configure
  % make
  % make check
  % make install
  % make bootstrap

make 時のログを見ると、

../gsc-comp -:=.. -f -c -check _io.scm
gcc -I../include -I. -Wall -W -Wno-unused -O1 -fno-math-errno -fschedule-insns2 -fno-trapping-math -fno-strict-aliasing -fwrapv -fomit-frame-pointer -fno-common -mieee-fp -DHAVE_CONFIG_H -D___PRIMAL -D___LIBRARY -D___GAMBCDIR="\"/usr/local/Gambit-C/v4.2.5\"" -D___SYS_TYPE_CPU="\"i686\"" -D___SYS_TYPE_VENDOR="\"pc\"" -D___SYS_TYPE_OS="\"cygwin\"" -c _io.c
...

とある。gsc-comp でググるとMain Page - Gambit wiki

cd gambit
./configure
make bootstrap

This will create the gsc-comp compiler,

とある。じゃあっつって make bootstrap してみると

../gsc-comp -:=.. -f -c -check _io.scm
gcc -I../include -I. -Wall -W -Wno-unused -O1 -fno-math-errno -fschedule-insns2 -fno-trapping-math -fno-strict-aliasing -fwrapv -fomit-frame-pointer -fno-common -mieee-fp -DHAVE_CONFIG_H -D___PRIMAL -D___LIBRARY -D___GAMBCDIR="\"/usr/local/Gambit-C/v4.2.5\"" -D___SYS_TYPE_CPU="\"i686\"" -D___SYS_TYPE_VENDOR="\"pc\"" -D___SYS_TYPE_OS="\"cygwin\"" -c _io.c
...

その gsc-comp は誰が作ったっつーの。

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

2008-05-11

スタックベースに置き換え中

| 11:17

3impのスタックベース実装にトップレベルでの define を追加してひとまず動かせるようになったので、例によって fib(30) を gprof にかけてみた。

Each sample counts as 0.01 seconds.
  %   cumulative   self              self     total           
 time   seconds   seconds    calls   s/call   s/call  name    
 33.40      1.56     1.56 146743443     0.00     0.00  car
 27.19      2.83     1.27        2     0.64     2.33  vm
 18.42      3.69     0.86 122510573     0.00     0.00  cdr
  9.42      4.13     0.44 55197115     0.00     0.00  type_of
  6.21      4.42     0.29  9423879     0.00     0.00  std::_Rb_tree<SExp, std::pair<SExp const, SExp>, std::_Select1st<std::pair<SExp const, SExp> >, std::less<SExp>, std::allocator<std::pair<SExp const, SExp> > >::find(SExp const&)
  1.93      4.51     0.09  2692537     0.00     0.00  builtin_lt(int)
  1.07      4.56     0.05  2692536     0.00     0.00  builtin_difference(int)
  0.86      4.60     0.04 13462683     0.00     0.00  refer_stack(int, int)
  0.86      4.64     0.04  1346268     0.00     0.00  builtin_plus(int)
  0.43      4.66     0.02  2692537     0.00     0.00  type_check
  0.21      4.67     0.01                             GC_freehblk
  0.00      4.67     0.00  2692750     0.00     0.00  nilp
  0.00      4.67     0.00      406     0.00     0.00  FileStream::getch()
  0.00      4.67     0.00      195     0.00     0.00  my_gc_malloc(unsigned int, int)
  0.00      4.67     0.00      176     0.00     0.00  cons
  0.00      4.67     0.00      135     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      4.67     0.00      135     0.00     0.00  intern
  0.00      4.67     0.00       92     0.00     0.00  rplacd
  0.00      4.67     0.00       50     0.00     0.00  list
  0.00      4.67     0.00       47     0.00     0.00  read_rec(Stream*)
  0.00      4.67     0.00       37     0.00     0.00  set_union(SExp, SExp)
  0.00      4.67     0.00       34     0.00     0.00  FileStream::ungetch(int)
  0.00      4.67     0.00       15     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      4.67     0.00       15     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      4.67     0.00       15     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      4.67     0.00       15     0.00     0.00  compile
  0.00      4.67     0.00       12     0.00     0.00  compile_refer(SExp, SExp, SExp)
  0.00      4.67     0.00       12     0.00     0.00  compile_lookup(int*, SExp, SExp)
  0.00      4.67     0.00        8     0.00     0.00  compile_pair_loop(SExp, SExp, SExp, SExp, SExp)
  0.00      4.67     0.00        6     0.00     0.00  set_memberp(SExp, SExp)
  0.00      4.67     0.00        6     0.00     0.00  std::_Rb_tree<SExp, std::pair<SExp const, SExp>, std::_Select1st<std::pair<SExp const, SExp> >, std::less<SExp>, std::allocator<std::pair<SExp const, SExp> > >::lower_bound(SExp const&)
  0.00      4.67     0.00        6     0.00     0.00  std::_Rb_tree<SExp, std::pair<SExp const, SExp>, std::_Select1st<std::pair<SExp const, SExp> >, std::less<SExp>, std::allocator<std::pair<SExp const, SExp> > >::insert_unique(std::_Rb_tree_iterator<std::pair<SExp const, SExp> >, std::pair<SExp const, SExp> const&)
  0.00      4.67     0.00        6     0.00     0.00  std::_Rb_tree<SExp, std::pair<SExp const, SExp>, std::_Select1st<std::pair<SExp const, SExp> >, std::less<SExp>, std::allocator<std::pair<SExp const, SExp> > >::_M_insert(std::_Rb_tree_node_base*, std::_Rb_tree_node_base*, std::pair<SExp const, SExp> const&)
  0.00      4.67     0.00        5     0.00     0.00  define_global
  0.00      4.67     0.00        5     0.00     0.00  gen_cfunc
  0.00      4.67     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      4.67     0.00        3     0.00     0.00  length
  0.00      4.67     0.00        3     0.00     0.00  read_from_file
  0.00      4.67     0.00        2     0.00     0.00  __static_initialization_and_destruction_0(int, int)
  0.00      4.67     0.00        2     0.00     0.00  __static_initialization_and_destruction_0(int, int)
  0.00      4.67     0.00        2     0.00     0.00  std::_Rb_tree<SExp, std::pair<SExp const, SExp>, std::_Select1st<std::pair<SExp const, SExp> >, std::less<SExp>, std::allocator<std::pair<SExp const, SExp> > >::_M_erase(std::_Rb_tree_node<std::pair<SExp const, SExp> >*)
  0.00      4.67     0.00        1     0.00     0.00  builtin_print(int)
  0.00      4.67     0.00        1     0.00     0.00  set_intersect(SExp, SExp)
  0.00      4.67     0.00        1     0.00     0.00  make_boxes_loop(SExp, SExp, SExp, int)
  0.00      4.67     0.00        1     0.00     0.00  find_free(SExp, SExp)
  0.00      4.67     0.00        1     0.00     0.00  find_sets(SExp, SExp)
  0.00      4.67     0.00        1     0.00     4.66  load_file(char const*)
  0.00      4.67     0.00        1     0.00     0.00  print_rec(SExp)
  0.00      4.67     0.00        1     0.00     0.00  std::_Rb_tree<SExp, std::pair<SExp const, SExp>, std::_Select1st<std::pair<SExp const, SExp> >, std::less<SExp>, std::allocator<std::pair<SExp const, SExp> > >::insert_unique(std::pair<SExp const, SExp> const&)
  0.00      4.67     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      4.67     0.00        1     0.00     0.00  append2
  0.00      4.67     0.00        1     0.00     0.00  gen_closure
  0.00      4.67     0.00        1     0.00     0.00  init_compile
  0.00      4.67     0.00        1     0.00     0.00  init_vm
  0.00      4.67     0.00        1     0.00     0.00  mlisp_delete
  0.00      4.67     0.00        1     0.00     0.00  mlisp_new
  0.00      4.67     0.00        1     0.00     0.00  nreverse
  0.00      4.67     0.00        1     0.00     0.00  print

cons の数が 176回と激減してるのでよしよし。グローバルの変数に STL::map を使ったので、その find がかなり呼び出されてる。

実行時間は

$ time ./mlisp.exe test_fib.scm
832040

real    0m3.826s
user    0m3.795s
sys     0m0.010s

結構速くなった。

VC++ 2003 の Release でビルドしたものだとよりいっそう時間がかかる:

real    0m19.629s
user    0m0.020s
sys     0m0.000s

このありさま、、、Enterprise 版だったっけか?

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

2008-05-10

4.5章、box 関数が未定義

| 15:15

box, unbox, set-box! がさらっと出てくるけど定義は書いてない。

box の実装 - Scheme VM を書く - higepon blog

4.5章、ボックスむずい

| 12:57

継続やディスプレイクロージャで変数の値がコピーされてしまう状態で代入をサポートするために、代入される変数へのアクセスにボックスを介して行うようにして、1箇所での変更が全てに反映されるようにする。ここまではよい。次の意味がよくわからない:

In creating a closure, the collection of free variables does not change, even for boxed variables. Since the closure must have the box rather than the value, no indirection is necessary.

「クロージャのフリー変数はボックスの変数であっても(外から)変更されない。クロージャは値じゃなくてボックスを持つ必要があるので、間接アクセスは必要ない」ってこと?

英語がよくわからないので、言ってることが矛盾しているように感じる?

4.4章のディスプレイクロージャ実装の継続でエラー

| 11:59

3imp4.4章の、ディスプレイクロージャによる実装で、

The remaining help functions have not changed from the previous virtual machine.

と書いてあって continuation のコードは示されてないのだけど、closure 関数の引数の数が変わってるし、VM の命令コード refer は refer-local と refer-free に置き換えられてるのでそのままでは動かない。

gosh> (evaluate '(call/cc (lambda (cc) (cc 1234))))
*** ERROR: wrong number of arguments for #<closure closure> (required 3, got 2)

継続への第一引数を参照するようにして、クロージャのフリー変数の数は0にすれば動いた:

(define continuation
  (lambda (s)
    (closure
     (list 'REFER-LOCAL 0 (list 'NUATE (save-stack s) '(RETURN 0)))
     0
     '())))

higeponhigepon2008/05/10 18:30何かお困りですか?解決済みでしょうか。

mokehehemokehehe2008/05/10 21:41higeponさん、ありがとうございます。
現在"Three Implementation Models for Scheme"のスタックベースの実装を読んで試しているんですが、複文の扱いと、任意個の引数を取る関数の扱いで悩んでます。
複文は、compile に次に実行するコードを渡すようになってると思うんですが、そうすると後に実行する文を先にコンパイルする必要がありますがそれでいいのか?というところです。
任意個の引数は、スタックベースの場合 VM で return 命令を実行するときに、関数が引数の数を知っていてその分スタックポインタを戻していると思うんですが、任意個の引数を扱おうとする場合どうしたらいいかと思ってます。
higeponさんはどのように解決されてますでしょうか?

higeponhigepon2008/05/10 22:38こんにちは。
・複文
>そうすると後に実行する文を先にコンパイルする必要がありますがそれでいいのか?というところです。

最初はそれで良いのではないでしょうか。再帰でコンパイルしていくような形にすれば後に実行するものほど先にコンパイルされる形に出きると思います。

・任意個の引数
手続きの呼び出しのインストラクションで引数の個数をオペランドとして渡す。
もしくは
Scheme の apply 手続きのように引数をリストとして渡す。
あたりはどうでしょうか。

mokehehemokehehe2008/05/11 06:42複文は後に実行するものを先にコンパイルしても大丈夫なんですか、ちょっと意外でした。関数内でdefineされるといやだな~と思ったもので。
任意個の引数は、コンパイル時には関数の定義が確定してないので呼び出し元がリストを作成できないと思うので、呼び出された関数で行う、ということになると思うんですが、そうすると引数の個数を渡さないと知りようがないですよね。
Gaucheでdisasmしてみたところ、GREF-TAIL-CALL(3)などと、引数の数が出るようになってました~。関数呼び出し時には引数の数も渡してるんですかね。

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

2008-05-09

スタックベースの実装のときの、グローバル環境の扱い

| 07:30

3impの4.1読みすすめ中。

ヒープベースで組み込み関数を追加したときは、グローバルなシンボルを初期化時に環境に突っ込んでやって、一番上の静的スコープがグローバル環境、という具合にして普通の変数参照と同じ仕組みで参照させてた。

けどスタックベースにしようとなると、スタックの底にグローバルのシンボルを積んでおく、というわけにもいかないし、実行時に新しいシンボルを追加できない。グローバルへの参照は refer-global みたいにして、別領域をアクセスするようにしたほうがいいかな?

そうだとしても、関数内で define された場合の処理は残るな…。

gnarlgnarl2008/05/09 15:23関数内でのdefineはletrecと同等(R5RS 5.2.5)なので、グローバル環境には影響しませんよ

mokehehemokehehe2008/05/09 23:06内部定義が letrec と等価とは知りませんでした。letrec に変換してしまえば、自前であれこれしなくてすみますね。

mokehehemokehehe2008/05/10 15:34higepon氏のdefine実装
http://d.hatena.ne.jp/higepon/20071110/1194698241

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

2008-05-06

非決定性できたよー\(^o^)/

10:33

可変引数を実装して、let マクロで本体に複数の式を取れるようになったので、The 90 Minute Scheme to C compiler に出てきた非決定性のプログラムが動いたー。

それまでに、任意個の引数を受け付けるときに引数リストを破壊してたのでマクロを複数回適用するとおかしくなるとか、クロージャの持ち方を変えたのにコンティニュエーションの持ち方を変えてなくてエラーが出たりとか大変だった。やはり副作用は敵ですね。

(define (cadr x) (car (cdr x)))

(define (null? x)
  (eq? x '()))

(define (reverse ls)
  (define (loop ls acc)
    (if (null? ls)
        acc
      (loop (cdr ls) (cons (car ls) acc))))
  (loop ls '()))

(define (map f ls)
  (define (loop ls acc)
    (if (null? ls)
        (reverse acc)
      (loop (cdr ls) (cons (f (car ls)) acc))))
  (loop ls '()))

(defmacro let (params . body)
  `((lambda ,(map (lambda (x)
                    (if (pair? x) (car x) x))
                  params)
      ,@body)
    ,@(map (lambda (x)
             (if (pair? x) (cadr x) nil))
           params)))

;;;;

(define fail
  (lambda () (error "no solution")))

(define in-range
  (lambda (a b)
    (call/cc
     (lambda (cont)
       (enumerate a b cont)))))

(define enumerate
  (lambda (a b cont)
    (if (> a b)
        (fail)
      (let ((save fail))
        (set! fail
              (lambda ()
                (set! fail save)
                (enumerate (+ a 1) b cont)))
        (cont a)))))

(print
 (let ((x (in-range 2 9))
       (y (in-range 2 9))
       (z (in-range 2 9)))
   (if (= (* x x)
          (+ (* y y) (* z z)))
       (list x y z)
     (fail))))

プロファイル

10:33

昨日の時間計測はプロファイルを入れた状態で計ってたので、それが結構食っていた。ソースは最初の32秒かかっていた状態で、プロファイルを切ってコンパイルした実行ファイルで fib(30) を計ったら 11.366 秒だった。関数呼び出しが死ぬほど多いとはいえ、変わりすぎだろ。

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

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

2008-05-04

ダメだった

17:45

append だと括弧を重ねても取り払われてしまってうまく動かなかった。ペアの場合は list で一段深くして、最後にごにょごにょしてみる。

(define (transform-quasiquote x)
  (define (loop x)
    (cond ((not (pair? x)) `(quote (,x)))
          ((eq? (car x) 'unquote) `(list ,(cadr x)))
          ((eq? (car x) 'unquote-splicing) (cadr x))
          (else `(list (append ,@(map loop x))))))
  (let ((res (loop x)))
    (case (car res)
      ((list) (cadr res))
      ((quote) `(quote ,(caadr res)))
      (else (error "unexpected")))))

バッククォート

17:00

3impにマクロを実装したい。けどその前に、マクロを実装するとなるとS式の変形を手で書くのはメンドイのでバッククォートとかカンマを使いたい。効率的なやり方はさておいて、とりあえず機械的に変形するだけだったら append でくっつけるようにしてしまえば

(define x '(a b)) 
`(1 x 2) => (append '(1) '(x) '(2)) => (1 x 2) 
`(1 ,x 2) => (append '(1) (list x) '(2)) => (1 (a b) 2) 
`(1 ,@x 2) => (append '(1) x '(2)) => (1 a b 2) 

対応できる。「,」「,@」はそれぞれ unquote と unquote-splicing。

(define (transform-quasiquote x) 
  (define (loop x) 
    (cond ((not (pair? x)) (list 'quote (list x))) 
          ((eq? (car x) 'unquote) (list 'list (cadr x))) 
          ((eq? (car x) 'unquote-splicing) (cadr x)) 
          (else (cons 'append (map loop x))))) 
  (loop x)) 

この関数自体もバッククォートを使って書けば

(define (transform-quasiquote x) 
  (define (loop x) 
    (cond ((not (pair? x)) `(quote (,x))) 
          ((eq? (car x) 'unquote) `(list ,(cadr x))) 
          ((eq? (car x) 'unquote-splicing) (cadr x)) 
          (else `(append ,@(map loop x))))) 
  (loop x)) 

バッククォートの変換の関数をバッククォートを使って書くとか、自分が何を作ってるのかよくわからなくなってくる。

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

2008-05-03

3impにREPLを実装したい

| 13:46

すげー大変。元のソースはすごくきれいにまとまってるけど、REPLとか複文とかdefineとかグローバル環境をつけようとすると結構手を入れないといけない。

  • 次の文の処理
  • lambda の本体で複文が使えるように
  • define は、シンボルが環境になかったら環境を拡張するようにする(コンパイル時、実行時とも)
  • 実行時にはコンパイル時の情報が全て失われているので、デバッグが大変

BiwaSchemeはどうなってるんだろう、と思ってテストしてみる:

(define (tap x)
  (print x)
  x)
(tap "hello")
[close 0
   [frame
      [refer-local 0
      [argument
      [refer-global "print"
      [apply 1]]]]
   [refer-local 0
   [return 1]]]
[assign-global "tap"
[halt]]]
hello
"hello"

おぉ、ちゃんと複文にも対応してる。すげー。グローバルの値はコンパイルしたコードにシンボルが残ってるのもいいですね。

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

2008-05-02

3impで複数の式のコンパイル

| 00:45

3impだと、ひとつの式をコンパイルするときに、あらかじめ次の式を渡さないといけない。でもそれだと式を順に実行していくときに、後の式を先にコンパイルしておかなければならないというジレンマ。

後の式を先にコンパイルしなくてすむように、1つの式をコンパイルするときには次に呼び出すコードとしてダミーの '(halt) を渡しておいて、まだ命令が続くようだったら '(halt) の中身を set-car!, set-cdr! で書き換えるようにしてみた:

(define (compile-file f prev)
  (let ((sexp (read f))
        (next (list 'halt)))
    (unless (eof-object? sexp)
      (let ((r (compile sexp comp-env next)))
        (set-car! prev (car r))
        (set-cdr! prev (cdr r))
        (compile-file f next)))))

(define (main args)
  (let* ((start (cons '() '()))
         (res (compile-file (current-input-port) start)))
    (print start)))

これはひどい。

どう書く symbol-value

08:09

Lisp でいうところの symbol-value (symbol-function) 的なものは、Scheme ではどう書くんでしょう?

Three implementation models for scheme をちょこちょこいじくってるんですが、組込み関数を定義しようと思って、

(define init-env
  (list
   (cons 'cons (lambda args (apply cons args)))
   (cons 'car (lambda args (apply car args)))
   (cons 'cdr (lambda args (apply cdr args)))
   ...
   ))

とか書いてて、「これマクロで置き換えられるよなぁ」と思って

(define builtins-proc
  (lambda (ls)
    (map (lambda (sym)
           `(cons ',sym (lambda args (apply ,sym args))))
         ls)))

(define-macro builtins
              (lambda (ls)
                `(list ,@(builtins-proc ls))))
(builtins (cons car cdr))

とか書いてみたんだけど、「builtins に渡すときにクォートしなくていいのは気持ち悪いなぁ」と思って、よく考えたらマクロは必要なくてシンボルの値が取れれば

(define (builtins ls)
  (map (lambda (x) (cons x (lambda args (apply (symbol-value x) args))))  ; symbol-value ?
       ls))
(builtins '(cons car cdr))

とできるハズ、だけど symbol-value に相当する Scheme の関数がわからないんです。eval してしまえば

(eval x (scheme-report-environment 5))

できるっちゃできますが…。

mokehehemokehehe2008/05/02 23:26Guileにはvariable-ref という関数がある模様
http://www.kt.rim.or.jp/~kbk/guile/guile_24.html

lequeleque2008/05/03 07:06Gauche には global-variable-ref というのがありますが
( http://practical-scheme.net/gauche/man/gauche-refj_32.html#IDX100 )、
RnRS の範囲内だと eval するしかないんじゃないかと思います。無理に quote を入れるのなら syntax-rules を使って
(define-syntax builtins
(syntax-rules (quote)
((_ (quote sym ...))
(list (cons 'sym (lambda args (apply sym args))) ...))))
とするとか。

mokehehemokehehe2008/05/03 08:45まさに望みどおりの関数です、ありがとうございます。
Gaucheのマニュアルの「symbol-bound?は非推奨となり、…」のくだりを読んで、SchemeとCommon Lispではシンボルの扱いが違うということを初めて知りました。
Scheme では環境によってシンボルが値にバインドされてるのに対して、Common Lispではシンボル自体が値を持っていて、それがパッケージごとになっているということでしょうか。Common Lisp のほうがよくわかってないです。

mokehehemokehehe2008/05/03 08:47Symbols - Hyper Spec
http://www.lispworks.com/documentation/HyperSpec/Body/10_.htm
シンボルとパッケージ
http://www.fireproject.jp/feature/common-lisp/details/symbol-package.html

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

2008-05-01

The 90 Minute Scheme to C compiler

08:38

higepon氏が紹介していたUr-Schemeをつらつら見てたら、The 90 Minute Scheme to C compilerを見て作ったとかなんとか書いてある。

じゃあそいつを試してみようと、ソースを落としてみた。Gaucheに食わせると、いきなり頭の

(define-type ast
  extender: define-type-of-ast
  subx) ; the asts of the sub-expressions

で、define-type がないとかで怒られる。しかたないのでコメントに書いてあるように、Gambit-C を使うようにして、テストのソースを食わせてみる。

test1.scm

(define square
  (lambda (x)
    (* x x)))

(+ (square 5) 1)

コンパイルしてみる:

$ ./90-min-scc.scm test1.scm
-------------------------- AST:
(begin (set! square (lambda (x.1) (%* x.1 x.1))) (%+ (square 5) 1))
-------------------------- AST AFTER CPS-CONVERSION:
(let ((r.5 (lambda (k.6 x.1) (k.6 (%* x.1 x.1)))))
  (let ((r.3 (set! square r.5)))
    (square (lambda (r.4) (let ((r.2 (%+ r.4 1))) (%halt r.2))) 5)))
-------------------------- AST AFTER CLOSURE-CONVERSION:
(lambda ()
  (let ((r.5 (%closure
              (lambda (self.7 k.6 x.1)
                ((%closure-ref k.6 0) k.6 (%* x.1 x.1))))))
    (let ((r.3 (set! square r.5)))
      ((%closure-ref square 0)
       square
       (%closure (lambda (self.8 r.4) (let ((r.2 (%+ r.4 1))) (%halt r.2))))
       5))))
-------------------------- C CODE:
case 0: /* (lambda () (let ((r.5 (%closure (lambda (self.7 k.6 x.1) ... */

 BEGIN_CLOSURE(1,0); END_CLOSURE(1,0);
 PUSH(LOCAL(0/*r.5*/)); GLOBAL(0/*square*/) = TOS();
 PUSH(GLOBAL(0/*square*/));
 BEGIN_CLOSURE(2,0); END_CLOSURE(2,0);
 PUSH(INT2OBJ(5));
 BEGIN_JUMP(3); PUSH(LOCAL(2)); PUSH(LOCAL(3)); PUSH(LOCAL(4)); END_JUMP(3);

case 2: /* (lambda (self.8 r.4) (let ((r.2 (%+ r.4 1))) (%halt r.2))) */

 PUSH(LOCAL(1/*r.4*/)); PUSH(INT2OBJ(1)); ADD();
 PUSH(LOCAL(2/*r.2*/)); HALT();

case 1: /* (lambda (self.7 k.6 x.1) ((%closure-ref k.6 0) k.6 (%* x.... */

 PUSH(LOCAL(1/*k.6*/));
 PUSH(LOCAL(2/*x.1*/)); PUSH(LOCAL(2/*x.1*/)); MUL();
 BEGIN_JUMP(2); PUSH(LOCAL(3)); PUSH(LOCAL(4)); END_JUMP(2);

コンパイル出力結果:

#define NB_GLOBALS 1
#define MAX_STACK 100

#include <stdio.h>
#include <stdlib.h>

#define HEAP_SIZE 1000000

typedef int obj;

obj global[NB_GLOBALS];
obj stack[MAX_STACK];
obj heap[HEAP_SIZE];

#define INT2OBJ(n) ((n) << 1)
#define OBJ2INT(o) ((o) >> 1)

#define PTR2OBJ(p) ((obj)(p) + 1)
#define OBJ2PTR(o) ((obj*)((o) - 1))

#define FALSEOBJ INT2OBJ(0)
#define TRUEOBJ INT2OBJ(1)

#define GLOBAL(i) global[i]
#define LOCAL(i) stack[i]
#define CLOSURE_REF(self,i) OBJ2PTR(self)[i]

#define TOS() sp[-1]
#define PUSH(x) *sp++ = x
#define POP() *--sp

#define EQ() { obj y = POP(); TOS() = INT2OBJ(TOS() == y); }
#define LT() { obj y = POP(); TOS() = INT2OBJ(TOS() < y); }
#define ADD() { obj y = POP(); TOS() = TOS() + y; }
#define SUB() { obj y = POP(); TOS() = TOS() - y; }
#define MUL() { obj y = POP(); TOS() = OBJ2INT(TOS()) * y; }
#define DISPLAY() printf ("%d", OBJ2INT(TOS()))
#define HALT() break

#define BEGIN_CLOSURE(label,nbfree) if (hp-(nbfree+1) < heap) hp = gc (sp);
#define INICLO(i) *--hp = POP()
#define END_CLOSURE(label,nbfree) *--hp = label; PUSH(PTR2OBJ(hp));

#define BEGIN_JUMP(nbargs) sp = stack;
#define END_JUMP(nbargs) pc = OBJ2PTR(LOCAL(0))[0]; goto jump;

obj *gc (obj *sp) { exit (1); } /* no GC! */

obj execute (void)
{
  int pc = 0;
  obj *sp = stack;
  obj *hp = &heap[HEAP_SIZE];

  jump: switch (pc) {

case 0: /* (lambda () (let ((r.5 (%closure (lambda (self.7 k.6 x.1) ... */

 BEGIN_CLOSURE(1,0); END_CLOSURE(1,0);
 PUSH(LOCAL(0/*r.5*/)); GLOBAL(0/*square*/) = TOS();
 PUSH(GLOBAL(0/*square*/));
 BEGIN_CLOSURE(2,0); END_CLOSURE(2,0);
 PUSH(INT2OBJ(5));
 BEGIN_JUMP(3); PUSH(LOCAL(2)); PUSH(LOCAL(3)); PUSH(LOCAL(4)); END_JUMP(3);

case 2: /* (lambda (self.8 r.4) (let ((r.2 (%+ r.4 1))) (%halt r.2))) */

 PUSH(LOCAL(1/*r.4*/)); PUSH(INT2OBJ(1)); ADD();
 PUSH(LOCAL(2/*r.2*/)); HALT();

case 1: /* (lambda (self.7 k.6 x.1) ((%closure-ref k.6 0) k.6 (%* x.... */

 PUSH(LOCAL(1/*k.6*/));
 PUSH(LOCAL(2/*x.1*/)); PUSH(LOCAL(2/*x.1*/)); MUL();
 BEGIN_JUMP(2); PUSH(LOCAL(3)); PUSH(LOCAL(4)); END_JUMP(2);

  }
  return POP();
}

int main () { printf ("result = %d\n", OBJ2INT(execute ())); return 0; }

実際のコードに対応する部分は、switch 文の中だけ。うーん、Cにコンパイルといっても、これだとVM形式とそんなに変わらない気がするなぁ。

後で論文やビデオを見る。

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