Sat Feb 20 18:24:36 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Cache overload resolution on sbcl
diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp
--- old-smoke/src/clos.lisp 2014-10-30 07:05:07.000000000 +0100
+++ new-smoke/src/clos.lisp 2014-10-30 07:05:07.000000000 +0100
@@ -461,9 +461,11 @@
(defun call-constructor (class arguments)
(multiple-value-bind (method sequence)
- (find-best-viable-function (constructor-name class)
- arguments
- class)
+ (#-sbcl find-best-viable-function
+ #+sbcl find-best-viable-function-cached
+ (constructor-name class)
+ arguments
+ class nil)
(when (null method)
(error "No constructor for class ~A with
the arguments ~S." class arguments))
diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp
--- old-smoke/src/objects/type.lisp 2014-10-30 07:05:07.000000000 +0100
+++ new-smoke/src/objects/type.lisp 2014-10-30 07:05:07.000000000 +0100
@@ -119,14 +119,15 @@
;; For efficiency just check if the first byte is a null byte;
;; No need to convert the entire C string to lisp like in:
;; (null (name type)))
+ (declare (optimize (speed 3)))
(null-pointer-p (mem-ref
- (foreign-slot-pointer
- (mem-aref (smoke-array-pointer
- (smoke-module-types (smoke type)))
- 'smoke-type
- (the smoke-index (id type)))
- 'smoke-type 'name)
- :pointer)))
+ (foreign-slot-pointer
+ (mem-aref (smoke-array-pointer
+ (smoke-module-types (smoke type)))
+ 'smoke-type
+ (the smoke-index (id type)))
+ 'smoke-type 'name)
+ :pointer)))
(defgeneric get-class (smoke-symbol)
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:07.000000000 +0100
+++ new-smoke/src/overload-resolution.lisp 2014-10-30 07:05:08.000000000 +0100
@@ -195,24 +195,27 @@
conversion2
conversion1)))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun conversion-function (name &optional arg)
- (if arg
- `(if (using-typep)
- `(,,name
- (find-class ',(class-name ,arg)))
- #'(lambda (object)
- (funcall (fdefinition ,name)
- object ,arg)))
- `(if (using-typep)
- ,name
- (fdefinition ,name)))))
-
(defmacro make-match (type &optional (name ''identity) (argument nil)
&rest args)
- `(,(symbolicate 'make- (eval type))
- :function-name ,(conversion-function name argument)
- ,@args))
+ (flet ((conversion-function (name &optional arg)
+ (if arg
+ `(if (using-typep)
+ `(,,name
+ ,(if (typep ,arg 'class)
+ `(find-class ',(class-name ,arg))
+ `(find-smoke-method (find-class ,(class-name
+ (find-smoke-class
+ (get-class ,arg))))
+ ,(name ,arg))))
+ #'(lambda (object)
+ (funcall (fdefinition ,name)
+ object ,arg)))
+ `(if (using-typep)
+ ,name
+ (fdefinition ,name)))))
+ `(,(symbolicate 'make- (eval type))
+ :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
@@ -304,7 +307,11 @@
collect `(setf (gethash ,type-name *from-lisp-translations*)
#'(lambda (type type-p)
(and (if type-p
- (subtypep type ',lisp-type)
+ (multiple-value-bind (value valid-p)
+ (subtypep type ',lisp-type)
+ (unless valid-p
+ (throw 'unspecific-type type))
+ value)
(typep type ',lisp-type))
',conversion-function-name))))))
@@ -337,8 +344,10 @@
(9 (object.typep '(c-integer :unsigned-long)))
(10 (object.typep 'single-float))
(11 (object.typep 'double-float))
- (12 (and (object.typep 'enum) ;; FIXME enum-type using type
- (smoke-type= type (enum-type object))))
+ (12 (when (object.typep 'enum)
+ (when (using-typep)
+ (throw 'unspecific-type object))
+ (smoke-type= type (enum-type object))))
(13 (and (object.typep 'smoke-standard-object)
(smoke-type= (get-class type) (object.type-of))))))
@@ -518,18 +527,21 @@
(type (or smoke-standard-class smoke-standard-object)
object-or-class))
(multiple-value-bind (method sequence)
- (find-best-viable-function name
- arguments
- (smoke-class-of object-or-class)
- (when (typep object-or-class
- 'smoke-standard-object)
- (const-p object-or-class)))
+ (#-sbcl find-best-viable-function
+ #+sbcl find-best-viable-function-cached
+ name
+ arguments
+ (smoke-class-of object-or-class)
+ (when (typep object-or-class
+ 'smoke-standard-object)
+ (const-p object-or-class)))
(when (null method)
(error (make-condition 'no-applicable-cxx-method
:method name
:class object-or-class
:arguments arguments)))
- (if (static-p method)
- (apply #'call-sequence method (null-pointer) sequence arguments)
- (apply #'call-sequence method (cast object-or-class (get-class method))
- sequence arguments))))
+ (apply #'call-sequence method
+ (if (static-p method)
+ (null-pointer)
+ (cast object-or-class (get-class method)))
+ sequence arguments)))
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:07.000000000 +0100
+++ new-smoke/src/sb-optimize.lisp 2014-10-30 07:05:08.000000000 +0100
@@ -92,23 +92,38 @@
sequence argument-names)))))))))))
-;;; cache ==================================================================
+;;; Cache overload resolution / method lookup
+
+;;; FIXME the cached lookup should be faster
+;;;
+;;; cache return value conversion
+;;;
+;;; Using the gf symbol instead of the method name would be better,
+;;; althoug we would have to invent one for constructors.
;;;
-;;; 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.
+;;; Since the -using-types stuff was intended for for compile time
+;;; expansion it is not that well suited for this. i.e. passing
+;;; closures would be better than the actual syntax.
+;;;
+;;; For qt.tests the uncached calls make up 30 % of all calls.
+;;; qt.examples:colliding-mice (run for ~1 min) gets 20 % uncached
+;;; calls and qt.examples:class-browser get 10 %. (20 February 2010)
-(sb-int:defun-cached (find-best-viable-function-using-types-cached
+(sb-int:defun-cached (find-best-viable-function-using-layouts-cached
:hash-function (lambda (name arguments
class const-p)
(declare (string name)
(list arguments)
- (class class)
+ (sb-c::layout class)
(boolean const-p))
(logand
(logxor
(sxhash name)
- (sxhash arguments)
+ (the fixnum
+ (reduce
+ #'logxor
+ (mapcar #'sb-c::layout-clos-hash
+ arguments)))
(sxhash class)
(sxhash const-p))
#x1FF))
@@ -117,25 +132,28 @@
(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)
+ (find-best-viable-function-using-types
+ name (mapcar #'sb-pcl::wrapper-class* arguments)
+ class const-p)
(list method (mapcar #'(lambda (s)
(if (symbolp s)
(fdefinition s)
#'(lambda (x)
+ (declare (optimize (speed 3)))
(funcall (fdefinition (first s))
x
- (second s)))))
+ (eval (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
+ (find-best-viable-function-using-layouts-cached
name
- (mapcar #'(lambda (o) (class-of o)) arguments)
+ (mapcar #'(lambda (o) (sb-c::layout-of o)) arguments)
class
const-p))))
(find-best-viable-function name arguments class const-p))