Implicit Function Currying with Automatic Partial Evaluation

関数の部分適用と部分評価を自動的に行うマクロの実装を、日本語と Scheme で示していきます。

動機

前回 fun と fn という、Standard ML ライクなカリー化関数の構文をご紹介しました。とても便利で既に多用しているんですが、一つどうしても気になるのは、コードが無駄にコピーされてしまう点です。

例えば

(fn (x y z)
  (* (+ x y) z))

という関数は次のように展開されてしまいます:

(case-lambda
 ((x)
  (case-lambda
   ((y)
    (lambda (z)
      (* (+ x y) z)))
   ((y z)
    (* (+ x y) z))))
 ((x y)
  (lambda (z)
    (* (+ x y) z)))
 ((x y z)
  (* (+ x y) z)))

元の定義の本体部分があちこちに散らばっていますよね。これだとせっかく部分適用ができても、完全に適用されるまで本体の評価が持ち越されることになります。

この関数の場合、x と y が与えられた時点で (+ x y) は計算可能ですから、その部分は評価しちゃって欲しいところです。このままだと部分適用した関数を map 等で何度も利用する場合にあまり嬉しくありません。

具体的には、こういう式展開をしてくれれば良いなと思うわけです:

(case-lambda
 ((x)
  (case-lambda
   ((y)
    (let ((g1 (+ x y)))
      (lambda (z)
        (* g1 z))))
   ((y z)
    (* (+ x y) z))))
 ((x y)
  (let ((g2 (+ x y)))
    (lambda (z)
      (* g2 z))))
 ((x y z)
  (* (+ x y) z)))

方針

まず何をどうするかが問題ですが、基本的には上の展開例のように、与えられた引数のみに依存する式を関数本体から探し出し、評価し、その値で置き換えてやれば良いと思われます。

ただ、実際には評価を行うのは実行時なので、評価を行うための let 構文を埋め込むというコード変形を行うことになります。

例えば g1 の部分に注目していただくと、そこのスコープでは x と y が参照可能ですから、本体から x と y の計算式を抜き取り、ラムダの外に追い出して評価しています。これで一度だけの評価で済みますね。

この一度だけというのがポイントで、もし if 文の中にあってプログラム実行中に一度も評価されない可能性がある式は、部分評価の対象外とすべきでしょう。

実装

ところで、Lisp のプログラムと言えばリスト (ツリー) ですよね。ツリーの探索や置換と言えば、zipper を思い出します。ということで、zipper で使ったツリー探索の仕組みをコード変形に適用することにします。

こういうのです:

;; Adapted from: http://okmij.org/ftp/Scheme/zipper-in-scheme.txt
(define (map* f l)
  (if (not (pair? l))
      l
      (cons (f (car l)) (map* f (cdr l)))))

(define (depth-first handle tree)
  (cond ((not (pair? tree)) tree)       ; an atom
        ((handle tree) => values)
        (else                    ; the node was not handled -- descend
         (map* (lambda (kid)
                 (depth-first handle kid))
               tree))))

depth-first を使って式を探索し、置換可能な部分が見つかればその都度変数で置き換えていく、というのが基本戦略となります。

ただ、関数本体はマクロのパターンマッチで取得するので、初めはシンタックス・オブジェクトというデータ型になっています。それをツリー構造に展開する関数が必要です:

(define (syntax->tree x stop?)
  (cond ((stop? x) x)
        ((syntax? x)
         (syntax->tree (syntax-e x) stop?))
        ((pair? x)
         (cons (syntax->tree (car x) stop?)
               (syntax->tree (cdr x) stop?)))
        (else x)))

使用例:

> (syntax->tree #'(* (+ x y) 1) identifier?)
(#<syntax::229>
 (#<syntax::232> #<syntax::234> #<syntax::236>)
 1)

depth-first とは別に、ツリー内部を検索する関数も必要になります:

(define (stx-search p? stx)
  (cond ((p? stx) #t)
        ((stx-pair? stx)
         (or (stx-search p? (stx-car stx))
             (stx-search p? (stx-cdr stx))))
        (else #f)))

(stx-pair? とかは PLT Scheme のライブラリ関数です)

「まだ与えられていない引数」および「関数本体で導入されるレキシカル変数」は参照することが出来ないため、これらに依存する式は評価できません (コンパイル時に unbound variable エラーになります)。

なので、置換可能な式を探索する際に、式の中に参照不可能な変数が含まれていないかチェックしなければなりません。

そしてそのチェックのためには、予めレキシカル変数をコードから抽出しておく必要があります:

(define (match-vars stx)
  (kernel-syntax-case stx #f
    ((define-values (v ...) e ...)
     (syntax->list #'(v ...)))
    ((#%plain-lambda (v ...) e ...)
     (syntax->list #'(v ...)))
    ((case-lambda (v e ...) ...)
     (append-map syntax-e (syntax->list #'(v ...))))
    ((let-values ((v x) ...) e ...)
     (append-map syntax-e (syntax->list #'(v ...))))
    ((letrec-values ((v x) ...) e ...)
     (append-map syntax-e (syntax->list #'(v ...))))
    ((set! v e) (list #'v))
    (else '())))

(define (collect-vars stx)
  (cond ((pair? stx)
         (append (collect-vars (car stx))
                 (collect-vars (cdr stx))))
        ((syntax? stx)
         (append (match-vars stx)
                 (collect-vars (syntax-e stx))))
        (else '())))

関数本体のコードに collect-vars を適用すると、再帰的にレキシカル変数のリストが得られるようになっています。set! で変更される変数もついでに捕捉しておきます。

メイン部分に入っていきましょう。

(define-syntax (fn stx)
  (syntax-case stx ()
    ((fn params . exp)
     (kernel-syntax-case
         (call-with-values
             (lambda ()
               (syntax-local-expand-expression #'(lambda params . exp)))
           (lambda (stx _) stx))
         #f
       ((#%plain-lambda params . exp)
        (make-cases (cons #'begin
                          (map (lambda (e)
                                 ;; Keep protected exp intact
                                 (if (protected? e)
                                     e
                                     (syntax->tree e identifier?)))
                               (syntax->list #'exp)))
                    (syntax->list #'params)
                    (collect-vars #'exp)))))))

前のバージョンとの違いの一つは、パターンマッチで得た関数本体 (exp) を local-expand でフル展開しているところです。これは、receive とか and-let* のような派生構文を全て展開してコアの構文のみにするためです。おかげで match-vars の定義が楽になります。

ただ、これには少し厄介な問題も伴います。フルにマクロ展開をしてしまうと、モジュール内部のエクスポートされていない識別子が展開形の中に出てきてしまう場合があるのです。

この問題に対し、PLT Scheme では、そのような識別子を含む構文オブジェクトに封印のような仕掛けを施しており、少しでも手を加えると封印が破れたことが検知され、コンパイル・エラーが出るようになっています (参照: Fwd: module security)。

というわけで、封印の掛かっている構文オブジェクトは次の関数でチェックし、部分評価の対象から外さなければいけません。

(define (protected? stx)
  (stx-search (lambda (x)
                (and (syntax? x)
                     (syntax-property x 'protected)))
              stx))

カリー化定義の本体はこのようになりました:

(define (make-cases exp params locals)
  (cond ((null? params) exp)
        ((null? (cdr params))
         #`(lambda #,params #,exp))
        (else
         #`(case-lambda
             #,@(map (lambda (i)
                       (let-values (((bound-params rest-params)
                                     (split-at params (+ i 1))))
                         (if (null? rest-params)
                             #`(#,bound-params #,exp)
                             (let*-values
                                 (((residue ev-binds)
                                   (peval exp (append rest-params locals)))
                                  ((exp2)
                                   (make-cases residue rest-params locals)))
                               #`(#,bound-params
                                  #,(if (pair? ev-binds)
                                        #`(let #,ev-binds #,exp2)
                                        exp2))))))
                     (iota (length params)))))))

peval という関数を呼び出している点が前回と異なります。residue と ev-binds という2値を返す関数です。後者はその部分適用の時点で評価可能な式と、それに束縛される変数の組のリストです。前者は部分評価をした後の、小さくなった関数本体を表します。

peval を再帰的に呼び出す度に残りの計算が少なくなっていく、ということが期待できるわけです。

(define (peval exp unbound)
  (let ((binds '()))
    (values (depth-first
             (lambda (e)
               (cond ((ignore-form? e) e)          ;avoid descent
                     ((side-effect? e) #f)         ;just descend
                     ((free-from? e unbound)
                      (let ((g (gensym)))
                        (set! binds (cons #`(#,g #,e) binds))
                        g))
                     (else #f)))
             exp)
            (reverse binds))))

ここで depth-first の使い方を説明しておきましょう。

第1引数の関数で第2引数に含まれるノードを順次受け取っていきます。そして返値として #f を返せばノードに変更を加えず、それ以外の値を返すとノードがその値で置き換えられる仕組みです。

いずれの場合もそれ以降の探索は続行されるんですが、#f の場合はそのノードの下位ノードへと降りていくのに対し、#f 以外の場合は次のノードに進むという違いがあります。

peval においては、構文木の中から簡約可能な式を見つける上で、その下降とかスキップを適宜行っているわけです (if 文は無視して次に進む、等)。

そして簡約可能な式が見つかると、部分評価のためのバインディング #`(#,g #,x) を記録しつつ変数 g で置き換えていきます。

以下 depth-first 中の条件判断の関数です:

(define (operator exp)
  (and (pair? exp)
       (let ((x (car exp)))
         (and (identifier? x)
              (pair? (identifier-binding x))
              (syntax-e x)))))

(define (application? exp)
  (cond ((operator exp)
         => (lambda (op)
              (and (eq? op '#%app)
                   (let ((proc (cadr exp)))
                     (if (syntax? proc)
                         (syntax-e proc)
                         proc)))))
        (else #f)))

(define (free-from? exp unbound)
  (and (application? exp)
       (not
        (stx-search (lambda (id)
                      (and (identifier? id)
                           (ormap (lambda (ng)
                                    (or (bound-identifier=? ng id)
                                        (free-identifier=? ng id)))
                                  unbound)))
                    exp))))

(define (ignore-form? exp)
  (let ((forms-to-ignore
         '(if quote quote-syntax with-continuation-mark
           #%top #%variable-reference)))
    (cond ((operator exp)
           => (lambda (op) (memq op forms-to-ignore)))
          (else #f))))

(define (side-effect? exp)
  (let ((side-effecting-procs
         '(dynamic-require sleep thread kill-thread
           call/cc call-with-current-continuation
           call-with-continuation-prompt
           ;; and much more ...
           )))
    (stx-search (lambda (e)
                  (cond ((application? e)
                         => (lambda (op) (memq op side-effecting-procs)))
                        (else #f)))
                exp)))

実装は一応以上です。ソース: curry.ss

利用例

実例を手元で実際に動かしているものから抜粋します:

(fun (nicovideo user watch)
  (login (lookup 'mail user) (lookup 'pass user))
  (make-immutable-hasheq
   (let ((vid (video-id watch)))
     `((video_id . ,vid)
       ,@(let ((api-url (string->url (api vid))))
           (call/input-url api-url
             get-pure-port
             (lambda (in)
               ;; We need to extend cookie with view history prior to
               ;; further activities
               (view-page watch)
               (form-urlencoded->alist (port->string in)))
             (list (make-cookie-header api-url))))))))

これはニコ動ダウンローダの一部で、セッションIDを取得して動画の情報を得る関数です。実際の動画やコメントのダウンロードには別の関数を組み合わせて使います。

カリー化により第1引数 (ユーザー情報の連想リスト) が先に与えられると、その時点で最初のログインの式が評価されます。したがって、このように

(map (compose nico-download
              (nicovideo '((mail . "mail@address") (pass . "passwd"))))
     '("http://www.nicovideo.jp/watch/sm5003587"
       "http://www.nicovideo.jp/watch/sm2143250"
       "http://www.nicovideo.jp/watch/sm5008319"))

複数の動画を一気にダウンロードする時でも、ログインは1回で済むわけです。

部分評価が無ければ呼び出しの回数分だけログインしてしまうところですから、大きなメリットと言って良いでしょう。

問題点

最後に幾つか問題点を挙げておきます。

第1に、評価順の問題です。

begin のような構文であっても、式の並び順で評価が行われるとは限りません。簡約可能な式が後ろの方にあるとそれが先に評価されてしまう、という事が起こり得るわけです。

次に、副作用の問題があります。

ニコ動の例においては、ログインが1回で済むというのは一見望ましい振る舞いのように思えます。が、一般に副作用を起こす関数が1回の評価で良いのか、何度も評価されて欲しいのか、というのは実は非常に微妙な問題だと思います。

また、評価順の問題とも絡んで、副作用を伴う式が意図しない順序で評価されると、プログラムが正しく動作しなくなる事もあります。

第3に、継続や dynamic-wind 等の特殊な制御構造に干渉しないよう注意を払わなければなりません。

最後に、どこかで変更されるかもしれないグローバル変数やパラメータ、あるいはダイナミック変数をキャッシュしてしまう可能性も考慮する必要があるでしょう。

なお、これらは全てマクロの実装者側が留意すべき事柄であり、ユーザー側は何も考えなくても勝手に最適化が行われる、というのが理想です。