Sat Feb 20 18:24:36 CET 2010 Tobias Rautenkranz * 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-24 10:42:18.000000000 +0200 +++ new-smoke/src/clos.lisp 2014-10-24 10:42:18.000000000 +0200 @@ -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-24 10:42:18.000000000 +0200 +++ new-smoke/src/objects/type.lisp 2014-10-24 10:42:18.000000000 +0200 @@ -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-24 10:42:18.000000000 +0200 +++ new-smoke/src/overload-resolution.lisp 2014-10-24 10:42:18.000000000 +0200 @@ -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-24 10:42:18.000000000 +0200 +++ new-smoke/src/sb-optimize.lisp 2014-10-24 10:42:18.000000000 +0200 @@ -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))