Tue Sep 1 13:44:21 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix overload resolution using types and test caching the overload resolution.
diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp
--- old-smoke/src/overload-resolution.lisp 2014-10-30 07:05:49.000000000 +0100
+++ new-smoke/src/overload-resolution.lisp 2014-10-30 07:05:49.000000000 +0100
@@ -140,7 +140,7 @@
make-number-conversion make-pointer-conversion
make-boolean-conversion make-user-conversion))
(defstruct conversion
- (function-name nil :type (or symbol function) :read-only t)
+ (function-name nil :type (or symbol list function) :read-only t)
(rank -1 :type fixnum :read-only t))
(defstruct (exact-match (:include conversion (rank 0))))
@@ -208,12 +208,11 @@
,name
(fdefinition ,name)))))
-(defmacro make-match (type &optional (name ''identity)
- (argument nil)
+(defmacro make-match (type &optional (name ''identity) (argument nil)
&rest args)
`(,(symbolicate 'make- (eval type))
- :function-name ,(conversion-function name argument)
- ,@args))
+ :function-name ,(conversion-function name argument)
+ ,@args))
(defun+using-type get-conversion-sequence object (object type &optional user)
"Retrains a conversion sequence to convert a instance of type CLASS
@@ -499,7 +498,8 @@
(condition-method condition)
(condition-class condition)
(condition-arguments condition)))))
-
+
+
(defun call-using-args (object-or-class name arguments)
"Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS."
(declare (optimize (speed 3)))
diff -rN -u old-smoke/src/sb-optimize.lisp new-smoke/src/sb-optimize.lisp
--- old-smoke/src/sb-optimize.lisp 2014-10-30 07:05:49.000000000 +0100
+++ new-smoke/src/sb-optimize.lisp 2014-10-30 07:05:49.000000000 +0100
@@ -90,3 +90,52 @@
(get-class method)))))))
(list ,@(sequence-form
sequence argument-names)))))))))))
+
+
+;;; cache ==================================================================
+;;;
+;;; we could replace the call to #'find-best-viable-function in
+;;; #'call-using-args with a call to
+;;; #'find-best-viable-function-cached, but it is only doubles speed.
+
+(sb-int:defun-cached (find-best-viable-function-using-types-cached
+ :hash-function (lambda (name arguments
+ class const-p)
+ (declare (string name)
+ (list arguments)
+ (class class)
+ (boolean const-p))
+ (logand
+ (logxor
+ (sxhash name)
+ (sxhash arguments)
+ (sxhash class)
+ (sxhash const-p))
+ #x1FF))
+ :hash-bits 9)
+ ((name equal) (arguments equal) (class eq) (const-p eq))
+ (declare (optimize (speed 3))
+ (inline find-best-viable-function-using-types))
+ (multiple-value-bind (method conversion-sequence)
+ (find-best-viable-function-using-types name arguments class const-p)
+ (list method (mapcar #'(lambda (s)
+ (if (symbolp s)
+ (fdefinition s)
+ #'(lambda (x)
+ (funcall (fdefinition (first s))
+ x
+ (second s)))))
+ conversion-sequence))))
+
+(declaim (inline find-best-viable-function-cached))
+(defun find-best-viable-function-cached (name arguments class const-p)
+ (declare (optimize (speed 3)))
+ (catch 'unspecific-type
+ (return-from find-best-viable-function-cached
+ (values-list
+ (find-best-viable-function-using-types-cached
+ name
+ (mapcar #'(lambda (o) (class-of o)) arguments)
+ class
+ const-p))))
+ (find-best-viable-function name arguments class const-p))
diff -rN -u old-smoke/src/using-type.lisp new-smoke/src/using-type.lisp
--- old-smoke/src/using-type.lisp 2014-10-30 07:05:49.000000000 +0100
+++ new-smoke/src/using-type.lisp 2014-10-30 07:05:49.000000000 +0100
@@ -13,7 +13,7 @@
`(,function-name ,@args))
(call-using-type (function-name &rest args)
`(,function-name ,@args)))
- ,@body))
+ ,@body))
(defun typep-using-type (object-type type)
"Returns true when OBJECT-TYPE is a subtype of TYPE,