writeがスタックを食いつぶす

Gaucheのソースツリーを眺めていて、writeがCのスタックを食いつぶすのを直したというようなコミットを見つけた。同じことが起きるよなぁと思いつつ、とりあえずテスト。以下は使用したコード(R7RS形式なのは最後にチェックしたのがChibiだから。当然Sagittariusでも動く)

(import (scheme base) (scheme write))
(define (call-with-string-output-port proc)
  (call-with-port (open-output-string)
    (lambda (p) 
      (proc p)
      (get-output-string p))))

(display
 (let loop ((cnt 0) (ls '()))
   (if (< cnt 1000000)
       (loop (+ cnt 1) (list ls))
       (string-length (call-with-string-output-port
                       (lambda (p) (display ls p))))))) 
(newline)

とりあえず、どのくらいの処理系がこれをSEGVを起こさず処理するのかチェック。以下は結果。

200002を正しく返した処理系

Chez Scheme, Racket (plt-r6rs), Larceny (R6RS)

SEGVもしくは処理が終わらなかった処理系

Sagittarius, Chibi, Mosh, Ypsilon

動く処理系で、ソースを確認できるのはRacketとLarcenyだけなので、とりあえず確認してみた。

Larcenyはなぜ動いているのか正直分からなかった。コードがSchemeで書かれているので、ひょっとしたら最適化でうまいこと動いているのか、Cで書いていない分スタックの消費が少なくなっているのかは不明。

Racketはスタックの底にたどり着いたらlongjmpするという荒業だった。たしかに、ありだよね。

Gaucheは0.9.4は再帰呼び出しをせず、gotoで済ますという方法。ただ、そのためにメモリを結構使用するんじゃないかなぁと思ったり。

Sagittariusは(ユニットテストの)メモリの使用量が半端ないので、可能な限り省エネで行きたいところ。なので、やるならRacket方式か、気合でなにか良い案思いつく必要がある。longjmpのオーバーヘッドってどれくらいなんだろう？

あまり良い案が思い浮かばないので、メモを兼ねて考えをまとめる。

基本的に問題になるのはペアとベクタである。ペアだけなら、car部分にペアがネストしていると困る。上記のコードは本質的に以下のものを出力しようとする。

(display '((((())))))

Cで実装されているwriteは以下のコードをこんな感じで処理する。

void write(object o, port p)
{
   if (pair_p(o)) {
     write(PAIR(o)->car, p);
     return write(PAIR(o)->cdr, p);
   }
} 

これは、cdr部分は末尾再帰なのでよほどヘボイコンパイラじゃない限りはgotoもしくはjmpになってスタックを消費しない。問題はcar部分。Scheme（というかLisp）のリストは要するに単純な２分木なのでこの問題をスタックまたはヒープを消費しないように解決する方法がない気がしてきた。
継続渡しだとどうだろう？先にcdr部分を継続としてラップしてしまって、処理はcar部分だけで終わらせる。たとえば、こんな感じで。

void write(object o, port p, cont k)
{
   if (pair_p(o)) {
     cont kk = make_cont(o, k);
     return write(PAIR(o)->car, p, kk);
   } else {
     print_simple_object(o); /* こいつはスタックを消費しない */
     return k();
   }
}

問題は、make_cont部分がほぼ確実にヒープを使うことか・・・やっぱり逃げ道はないか？

とりあえず、CLではどうなるだろうと、CLsipとSBCLで以下のコードを試してみた。

(print
 (let ((ls nil))
   (loop :for i :from 0 :to 1000000
         :do (setf ls (list ls))
         :finally (length (with-output-to-string (stream)
                            (print ls stream))))))

結果はどちらもスタックオーバーフロー。さすがだと思ったのは、どちらもSEGVにはならなかったこと。とりあえず例外投げるようにするか・・・