パーサーコンビネータの性能向上について

自前の XML パーサーやウェブ・スクレイピングなどにパーサーコンビネータ・ライブラリを使っているんですが、どうも実行速度が遅いのが気になってきたので、原因を考えてみました。

で、気付いたんですが、例えばこのようなパーサーを定義した時に、

(doP (char #\a) (char #\A) (char #\B))

パーサーを実行する度に (char #\a) のような関数適用が新たに評価されてしまうことが一つの原因ではないかと思いました。

そこで、関数適用の形になっているパーサーは1回だけ評価してキャッシュしておくことで、実行効率の向上を図ることにしました。

(以下 Gauche の PEG ライブラリの実装を参考にさせていただきましたが、少し工夫を加えた部分もあります。)

大まかなイメージとしては、上記のパーサーの場合

(let ((tmp1 (char #\a))
      (tmp2 (char #\A))
      (tmp3 (char #\B)))
  (lambda (input)
    ...))

のような形に展開し、入力ストリームを受け取るラムダの外側にパーサーをキャッシュしておけば良いわけです (内側だと毎回評価してしまいます)。

ただし、上と同じ意味のパーサーでも、次のように変数束縛を伴う定義の場合には問題が生じます。

(doP (a <- (char #\a))
     (A <- (char (char-upcase a)))
     (char (integer->char (+ (char->integer A) 1))))

同じように展開してしまうと

(let ((tmp1 (char #\a))
      (tmp2 (char a))
      (tmp3 (char (integer->char (+ (char->integer A) 1)))))
  (lambda (input)
    ...))

どこにもバインドされていない変数 (a, A) を参照することになり、エラーになってしまうんです。

話を具体的にするために、別の例を出しましょう。引用符に囲まれた文字列を取り出すパーサーを考えてみます:

(doP (q <- (one-of (string->list "\"'")))
     (s <- (many-till (none-of (list q))
                      (char q)))
     (return (list->string s)))

この場合、1行目のパーサーは意味が変わらないのでキャッシュしたいんですが、2つ目のパーサーは q の値によって意味が変わるので毎回評価しなければいけませんよね。

このように、キャッシュ出来るパーサーと出来ないパーサーがあるわけです。

この問題に対処するため、パーサー式を分析して、doP 構文内で束縛された変数を含む場合はキャッシュしないようにする方法を考えてみました。

bound-identifier=? という関数を使います。

(define (memvar exp vars)
  (and (pair? vars)
       (let bound? ((exp exp))
         (if (identifier? exp)
             (ormap (lambda (var)
                      (bound-identifier=? exp var))
                    vars)
             (let ((exps (syntax-e exp)))
               (and (pair? exps)
                    (ormap bound? exps)))))))

syntax-case マクロの中で呼び出す用の関数です。exp はパーサー式、vars は束縛変数のリストで、それぞれ型はシンタックス・オブジェクト、シンタックス・オブジェクトのリストです。

例えば exp として (char a) のような、変数を含む式を受け取った場合、変数 a が vars に含まれていれば #t を返します。

doP 構文を展開する際に束縛変数をリストに集めていき、パーサー式を見つける度に memvar 関数でそのリストと照合することで、束縛変数を参照しているかどうかが分かる仕組みです。

パーサー式が既に変数であるか、または束縛変数を参照していればそのままにしておき、それ以外であれば一時変数としてキャッシュする、という方針で doP 構文をこのように定義してみました:

(define-syntax (doP stx)
  (define (finish-body pre-binds var&parsers)
    (with-syntax
        ((parse-it
          (let loop ((input #'input) (var&parsers var&parsers))
            (if (null? (cdr var&parsers))
                (syntax-case (car var&parsers) (return)
                  ((return x) #`(values #f x #,input))
                  (p #`(p #,input)))
                (with-syntax ((input2 (gensym)))
                  (syntax-case (car var&parsers) (<-)
                    ((v <- p)
                     #`(receive (err v input2) (p #,input)
                         (if err
                             (values err v input2)
                             #,(loop #'input2 (cdr var&parsers)))))
                    (p
                     #`(receive (err v input2) (p #,input)
                         (if err
                             (values err v input2)
                             #,(loop #'input2 (cdr var&parsers)))))))))))
      #`(let #,pre-binds
          (lambda (input) parse-it))))
  (syntax-case stx ()
    ((doP p ...)
     (let loop ((pre-binds '())
                (var&parsers '())
                (bound-vars '())
                (clauses (syntax->list #'(p ...))))
       (if (null? clauses)
           (finish-body pre-binds (reverse var&parsers))
           (syntax-case (car clauses) (<- return)
             ((return x)
              (loop pre-binds
                    (cons #'(return x) var&parsers)
                    bound-vars
                    (cdr clauses)))
             ((v <- p)
              (if (or (identifier? #'p) (memvar #'p bound-vars))
                  (loop pre-binds
                        (cons #'(v <- p) var&parsers)
                        (cons #'v bound-vars)
                        (cdr clauses))
                  (with-syntax ((tmp (gensym)))
                    (loop (cons #'(tmp p) pre-binds)
                          (cons #'(v <- tmp) var&parsers)
                          (cons #'v bound-vars)
                          (cdr clauses)))))
             (p
              (if (or (identifier? #'p) (memvar #'p bound-vars))
                  (loop pre-binds
                        (cons #'p var&parsers)
                        bound-vars
                        (cdr clauses))
                  (with-syntax ((tmp (gensym)))
                    (loop (cons #'(tmp p) pre-binds)
                          (cons #'tmp var&parsers)
                          bound-vars
                          (cdr clauses)))))))))))

以前の実装では doP 構文はモナドの >>= 関数への糖衣構文だったので、パーサーとは独立の純粋に抽象的な定義だったんですが、この変更により doP マクロの中でパーサー連結の詳細を記述しなければいけなくなったのがちょっと残念です。

同じ事の定義が別々の場所にあるのは不自然なので、>>= の定義を逆に doP 構文に依存させるように変更しました:

(define (>>= p f)
  (doP (x <- p) (f x)))