From 46d8e06740236e41db254d95c6bdc662039d32f6 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 11 May 2007 11:55:42 +0000 Subject: [PATCH] 1.0.5.47: cacheability of EMFs from methods with non-standard specializers ... the second return value from COMPUTE-APPLICABLE-METHODS-USING-CLASSES promises that the first return value can be cached. It doesn't promise that an arbitrary computation on the specializers will work, so we need not to go down that codepath. ... so refuse to build dispatch discriminating functions if any method of the generic function has a non-standard (non-PCL-native) specializer, as operations such as SB-PCL::SPECIALIZER-CLASS and SB-PCL::TYPE-FROM-SPECIALIZER will fail on such specializers ... rework SPECIALIZER-CLASS-OR-NIL to call the new function STANDARD-SPECIALIZER-P. ... test case. --- src/pcl/dfun.lisp | 12 ++++- src/pcl/methods.lisp | 26 ++++++----- tests/mop-28.impure.lisp | 114 ++++++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 140 insertions(+), 14 deletions(-) create mode 100644 tests/mop-28.impure.lisp diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 0e816d0..3b5a599 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -606,10 +606,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 classes-list new-class))) (make-constant-value-dfun generic-function cache))) +(defun gf-has-method-with-nonstandard-specializer-p (gf) + (let ((methods (generic-function-methods gf))) + (dolist (method methods nil) + (unless (every (lambda (s) (standard-specializer-p s)) + (method-specializers method)) + (return t))))) + (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) (when (eq *boot-state* 'complete) (unless (or caching-p - (gf-requires-emf-keyword-checks gf)) + (gf-requires-emf-keyword-checks gf) + ;; DISPATCH-DFUN-COST will error if it encounters a + ;; method with a non-standard specializer. + (gf-has-method-with-nonstandard-specializer-p gf)) ;; This should return T when almost all dispatching is by ;; eql specializers or built-in classes. In other words, ;; return NIL if we might ever need to do more than diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index d9e2ac8..eeb37f9 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -610,7 +610,7 @@ )) (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer)) - nil) + (eql specl1 specl2)) (defmethod same-specializer-p ((specl1 class) (specl2 class)) (eq specl1 specl2)) @@ -633,17 +633,19 @@ ;;; RAISE-METATYPE; however, the list of methods is maintained by ;;; hand, which is error-prone. We can't just add a method to ;;; SPECIALIZER-CLASS, or at least not with confidence, as that -;;; function is used elsewhere in PCL. -- CSR, 2007-05-10 -(defmethod specializer-class-or-nil ((specializer specializer)) - nil) -(defmethod specializer-class-or-nil ((specializer eql-specializer)) - (specializer-class specializer)) -(defmethod specializer-class-or-nil ((specializer class)) - (specializer-class specializer)) -(defmethod specializer-class-or-nil ((specializer class-eq-specializer)) - (specializer-class specializer)) -(defmethod specializer-class-or-nil ((specializer class-prototype-specializer)) - (specializer-class specializer)) +;;; function is used elsewhere in PCL. `STANDARD' here is used in the +;;; sense of `comes with PCL' rather than `blessed by the +;;; authorities'. -- CSR, 2007-05-10 +(defmethod standard-specializer-p ((specializer class)) t) +(defmethod standard-specializer-p ((specializer eql-specializer)) t) +(defmethod standard-specializer-p ((specializer class-eq-specializer)) t) +(defmethod standard-specializer-p ((specializer class-prototype-specializer)) + t) +(defmethod standard-specializer-p ((specializer specializer)) nil) + +(defun specializer-class-or-nil (specializer) + (and (standard-specializer-p specializer) + (specializer-class specializer))) (defun error-need-at-least-n-args (function n) (error 'simple-program-error diff --git a/tests/mop-28.impure.lisp b/tests/mop-28.impure.lisp new file mode 100644 index 0000000..3298ba9 --- /dev/null +++ b/tests/mop-28.impure.lisp @@ -0,0 +1,114 @@ +;;;; miscellaneous side-effectful tests of the MOP + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; a test of a non-standard specializer class and non-standard +;;; generic function class, which nevertheless admit the cacheing +;;; strategy implicit in the second return value of +;;; compute-applicable-methods-using-classes. + +(load "assertoid.lisp") + +(defpackage "OR-SPECIALIZER-TEST" + (:use "CL" "SB-MOP" "ASSERTOID")) + +(in-package "OR-SPECIALIZER-TEST") + +(defclass or-specializer (specializer) + ((classes :initform nil :reader or-specializer-classes :initarg :classes) + (direct-methods :initform nil :reader specializer-direct-methods))) + +(defvar *or-specializer-table* (make-hash-table :test 'equal)) + +(defun ensure-or-specializer (&rest classes) + ;; FIXME: duplicate hash values + (let* ((cs (mapcar (lambda (x) (if (symbolp x) (find-class x) x)) classes)) + (sorted-classes (sort cs #'< :key #'sxhash))) + (or (gethash sorted-classes *or-specializer-table*) + (setf (gethash sorted-classes *or-specializer-table*) + (make-instance 'or-specializer :classes sorted-classes))))) + +(defclass gf-with-or (standard-generic-function) () + (:metaclass funcallable-standard-class)) + +(defmethod compute-applicable-methods-using-classes + ((generic-function gf-with-or) classes) + ;; FIXME: assume one-argument for now + (let (applicable-methods) + (let ((methods (generic-function-methods generic-function))) + (dolist (m methods) + (let ((specializer (car (method-specializers m))) + (class (car classes))) + (typecase specializer + (class (when (subtypep class specializer) + (push m applicable-methods))) + (eql-specializer + (when (eql (class-of (eql-specializer-object specializer)) + class) + (return-from compute-applicable-methods-using-classes + (values nil nil)))) + (or-specializer + (dolist (c (or-specializer-classes specializer)) + (when (subtypep class c) + (push m applicable-methods)))))))) + ;; FIXME: sort the methods + (values applicable-methods t))) + +(defmethod compute-applicable-methods + ((generic-function gf-with-or) arguments) + ;; FIXME: assume one-argument for now + (let (applicable-methods) + (let ((methods (generic-function-methods generic-function))) + (dolist (m methods) + (let ((specializer (car (method-specializers m))) + (argument (car arguments))) + (typecase specializer + (class (when (typep argument specializer) + (push m applicable-methods))) + (eql-specializer + (when (eql (eql-specializer-object specializer) argument) + (push m applicable-methods))) + (or-specializer + (dolist (c (or-specializer-classes specializer)) + (when (typep argument c) + (push m applicable-methods)))))))) + ;; FIXME: sort the methods + applicable-methods)) + +(defmethod add-direct-method ((specializer or-specializer) method) + (pushnew method (slot-value specializer 'direct-methods))) + +(defmethod remove-direct-method ((specializer or-specializer) method) + (setf (slot-value specializer 'direct-methods) + (remove method (slot-value specializer 'direct-methods)))) + +;;; FIXME: write SPECIALIZER-DIRECT-GENERIC-FUNCTIONS method + +(defclass class1 () ()) +(defclass class2 () ()) +(defclass class3 () ()) +(defclass class4 (class1) ()) + +(defgeneric foo (x) + (:generic-function-class gf-with-or)) + +(let ((specializer (ensure-or-specializer 'class1 'class2))) + (eval `(defmethod foo ((x ,specializer)) t))) + +(assert (foo (make-instance 'class1))) +(assert (foo (make-instance 'class2))) +(assert (raises-error? (foo (make-instance 'class3)))) +(assert (foo (make-instance 'class4))) + +;;; check that we are actually cacheing effective methods. If the +;;; representation in PCL changes, this test needs to change too. +(assert (typep (cddr (sb-pcl::gf-dfun-state #'foo)) 'sb-pcl::caching)) diff --git a/version.lisp-expr b/version.lisp-expr index 521b791..d06bb98 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.5.46" +"1.0.5.47" -- 1.7.10.4