`(Hello ,world)

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

2012-07-14

3impのヒープベース処理系に多値を追加する

3impの処理系には多値がない。いままでどうやればいいのか思いつかなかったのだけど、なんとなくできたので。

compileのペアの評価に、多値を返すスペシャルフォーム values を追加する:

(define compile
  ...
  (record-case x
   ...
   (values args
           (recur loop ((args args)
                        (c (if (tail? next)
                               ;; Tail case: directly go to next command.      
                               (list 'values next)
                             ;; Non-tail case: implicit return.                
                             (list 'values '(return)))))
                  (if (null? args)
                      (if (tail? next)
                          c
                        (list 'frame next c))
                    (loop (cdr args)
                          (compile (car args)
                                   e
                                   (list 'argument c))))))
   ...

valuesがきたら、関数呼び出しと同じく引数をargumentで積んでいって、最後に (values next) というバイトコードを追加する。あとは末尾だったらframeを作らないとかは関数呼び出しと同じ。例:

> (compile '(values 1 2 3) '())
(constant 3 (argument (constant 2 (argument (constant 1 (argument (values (return))))))))

VMでは、オペコードがvaluesだったら、引数としてつまれている最初の値(空の場合はundefined)を a に代入する。それによって一番目の値をそのまま演算に使える。

(define VM
  ...
    (record-case x                                                            
     (values (x)
             (let1 a (if (null? r)
                         (undefined)
                       (car r))
                   (VM a x e r s r)))
  ...

多値を受け取る receive スペシャルフォームもコンパイラに追加する。receiveは (receive (x y z) (values 1 2 3) body) という形式:

(define compile
  ...
  (record-case x
   ...
   (receive (vars vals body)
            (compile vals e
                     (list 'receive
                           (compile body (extend e vars) next))))
   ...

まず vals をコンパイルして、あとはlambdaと同じく環境をvarsで拡張してボディを評価。

VMに、それまでのステートに加えて、多値用の変数 rest-values を追加する

(define VM
  (lambda (a x e r s rest-values)

バイトコードの receive がきたら、関数呼び出しの apply と同じような感じで、rest-values を使って環境を拡張する:

(define VM
  ...
    (record-case x                                                            
     (receive (x)
              (VM a x (extend e rest-values) '() s rest-values))
  ...

あとはvaluesで返した値の数がreceiveで受け取る数より少なかったり、restパラメータの処理とかは適宜。

ヒープベースには簡単に追加できるけど、スタックベースにも同様に追加できるでしょう。

Javaで作ってるやつのパッチはこちら

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

2009-04-13

セルフホスティングのコンパイラが動いた!

3impのコンパイラは元の論文どおりSchemeで書いて、VM部だけCで作った。でコンパイラで自分自身(ちょっと変えてるけど)をコンパイルしてバイトコードにしてCのVMで動かしたら、CのVMとコンパイル済みのバイトコードのみでSchemeのソースをコンパイルして実行できるようになった!

うまく動いてなかった原因は、GCにBoehmGCを使ってるんだけど、内部に別のポインタを指すメンバを持つ構造体なのに間違ってアトミックとしてmallocしていたため、そいつの内部で指してるまだ使ってるオブジェクトがガベコレされてしまっていたせいだった。あんがい…正確です…。

あと引数チェックを省略するように実行時に書き換えるとおかしくなるケースがあるようなのでいったん保留。

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

2009-04-01

if の条件式中の and, or, not の最適化

PAIP 23章 Compiling Lisp の中に、(if (and p q) x y) としたときに (and p q) がマクロで (if p q nil) に展開されて評価するので無駄が出る、ということが書いてある。確かに。

同じことが3impのコンパイラで吐き出した命令にも発生する。こっちの場合は合成命令を試したときと同様に、吐き出されたバイトコードのパターンマッチで簡単に解決できるな、と思ってやってみた。

and

(CONST #f TEST then . else) の並びがあったらelseのみに書き換えればOK。

;;元の式
(if (and p q) x y)
;;マクロ展開
(if (if p q #f) x y)
;;コンパイル
(GREF p TEST (GREF q . #0=(TEST (GREF x . #1=(RET)) GREF y . #1#)) CONST #f . #0#)
;;最適化後
(GREF p TEST (GREF q TEST (GREF x . #0=(RET)) GREF . #1=(y . #0#)) GREF . #1#)

pが偽だった場合はCONST #f TEST ~がなくなって直接 GREF y になっている。

or

同様に or もやってみる。or の場合は最初のテストに成功したら次のテストは省くようにする。

;;元の式
(if (or p q) x y)
;;マクロ展開
(if ((lambda (G277) (if G277 G277 q)) p) x y)
;;コンパイル
(GREF p ARG EXPAND 1 LREF 0 TEST (LREF 0 . #0=(SHRINK 1 TEST (GREF x . #1=(RET)) GREF y . #1#)) GREF q . #0#)
;;最適化後
(GREF p ARG EXPAND 1 LREF 0 TEST (SHRINK 1 . #0=(GREF x . #1=(RET))) GREF q SHRINK 1 TEST #0# GREF y . #1#)

SHRINKが2か所になってしまうけど、比較回数は減ってるはず。不要な一時変数自体作成しないようにしたいけど、簡単にはいかなかったのでとりあえず。

not

調子に乗ってnotも。notはマクロじゃなくて関数なので、not呼び出し→TEST だったら条件を入れ替えるようにする。

;;元の式
(if (not p) x y)
;;コンパイル
(FRAME (GREF p ARG GREF not APPLY 1) TEST (GREF x . #0=(RET)) GREF y . #0#)
;;最適化後
(GREF p TEST (GREF y . #0=(RET)) GREF x . #0#)

本当は not が書き換えられてないか調べないといけないけど。

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

2009-03-29

beginをマクロから文法に変更

今までbeginは空のラムダ関数に変更するマクロ (begin a b c) => (lambda () a b c) で実装してたんだけど、lambda 式内の internal-define を実装するとbegin内部でdefineしたものが外部から見れなくなってしまうので、文法として追加するように変更。

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

2009-03-18

実行時の命令書き換えを試してみる

3impのVMでフィボナッチを動かすと、そのほとんどがグローバル環境に定義されている関数を呼び出す時に行われるハッシュテーブルの参照に費やされてることがわかる。C言語とかのコンパイラで実行ファイルにした場合はリンク時にアドレスが解決されてるので関数呼び出しのコストは純粋にスタック操作の分だけだろうけど、スクリプト言語・VMではそうはいかないということをあらためて認識した。

で実行時にグローバル変数の参照の命令が現れたら初回は普通にハッシュテーブルから検索して場所を特定して、以降はコードを書き換えて直接、ではないんだけどハッシュ検索は省くようにしてみた。そうしたらかなり速くなった!

すると今度は関数呼び出し時に引数の数をチェックしてるのが目立つようになった。これも毎回行う必要はないので同じように書き換えて初回だけ引数のチェックをして以降はチェックしないようにしてみた。これもまあまあ速くなった。ただこれをすると、後から関数を書き換えて引数の数を変更してもチェックされないのでエラーが出ない罠。

Inspiron mini 9(Atom 1.6GHz)、Linuxでfib(35)を測った結果:

命令書き換えなし20.194s
GLOC12.106s
GLOC+PAPPLY10.225s
Gauche7.964s
Ypsilon5.673s
Mosh0.0.813.144s
gcc -O30.204s
Ruby1.9.027.251s
Perl5.8.81m32.834s
Python2.5.225.857s
Lua5.1.412.177s
Squirrel2.2.222.010s
Xtal0.9.9.016.143s

Windows、Core2で動かした時とはだいぶ結果が違うなぁ。gcc -O3を見るとスクリプトがバカらしくなってくるな…。Common Lispでも試したいんだけど、処理系の使い方がまだわからない。

フィボナッチ以外のベンチもしてみないとね。

2009-03-17

合成命令を試してみる

3impの最適化のテストなんぞ。コンパイルした結果を見ると、+などのグローバルの関数参照→APPLYで呼び出し、とか定数宣言→引数としてスタックに積む、みたいなパターンが多いのでその辺をまとめたらステップ数も減るし効果あるのかどうか試してみる。

コンパイルして吐き出されたS式をGauchematchを使ってこれこれのパターンだったらこれこれに置き換える、という単純なもの。命令を置き換えるときに新しいリストに置き換えてしまうと循環参照などが保てなくなってしまうので破壊的操作で。

(use util.match) 

(define-macro (replace-rule code . ls)
  `(match ,code
          ,@(map (lambda (e)
                   `((,@(car e) . %rest) (values ,(caddr e) %rest)))
                 ls)
          (else (values #f code))))


;;;; 置き換えルール
(define (get-replace-rule code)
  (replace-rule code
                (('GREF f 'APPLY n) => `(GREF-APPLY ,f ,n))
                (('GREF f 'SHIFT m 'APPLY n) => `(GREF-SHIFT-APPLY ,f ,n))
                (('SHIFT m 'APPLY n) => `(SHIFT-APPLY ,n))
                (('CONST obj 'ARG) => `(CONST-ARG ,obj))
                ))


(define optbl
  '((HALT ())
    (LREF (n . $x))
    (FREF (n . $x))
    (GREF (sym . $x))
    (UNBOX $x)
    (CONST (obj . $x))
    (CLOSE (argnum n $body . $x))
    (BOX (n . $x))
    (TEST ($then . $else))
    (LSET (n . $x))
    (FSET (n . $x))
    (GSET (sym . $x))
    (CONTI (tail$ . $x))
    (NUATE (stack . $x))
    (FRAME ($x . $ret))
    (ARG $x)
    (SHIFT (n . $x))
    (APPLY (argnum))
    (RET ())
    (EXPAND (argnum . $x))
    (SHRINK (n . $x))
    ))

(define *h* (make-hash-table))

(dolist (e optbl)
  (let ((sym (car e))
        (args (cadr e)))
    (hash-table-put! *h* sym args)))

(define (next-ops code)
  (define (op? sym)
    (eq? (string-ref (symbol->string sym) 0)
         #\$))
  (define (check sym x f)
    (if (op? sym)
        (f x)
      (f #f)))
  (define (scons x xs)
    (if x (cons x xs) xs))
  
  (let* ((op (car code))
         (e (and (hash-table-exists? *h* op)
                 (hash-table-get *h* op))))
    (if e
        (reverse!
         (let loop ((p e)
                    (q (cdr code))
                    (acc '()))
           (cond ((pair? p)
                  (check (car p) (car q)
                         (lambda (x) (loop (cdr p) (cdr q) (scons x acc)))))
                 ((null? p) acc)
                 (else
                  (check p q
                         (lambda (x) (scons x acc)))))))
      '())))

(define (replace pair newpair)
  (set-car! pair (car newpair))
  (set-cdr! pair (cdr newpair)))

(define (optimize! code)
  (when (not (null? code))
    (receive (rep rest) (get-replace-rule code)
             (if rep
                 (replace code (append rep (optimize! rest)))
               (begin
                 (dolist (x (next-ops code))
                   (optimize! x))))))
  code)

(define (main args)
  (until (read) eof-object? => code
    (optimize! code)
    (write/ss code)
    (newline)))

で試した結果…あまり効果なかったので(1分30秒→1分28秒とか)、こういう最適化はまだ後回しでいいかな、という感じ。

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

2009-03-09

caseマクロが動かなかったのを修正

BOX

元は

(index-set! s n (box (index s n)))

とs相対でアクセスしてるけど、DIRECT-INVOKEを追加したのでCLOSE直後に呼ばれるとは限らなくなりsとfがずれてる可能性があるので、f相対に変更。

lambdaのコンパイル

元の論文だとlambda式のコンパイル時に内部で使われるフリー変数の列挙が

      (let ((free (set-intersect (find-frees bodies proper-vars)
                                 (set-union (car e)
                                            (cdr e))))

という順になってるけど、これだと列挙される並び順がlambdaの入れ子ごとに逆順になってしまう。DIRECT-INVOKE時にはフリー変数をキャプチャしなおさないので同じ並びになってないとまずい。ので

      (let ((free (set-intersect (set-union (car e)                 ; 入れ替え
                                            (cdr e))
                                 (find-frees bodies proper-vars)))  ; 入れ替え

という並び順に変更。

デバッグ大変だお。

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

2009-03-08

生駒3imp読書会に参加

生駒読書会#3 参加者:orken, naoya_t, yuki_neko_nyan, momo_dev, 私, sano(敬称略、登録順)

なんか結構まったりとして不思議な会だった。集まるけど各自思い思いのことをするという感じで、自分としてはみんなで本を輪講するよりは全然よかった。輪講するとどうしても時間がかかってしまうので。

私は事前に4章まで一通り写経は終わってて4.7.2のDirect Function Invocation時に親フレームがあるかないかを実行時に判定するのは事実上無理なのでトップにフレームを作るようして必ずフレームが存在するように変更したのが朝までの時点。読書会ではそのスタック操作のバグを修正して一応動くようになった。それが原因ではなかったみたいだけどcall/ccを使った非決定性のプログラムも動くようになった。

で次の改善に手を出そうと思って4.7.3末尾再帰最適化は難しそうだから4.7.4クロージャのヒープ割り当て回避ができるかどうか考えた。たとえば(map (lambda (x) ...) ls)とかのラムダ式をスタック上に取りたいよなぁとか考えてたらそれまでの実装がmapが実装側言語であるGaucheのmapを呼び出していたことが判明した。applyも。mapやapplyに渡る関数は被実装側のクロージャなので確実に動かないはずなんだけどどうなってたんだろう?これらを被実装言語側で定義するよう修正。

改善は手軽に手を出せそうになかったので、ここまでの実装でメタサーキュラーができるかどうかやってみた。するとcompile関数で真っ先に必要になるrecord-case内で使われるcaseマクロで使われる名前つきletがうまく動いてないことが判明。原因を調べてたけどわからず。

そんな具合で読書会は終了。なかなか有意義な一日でした。みなさまありがとうございました。

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

2009-03-06

3impのcall/ccでやっぱりエラーが出る

3impの4.6スタックベース最終版でcall/ccを使うとちゃんと動かない場合がある。誰か同じ現象にあってないかな、、、と思ってググると過去に自分で書いていた。さすが俺!ていうかなんでやったこと忘れてまた同じことしてるのか…。

これでよしと思ったんだけど、The 90 Minute Scheme to C compilerに出てくる非決定性のプログラム

(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))))

を動かそうとするとちゃんと動かない。NUATE時にスタックが壊れてるっぽいんだけどまだちゃんと確認できてない。

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

2009-03-04

3impの処理系にラムダ関数の直接呼出しを追加

3impの4章のスタックベースの処理系で、4.7「できそうな改善」の 2.「関数直接呼出し」を実装した。

コンパイル時:関数適用の関数がソース上で直接のlambda式だった場合*1に、まず普通の関数呼び出しと同じように引数をARGUMENTでスタックに積んでいくコードを生成。関数は普通の CLOSE→APPLY で無駄なクロージャを作って呼び出す代わりに新規に追加した DIRECT-INVOKE→lambdaの本体埋め込みというバイトコードを生成。関数本体はひとつ上の環境のローカル変数を自身の仮引数で拡張してコンパイル。本体の最後では通常 RETURN のところをこれまた新規に追加した RETURN-DIRECT というオペコードで戻るようにした。

実行時:DIRECT-INVOKE で直接呼出し用の引数をフレームのローカル変数と同様に扱えるように結合。普通のフレームと同じ形になるようにする、これによって末尾呼び出しだった場合は RETURN で普通に戻れる。RETURN-DIRECT ではスタックを操作して一時的に追加したローカル変数を取り除く。

これで let とかある程度気兼ねなく使えますわ。

  • ToDo: コンパイル時に引数の数のチェックをする、restパラメータがあった場合の処理

*1: ((lambda (params...) body...) args...) のような形

g000001g0000012009/03/05 12:173impで思い出したのですが、今週の日曜日に3impを読む「生駒読書会」があるようです。
http://www.slideshare.net/naoya_t/shibuyalisp-tt2-opening?type=presentation
の「おまけ」参照
http://atnd.org/events/350
自分は参加しませんが、mokeheheさんにぴったりかなと思いました(*'-')

mokehehemokehehe2009/03/05 21:08おお、それはすごい会ですね!参加してみようかしら。

naoya_tnaoya_t2009/03/08 00:12こんばんは、生駒読書会主催のnaoya_tです。明日はちょうどその辺りをやります。
slimy hackathon中のg000000001さん勧誘活動どうもありがとうございます。

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

2008-12-15

BiwaSchemeに任意長引数を追加したい

BiwaSchemeで任意長の引数を扱えなかったのだけど、define-macro追加のためにどうしても欲しかったので、stackbase.jsに手を加えてみました。よかったら反映していただけるとありがたいです。一応 spec.html を走らせてテストはパスすることは確認しました。以下、diffです:

*** stackbase.org.js	Mon Dec 15 20:26:56 2008
--- stackbase.js	Mon Dec 15 21:57:11 2008
***************
*** 639,644 ****
--- 639,645 ----
        switch(this.value){
          case '\n': return "#\\newline";
          case ' ':  return "#\\space";
+         case '\t': return "#\\tab";
          default:   return "#\\"+this.value;
        }
      },
***************
*** 818,823 ****
--- 819,826 ----
            return Char.get('\n');
          } else if( t.toLowerCase() == '#\\space' ) {
            return Char.get(' ');
+         } else if( t.toLowerCase() == '#\\tab' ) {
+           return Char.get('\t');
          } else if( /^#\\.$/.test(t) ) {
            return Char.get( t.charAt(2) );
          } else if( /^\"(\\(.|$)|[^\"\\])*\"?$/.test(t) ) {
***************
*** 1035,1040 ****
--- 1038,1096 ----
          return ret;
      },
  
+     find_dot_pos: function(x){
+       var idx = 0;
+       for (; x instanceof Pair && x != nil; x = x.cdr, ++idx)
+         ;
+       if (x != nil) {
+         return idx;
+       } else {
+         return -1;
+       }
+     },
+ 
+     last_pair: function(x){
+       if (x instanceof Pair && x != nil){
+         for (; x.cdr instanceof Pair && x.cdr != nil; x = x.cdr)
+           ;
+       }
+       return x;
+     },
+ 
+     // dotted list -> proper list
+     dotted2proper: function(ls){
+       var nreverse = function(ls){
+         var res = nil;
+         for (; ls instanceof Pair && ls != nil; ){
+           var d = ls.cdr;
+           ls.cdr = res;
+           res = ls;
+           ls = d;
+         }
+         return res;
+       }
+       var copy_list = function(ls){
+         var res = nil;
+         for (; ls instanceof Pair && ls != nil; ls = ls.cdr){
+           res = new Pair(ls.car, res);
+         }
+         return nreverse(res);
+       }
+ 
+       if (ls instanceof Pair) {
+         var last = this.last_pair(ls);
+         if (last instanceof Pair && last.cdr == nil){
+           return ls;
+         } else {
+           var copied = copy_list(ls);
+           this.last_pair(copied).cdr = new Pair(last.cdr, nil);
+           return copied;
+         }
+       } else {
+         return new Pair(ls, nil);
+       }
+     },
+ 
      // x: exp(list of symbol or integer or..)
      // e: env (= [locals, frees])
      // s: vars might be set!
***************
*** 1093,1110 ****
              var vars = x.cdr.car;
              var body = new Pair(Sym("begin"), x.cdr.cdr); //tenuki
  
!             var free = this.find_free(body, vars.to_set(), f); //free variables
!             var sets = this.find_sets(body, vars.to_set()); //local variables
  
              var do_body = this.compile(body,
!                             [vars.to_set(), free],
                              sets.set_union(s.set_intersect(free)),
!                             f.set_union(vars.to_set()),
!                             ["return", vars.length()]);
              var do_close = ["close", 
                               free.size(),
!                              this.make_boxes(sets, vars, do_body),
!                              next];
              return this.collect_free(free, e, do_close);
            case Sym("if"):
              var testc=x.second(), thenc=x.third(), elsec=x.fourth();
--- 1149,1169 ----
              var vars = x.cdr.car;
              var body = new Pair(Sym("begin"), x.cdr.cdr); //tenuki
  
!             var dotpos = this.find_dot_pos(vars);
!             var proper = this.dotted2proper(vars);
!             var free = this.find_free(body, proper.to_set(), f); //free variables
!             var sets = this.find_sets(body, proper.to_set()); //local variables
  
              var do_body = this.compile(body,
!                             [proper.to_set(), free],
                              sets.set_union(s.set_intersect(free)),
!                             f.set_union(proper.to_set()),
!                             ["return"]);
              var do_close = ["close", 
                               free.size(),
!                              this.make_boxes(sets, proper, do_body),
!                              next,
!                              dotpos];
              return this.collect_free(free, e, do_close);
            case Sym("if"):
              var testc=x.second(), thenc=x.third(), elsec=x.fourth();
***************
*** 1126,1134 ****
              var c = ["conti", 
                        (this.is_tail(next) ? next[1] : 0), //number of args for outer lambda
                        ["argument",
                          this.compile(x, e, s,f,  
!                           (this.is_tail(next) ? ["shift", 1, next[1], ["apply", 1]]
!                                               : ["apply", 1]))]];
                      //note: proc for call/cc takes 1 argument (= ["apply", 1])
              return this.is_tail(next) ? c : ["frame", c, next];
            default: 
--- 1185,1195 ----
              var c = ["conti", 
                        (this.is_tail(next) ? next[1] : 0), //number of args for outer lambda
                        ["argument",
+                       ["constant", 1,
+                       ["argument",
                          this.compile(x, e, s,f,  
!                           (this.is_tail(next) ? ["shift", 1, ["apply"]]
!                                               : ["apply"]))]]]];
                      //note: proc for call/cc takes 1 argument (= ["apply", 1])
              return this.is_tail(next) ? c : ["frame", c, next];
            default: 
***************
*** 1139,1146 ****
              var func = x.car;
              var args = x.cdr;
              var c = this.compile(func, e, s,f,  
!                       this.is_tail(next) ? ["shift", args.length(), next[1], ["apply", args.length()]]
!                                          : ["apply", args.length()]);
              for(var p=args; p instanceof Pair && p!=nil; p=p.cdr){
                c = this.compile(p.car, e, s, f, ["argument", c]);
              }
--- 1200,1208 ----
              var func = x.car;
              var args = x.cdr;
              var c = this.compile(func, e, s,f,  
!                       this.is_tail(next) ? ["shift", args.length(), ["apply"]]
!                                          : ["apply"]);
!             c = this.compile(args.length(), e, s, f, ["argument", c]);  // 引数の数をスタックに積む
              for(var p=args; p instanceof Pair && p!=nil; p=p.cdr){
                c = this.compile(p.car, e, s, f, ["argument", c]);
              }
***************
*** 1248,1258 ****
      //ret: closure array
      continuation: function(s, n){
        // note: implementation of this function for final version doesn't exist in 3imp.pdf..
        return this.closure(["refer-local", 0,
!                             ["nuate", this.save_stack(s), 
!                             ["return", n]]], 
                            0,     //n (number of frees)
!                           null); //s (stack position to get frees)
      },
  
      // shift stack 
--- 1310,1322 ----
      //ret: closure array
      continuation: function(s, n){
        // note: implementation of this function for final version doesn't exist in 3imp.pdf..
+       var ss = this.push(n, s);
        return this.closure(["refer-local", 0,
!                             ["nuate", this.save_stack(ss), 
!                             ["return"]]], 
                            0,     //n (number of frees)
!                           null,  //s (stack position to get frees)
!                           -1);   // dotpos
      },
  
      // shift stack 
***************
*** 1260,1285 ****
      // m: number of items to shift
      // s: stack pointer (= index of stack top + 1)
      shift_args: function(n, m, s){
!       for(var i = n-1; i >= 0; i--){
!         this.index_set(s, i+m, this.index(s, i));
        }
!       return s-m;
      },
  
      index: function(s, i){
!       return this.stack[s-i-1];
      },
  
      index_set: function(s, i, v){
!       this.stack[s-i-1] = v;
      },
  
!     //ret: [body, stack[s-1], stack[s-2], ..]
!     closure: function(body, n, s){
!       var v = []; //(make-vector n+1)
        v[0] = body;
        for(var i=0; i<n; i++)
!         v[i+1] = this.index(s, i);
        return v;
      },
  
--- 1324,1350 ----
      // m: number of items to shift
      // s: stack pointer (= index of stack top + 1)
      shift_args: function(n, m, s){
!       for(var i = n-1; i >= -1; i--){
!         this.index_set(s, i+m+1, this.index(s, i));
        }
!       return s-m-1;
      },
  
      index: function(s, i){
!       return this.stack[s-i-2];
      },
  
      index_set: function(s, i, v){
!       this.stack[s-i-2] = v;
      },
  
!     //ret: [body, stack[s-1], stack[s-2], .., stack[s-n], dotpos]
!     closure: function(body, n, s, dotpos){
!       var v = []; //(make-vector n+1+1)
        v[0] = body;
        for(var i=0; i<n; i++)
!         v[i+1] = this.index(s, i-1);
!       v[n+1] = dotpos;
        return v;
      },
  
***************
*** 1328,1335 ****
            a = obj;
            break;
          case "close":
!           var n=x[1], body=x[2], x=x[3];
!           a = this.closure(body, n, s);
            s -= n;
            break;
          case "box":
--- 1393,1401 ----
            a = obj;
            break;
          case "close":
!           var ox=x;
!           var n=ox[1], body=ox[2], x=ox[3], dotpos=ox[4];
!           a = this.closure(body, n, s, dotpos);
            s -= n;
            break;
          case "box":
***************
*** 1376,1389 ****
            s = this.push(a, s);
            break;
          case "shift":
!           var n=x[1], m=x[2], x=x[3];
!           s = this.shift_args(n, m, s);
            break;
          case "apply": //extended: n_args as second argument
!           var func = a, n_args = x[1];
            if(func instanceof Array){ //closure
              a = func;
              x = func[0];
              f = s;
              c = a;
            }
--- 1442,1473 ----
            s = this.push(a, s);
            break;
          case "shift":
!           var n=x[1], x=x[2];
!           var n_args = this.index(s, n);  // 一つ前の呼び出しの引数の数
!           s = this.shift_args(n, n_args, s);
            break;
          case "apply": //extended: n_args as second argument
!           var func = a; //, n_args = x[1];
!           var n_args = this.index(s, -1);  // 直前に引数の数を積んである
            if(func instanceof Array){ //closure
              a = func;
              x = func[0];
+             var dotpos = func[func.length-1];  // 仮引数のドットの位置
+             if (dotpos >= 0) {  // 任意個の引数を処理
+               var ls = nil;
+               for (var i=n_args; --i>=dotpos; ) {
+                 ls = new Pair(this.index(s, i), ls);
+               }
+               if (dotpos >= n_args) {
+                 // rest 用の領域がない:スタックをずらす
+                 for(var i = -1; i < n; i++){
+                   this.index_set(s, i-1, this.index(s, i));
+                 }
+                 s++;
+                 this.index_set(s, -1, this.index(s, -1) + 1);  // 引数の数を増やす
+               }
+               this.index_set(s, dotpos, ls);
+             }
              f = s;
              c = a;
            }
***************
*** 1396,1402 ****
  
              if(result instanceof Pause){
                var pause = result;
!               pause.set_state(this, ["return", n_args], f, c, s);
                pause.ready();
                return pause;
              }
--- 1480,1486 ----
  
              if(result instanceof Pause){
                var pause = result;
!               pause.set_state(this, ["return"], f, c, s);
                pause.ready();
                return pause;
              }
***************
*** 1411,1421 ****
                //   x
                var call_after = ["frame",
                                   ["argument",
                                   ["constant", result.after,
!                                  ["apply", 1]]],
!                                ["return", n_args]];
!               var call_proc = ["constant", result.proc, 
!                               ["apply", result.args.length]];
                var push_args = result.args.inject(call_proc, function(opc, arg){
                  // (foo 1 2) => first push 2, then 1
                  //   [constant 2 ... [constant 1 ... ]
--- 1495,1509 ----
                //   x
                var call_after = ["frame",
                                   ["argument",
+                                  ["constant", 1,
+                                  ["argument",
                                   ["constant", result.after,
!                                  ["apply"]]]]],
!                                ["return"]];
!               var call_proc = ["constant", result.args.length,
!                               ["argument",
!                               ["constant", result.proc, 
!                               ["apply", result.args.length]]]];
                var push_args = result.args.inject(call_proc, function(opc, arg){
                  // (foo 1 2) => first push 2, then 1
                  //   [constant 2 ... [constant 1 ... ]
***************
*** 1429,1435 ****
              }
              else{
                a = result;
!               x = ["return", n_args];
              }
            }
            else{
--- 1517,1523 ----
              }
              else{
                a = result;
!               x = ["return"];
              }
            }
            else{
***************
*** 1437,1448 ****
            }
            break;
          case "return":
!           var n=x[1];
!           var ss=s-n; 
            x = this.index(ss, 0),
            f = this.index(ss, 1),
            c = this.index(ss, 2),
!           s = ss-3;
            break;
          default:
            throw new Bug("unknown opecode type: "+x[0]);
--- 1525,1536 ----
            }
            break;
          case "return":
!           var n=this.index(s, -1);
!           var ss=s-n;
            x = this.index(ss, 0),
            f = this.index(ss, 1),
            c = this.index(ss, 2),
!           s = ss-3-1;
            break;
          default:
            throw new Bug("unknown opecode type: "+x[0]);
***************
*** 1585,1591 ****
        args || (args = []);
        var n_args  = args.length;
  
!       var x = ["constant", closure, ["apply", n_args]]
        for(var i=0; i<n_args; i++)
          x = ["constant", args[i], ["argument", x]]
  
--- 1673,1679 ----
        args || (args = []);
        var n_args  = args.length;
  
!       var x = ["constant", n_args, ["argument", ["constant", closure, ["apply"]]]]
        for(var i=0; i<n_args; i++)
          x = ["constant", args[i], ["argument", x]]
  

修正した内容は:

  • lambda の仮引数リストがドットリストだったらその位置を記録、なければ -1
    • フリー変数、セットされる変数の列挙時にその変数も考慮に入れる
  • 手続き呼び出し時に呼び出されたクロージャ側で与えられた引数の数を知りたいので、引数の数をスタックの一番最後に積むように変更
    • それにともなって、スタックの参照を変更
  • 呼び出された手続きが任意個の引数を取る手続きだったら、残りの引数をリストにしてスタック上のローカル変数の値を変更する
    • スペースがない可能性があるので、その場合はスタックをずらす
  • 手続きへの引数の数はスタックに積んであるので、return, apply, shift のパラメータを削除
  • continuation 作成時に、return用に外のlambdaの引数をスタックに積むように変更

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-13

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

| 08:42

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

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

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