総称関数を高速化してみよう

gf-foo.lisp

総称関数を高速化してみよう(総称関数でない)

元ネタ

- http://www.doc.gold.ac.uk/~mas01cr/talks/
- http://www.doc.gold.ac.uk/~mas01cr/talks/2009-05-28%20Milan/string=-specializers.lisp

MOPでコード生成して高速化を図るらしい。
面白そうなので真似してみよう。

骨子としては、
discriminating-function-lambda でコード生成
compute-discriminating-functionで取り出しつつ
set-funcallable-instance-functionして新しいものに置き換え
というもの

(defpackage :no-dispatch
  (:use :cl :clos))

(in-package :no-dispatch)

(defclass typecase-generic-function (standard-generic-function)
  ()
  (:metaclass funcallable-standard-class))

(defun discriminating-function-lambda (methods gf)
  (let (clauses)
    (dolist (m methods)
      (let* ((type (car (method-specializers m)))
             (form `(funcall ,(method-function m) n nil)))
        (etypecase type
          (CONS (push `(,type ,form) clauses))
          #-lispworks
          (eql-specializer (push `((eql ,(eql-specializer-object type)) ,form) clauses))
          (CLASS (push `(,(class-name type) ,form) clauses)))))
    `(lambda (n)
       (etypecase n
         ,@clauses))))

(defmethod compute-discriminating-function
           ((gf typecase-generic-function))
  (lambda (n)
    (let* ((methods (generic-function-methods gf))
           (function (compiled-discriminating-function methods gf)))
      (set-funcallable-instance-function gf function)
      (funcall function n))))

(defun compiled-discriminating-function (methods gf)
  (compile nil (discriminating-function-lambda methods gf)))

;;;;;;;

fibを書いてみた

(locally
  (declare (optimize (speed 3) (safety 0) (debug 0)
                     (hcl:fixnum-safety 0)))
  (declare (ftype (function (fixnum) fixnum) fib))
  (defgeneric fib (n)
    (:generic-function-class typecase-generic-function))

  (defmethod fib ((n (eql 0))) 0)
  (defmethod fib ((n (eql 1))) 1)
  (defmethod fib ((n integer))
    (+ (fib (1- n))
       (fib (- n 2)))))

(time (fib 40))
Timing the evaluation of (fib 40)

User time    =        1.439
System time  =        0.000
Elapsed time =        1.437
Allocation   = 10888 bytes
0 Page faults

;;; 一応 ディスパッチなしのメソッド版

(defmethod fib/ (n)
  (declare (optimize (speed 3) (safety 0) (debug 0) ;; あまり効かない
                     (hcl:fixnum-safety 0)))
  (declare (fixnum n))
  (if (< n 2)
      n
      (+ (fib/ (1- n))
         (fib/ (- n 2)))))

(time (fib/ 40))
Timing the evaluation of (fib/ 40)

User time    =        1.647
System time  =        0.000
Elapsed time =        1.645
Allocation   = 10384 bytes
0 Page faults

色々あって速くない

中身
(discriminating-function-lambda 
 (generic-function-methods #'fib)
 #'fib)
→
(lambda (n)
  (etypecase n
    ((eql 0) (funcall #<Function (method fib ((eql 0))) 40600037B4> n nil))
    ((eql 1) (funcall #<Function (method fib ((eql 1))) 4060003A94> n nil))
    (fixnum (funcall #<Function (method fib (fixnum)) 4060003DBC> n nil)))) 
 
(let ((fib (compile nil (discriminating-function-lambda 
                         (generic-function-methods #'fib)
                         #'fib))))
  (defun fib* (n)
    (declare (fixnum n))
    (funcall fib n)))

(time (fib* 40))
Timing the evaluation of (fib* 40)

User time    =        1.560
System time  =        0.000
Elapsed time =        1.552
Allocation   = 26104 bytes
0 Page faults



思いきって切り詰めてみる。
compute-discriminating-function の詰め替え機能だけを利用する
(set-funcallable-instance-functionだけ利用するという手が最短だが……)

(defclass no-gf (standard-generic-function)
  ()
  (:metaclass funcallable-standard-class))

(defmethod compute-discriminating-function ((gf no-gf))
  (get (generic-function-name gf) 'no-gf))

(declare (ftype (function (fixnum) fixnum) fib-fun))
(defun fib-fun (n)
  (declare (optimize (speed 3) (safety 0) (debug 0)
                     (hcl:fixnum-safety 0)))
  (if (< n 2)
      n
      (+ (fib-fun (1- n))
         (fib-fun (- n 2)))))

(time (fib-fun 40))
Timing the evaluation of (fib-fun 40)

User time    =        0.852
System time  =        0.000
Elapsed time =        0.849
Allocation   = 9704 bytes
0 Page faults

(setf (get 'fib-no-gf 'no-gf) #'fib-fun)

(defgeneric fib-no-gf (n)
  (:generic-function-class no-gf))

(time (fib-no-gf 40))
Timing the evaluation of (fib-no-gf 40)

User time    =        0.780
System time  =        0.000
Elapsed time =        0.779
Allocation   = 8048 bytes
0 Page faults

速いがそれで良いのか、という感がある。

以上、丁寧にするなら
compute-discriminating-function
generic-function-methods
compute-applicable-methods
compute-applicable-methods-using-classes
の一連の流れに従って仕立てれば良いのかもしれない

# まとめ
* MOP〜AOPの応用例の一つとして実行効率の向上というものは初期から存在する
  (Kiczales先生の論文など参照)
* 実際の所はあまり耳にしない
* MOPでコード生成し、最適化を図る方法を紹介
* 実際の所、プロトコルに合せるのがめんどくさく、プロトコルに合せたことによるメリットが多い場合にしか役に立たなそう
* GFを差し替えるだけで大幅に速度が高速化する位でないとメリットが感じられない
* しかし動的にコンパイルしなおすというのは面白い
* とはいえ、レキシカル変数を捕捉するのが、面倒(もしくは不可能)だったりするので色々辻褄を合せるのが大変