From a49631ce9185a362f48bb31578287fbe705f9ee6 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Mon, 17 Sep 2007 22:57:13 +0200
Subject: Cache the return values of RETRIEVE-METHOD-SIGNATURE-INFO.

darcs-hash:17a199077cab37197bbcbc48d58100c4dd73e76e
---
 Lisp/internal-utilities.lisp | 26 ++++++++++++++++++++++++++
 Lisp/method-invocation.lisp  |  4 +++-
 2 files changed, 29 insertions(+), 1 deletion(-)

diff --git a/Lisp/internal-utilities.lisp b/Lisp/internal-utilities.lisp
index 818c18b..4e9d481 100644
--- a/Lisp/internal-utilities.lisp
+++ b/Lisp/internal-utilities.lisp
@@ -75,3 +75,29 @@
     (if (find-symbol "FOREIGN-FUNCALL-POINTER" '#:cffi)
         `(cffi:foreign-funcall-pointer ,pointer ,options ,@args)
         `(cffi:foreign-funcall (,pointer ,@options) ,@args))))
+
+
+;; Caching of function values.
+(defmacro define-cached-function (name lambda-list hashing-form &body body)
+  "Define a function and cache its result in a hash table.  The hash key
+is computed according to HASHING-FORM.
+
+Note that HASHING-FORM is expected to return a freshly consed object
+that can be garbage collected.  It is not recommended to use an atom as
+a HASHING-FORM if the value of the atom might itself be an interned atom
+or any other value that might never be deleted by the garbage
+collector."
+  (let ((hash-table (gensym))
+        (value (gensym))
+        (default-value (gensym))
+        (hash-key (gensym)))
+    `(let ((,hash-table (tg:make-weak-hash-table :weakness :key
+                                                 :test 'equal)))
+       (defun ,name ,lambda-list
+         (let* ((,hash-key ,hashing-form)
+                (,value (gethash ,hash-key ,hash-table ',default-value)))
+           (if (eq ',default-value ,value)
+               (values-list
+                (setf (gethash ,hash-key ,hash-table)
+                      (multiple-value-list (progn ,@body))))
+               (values-list ,value)))))))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 4c5abac..d851f63 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -275,7 +275,9 @@ Returns: *result* --- the return value of the method invocation.
                                            return-c-type)))))))))))
 
 
-(defun retrieve-method-signature-info (class selector)
+(define-cached-function retrieve-method-signature-info (class selector)
+    (cons (cffi:pointer-address (pointer-to class))
+          (cffi:pointer-address (pointer-to selector)))
   (let* ((signature (primitive-invoke class
                                       :instance-method-signature-for-selector
                                       'id
-- 
cgit v1.2.3