Y combinator. そして末尾再帰に取り付かれる

不動点演算子といってラムダ計算やらコンビネータ理論やらのものらしいです。
ちゃんと調べてないのでよくわかってません(笑)

ただ、これを使うと無名関数を再帰することができる、ということです。

で自分で実装して考えてみる。
まずは再帰のお供、fact関数。

(defun fact (n)
  (if (<= n 1)
      1
    (* n (fact (- n 1)))))

末尾再帰にもなっていませんがとりあえず実装。
ここから進めていきましょう。
この関数をlambda関数にした場合、何が使えなくて再帰できないのか？
そう、関数名fact、というか関数自身です。

んじゃどうすればいける？と考えると・・・ないものは無いんで外部から差し込むしかないよなーということになります。
つまり自分自身を引数として受け取って(なんか話が矛盾してきた！(笑))それをfuncallすれば再帰できるはず、ということで定義したのが次のコード。

(lambda (f n)
  (if (<= n 1)
      1
    (* n (funcall f f (- n 1)))))

これで自分自身を渡せば再帰できるはず・・・んじゃどーやってlambda関数なのに自分自身を渡すの？と考えて・・・
自分自身と同じのをもう一度宣言してやればとOK？(そもそも関数の等値性とか等価性なんてよくわかりません！)と思ってやってみる。

(funcall
 (lambda (f n)
   (if (<= n 1)
       1
     (* n (funcall f f (- n 1)))))
 (lambda (f n)
   (if (<= n 1)
       1
     (* n (funcall f f (- n 1))))) 10)
3628800

おお、動いた！!

んじゃ後はこれとおなじことをしてくれる関数を用意してやればいいだけです。

(defun y-combinator (f &rest args)
  (apply f (cons f args)))

y-combinatorは関数を受け取り、それを呼び出す関数です。
とりあえず引数が複数あっても呼び出せるようにはしてみた。
試してないけど。

(y-combinator
 (lambda (f n)
   (if (<= n 1)
       1
     (* n (funcall f f (- n 1))))) 10)
3628800

おっけー!
とりあえずコンパイルしての実行も試してみたいので関数を返すy-combinatorもつくってみる。

(defun y (f)
  (lambda (&rest args)
    (apply f (cons f args))))

そして・・・tail-recursiveなfactも用意(ここからがメイン)。

(defun fact-tail-rec (n &optional (context 1))
  (if (<= n 1)
      context
    (fact-tail-rec (- n 1) (* context n))))

(disassemble (compile 'fact-tail-rec))
Disassembly of function FACT-TAIL-REC
(CONST 0) = 1
1 required argument
1 optional argument
No rest parameter
No keyword parameters
16 byte-code instructions:
0     L0
0     (JMPIFBOUNDP 1 L5)
3     (CONST 0)                           ; 1
4     (STORE 1)
5     L5
5     (LOAD&PUSH 2)
6     (CONST&PUSH 0)                      ; 1
7     (CALLSR&JMPIF 1 49 L22)             ; <=
11    (LOAD&DEC&PUSH 2)
13    (LOAD&PUSH 2)
14    (LOAD&PUSH 4)
15    (CALLSR&PUSH 2 55)                  ; *
18    (JMPTAIL 2 5 L0)
22    L22
22    (LOAD 1)
23    (SKIP&RET 3)

んむ。ちゃんと末尾再帰なのでループに変換されている様子(clispを使ってます)。

そしてlambda関数としてのfact-tail-recursiveに。

(lambda (f n &optional (context 1))
  (if (<= n 1)
      context
    (funcall f f (- n 1) (* context n))))

(funcall
 (y (lambda (f n &optional (context 1))
             (if (<= n 1)
                 context
               (funcall f f (- n 1) (* context n))))) 10)
=> 3628800 (#x375F00, #o15657400, #b1101110101111100000000)

そしてお楽しみのcompile & disassemble。

(disassemble
 (compile nil
          (y (lambda (f n &optional (context 1))
               (if (<= n 1)
                   context
                 (funcall f f (- n 1) (* context n)))))))
Disassembly of function NIL
(CONST 0) =
#(F #<FUNCTION :LAMBDA (F N &OPTIONAL (CONTEXT 1)) (IF (<= N 1) CONTEXT (FUNCALL F F (- N 1) (* CONTEXT N)))>
  NIL)
(CONST 1) = 1
0 required arguments
0 optional arguments
Rest parameter
No keyword parameters
11 byte-code instructions:
0     (CONST&PUSH 0)                      ; #(F #<FUNCTION :LAMBDA # #> NIL)
1     (CONST 1)                           ; 1
2     (SVREF)
3     (PUSH)
4     (CONST&PUSH 0)                      ; #(F #<FUNCTION :LAMBDA # #> NIL)
5     (CONST 1)                           ; 1
6     (SVREF)
7     (PUSH)
8     (LOAD 3)
9     (CONS)
10    (APPLY&SKIP&RET 0 2)

うーん、残念ながらtail recursiveとしてループ展開はされてないみたい。
declaimでunrollを強制とかしてやれば変わるのかしらん？

clispのバイトコードの解説はこちら。

lambda関数のままinline化の強制の仕方を知らないので名前に束縛してコンパイル。

(declaim (inline y-comb-fact-tail-rec))
(declaim (inline y))
(defun y-comb-fact-tail-rec (n)
  (declare (optimize speed))
  (funcall (y (lambda (f n &optional (context 1))
                            (if (<= n 1)
                                context
                              (funcall f f (- n 1) (* context n))))) n))

(disassemble (compile 'y-comb-fact-tail-rec))
Disassembly of function Y-COMB-FACT-TAIL-REC
(CONST 0) = #<COMPILED-FUNCTION Y-COMB-FACT-TAIL-REC-1>
(CONST 1) = Y
1 required argument
0 optional arguments
No rest parameter
No keyword parameters
5 byte-code instructions:
0     (CONST&PUSH 0)                      ; #<COMPILED-FUNCTION Y-COMB-FACT-TAIL-REC-1>
1     (CALL1&PUSH 1)                      ; Y
3     (LOAD&PUSH 2)
4     (FUNCALL 1)
6     (SKIP&RET 2)

だめ。末尾再帰のfactのdisassemble結果が出てこない。

さらにy-combinatorも展開して定義してみる(どんどん本末転倒な方向に)。

(defun y-comb-fact-tail-rec-2 (n)
  (let ((f (lambda (f n &optional (context 1))
                            (if (<= n 1)
                                context
                              (funcall f f (- n 1) (* context n))))))
    (funcall f f n)))
(compile 'y-comb-fact-tail-rec-2)
(disassemble 'y-comb-fact-tail-rec-2)

Disassembly of function Y-COMB-FACT-TAIL-REC-2
(CONST 0) = #<COMPILED-FUNCTION Y-COMB-FACT-TAIL-REC-2-1>
1 required argument
0 optional arguments
No rest parameter
No keyword parameters
6 byte-code instructions:
0     (CONST&PUSH 0)                      ; #<COMPILED-FUNCTION Y-COMB-FACT-TAIL-REC-2-1>
1     (LOAD&PUSH 0)
2     (LOAD&PUSH 1)
3     (LOAD&PUSH 4)
4     (FUNCALL 2)
6     (SKIP&RET 3)

だめ。中で中間結果の関数を作られてるなぁ・・・
disassembleしようとy-comb-fact-tail-rec-2-1を渡してみたけど、undefined-functionとつれない返事。

まえにこちらのYコンビネータの定義をlispに持ってきて(はい。とても参考になりました。というかwikipediaの数学系表記だと自分の雑な脳みそだと理解するのが厳しいです･･･)試したときも結局、末尾再帰には程遠い結果でした。

constとして関数定義を使いまわしているところをみるとy-combinatorに渡した関数自体は等価なものとしてみてくれてはいるような感じです。
ほかの処理系とかだとどーなんだろ？
結局のところ末尾再帰をループに展開する判定次第の気もしますが・・・

いや、Y-Combinatorで末尾再帰が出来たところで何がうれしいの？というのはあるんですけどね・・・普通にlabelsとか使ったほうがまだ現実的というか・・・