0.8.0.44:

	Fix amazingly horrendous bug in constant-dfun generation (thanks
	to Gerd Moellmann)
	... when the method combination isn't standard, method functions
		might not be effective methods.
	... in constant-value-miss, aver that we are finding a
		constant-value.
	... test case from Paul Dietz

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 066585c..2acc37e 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -557,21 +557,41 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
           (default '(unknown)))
       (and (null applyp)
           (or (not (eq *boot-state* 'complete))
-              (compute-applicable-methods-emf-std-p gf))
-          (notany (lambda (method)
-                    (or (and (eq *boot-state* 'complete)
-                             (some #'eql-specializer-p
-                                   (method-specializers method)))
-                        (let ((value (method-function-get
-                                      (if early-p
-                                          (or (third method) (second method))
-                                          (or (method-fast-function method)
-                                              (method-function method)))
-                                      :constant-value default)))
-                          (if boolean-values-p
-                              (not (or (eq value t) (eq value nil)))
-                              (eq value default)))))
-                  methods)))))
+              ;; If COMPUTE-APPLICABLE-METHODS is specialized, we
+              ;; can't use this, of course, because we can't tell
+              ;; which methods will be considered applicable.
+              ;;
+              ;; Also, don't use this dfun method if the generic
+              ;; function has a non-standard method combination,
+              ;; because if it has, it's not sure that method
+              ;; functions are used directly as effective methods,
+              ;; which CONSTANT-VALUE-MISS depends on.  The
+              ;; pre-defined method combinations like LIST are
+              ;; examples of that.
+              (and (compute-applicable-methods-emf-std-p gf)
+                   (eq (generic-function-method-combination gf)
+                       *standard-method-combination*)))
+          ;; Check that no method is eql-specialized, and that all
+          ;; methods return a constant value.  If BOOLEAN-VALUES-P,
+          ;; check that all return T or NIL.  Also, check that no
+          ;; method has qualifiers, to make sure that emfs are really
+          ;; method functions; see above.
+          (dolist (method methods t)
+            (when (eq *boot-state* 'complete)
+              (when (or (some #'eql-specializer-p
+                              (method-specializers method))
+                        (method-qualifiers method))
+                (return nil)))
+            (let ((value (method-function-get
+                          (if early-p
+                              (or (third method) (second method))
+                              (or (method-fast-function method)
+                                  (method-function method)))
+                          :constant-value default)))
+              (when (or (eq value default)
+                        (and boolean-values-p
+                             (not (member value '(t nil)))))
+                (return nil))))))))
 
 (defun make-constant-value-dfun (generic-function &optional cache)
   (multiple-value-bind (nreq applyp metatypes nkeys)
@@ -1036,17 +1056,19 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 (defun constant-value-miss (generic-function args dfun-info)
   (let ((ocache (dfun-info-cache dfun-info)))
     (dfun-miss (generic-function args wrappers invalidp emf nil nil t)
-      (cond (invalidp)
-           (t
-            (let* ((function (typecase emf
-                               (fast-method-call (fast-method-call-function
-                                                  emf))
-                               (method-call (method-call-function emf))))
-                   (value (method-function-get function :constant-value))
-                   (ncache (fill-cache ocache wrappers value)))
-              (unless (eq ncache ocache)
-                (dfun-update generic-function
-                             #'make-constant-value-dfun ncache))))))))
+      (unless invalidp
+       (let* ((function
+               (typecase emf
+                 (fast-method-call (fast-method-call-function emf))
+                 (method-call (method-call-function emf))))
+              (value (let ((val (method-function-get
+                                 function :constant-value '.not-found.)))
+                       (aver (not (eq val '.not-found.)))
+                       val))
+              (ncache (fill-cache ocache wrappers value)))
+         (unless (eq ncache ocache)
+           (dfun-update generic-function
+                        #'make-constant-value-dfun ncache)))))))
 \f
 ;;; Given a generic function and a set of arguments to that generic
 ;;; function, return a mess of values.

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 8e6d414..ec1f012 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -638,5 +638,28 @@
 (assert (typep (allocate-instance (find-class 'allocatable-structure))
               'allocatable-structure))
 \f
+;;; Bug found by Paul Dietz when devising CPL tests: somewhat
+;;; amazingly, calls to CPL would work a couple of times, and then
+;;; start returning NIL.  A fix was found (relating to the
+;;; applicability of constant-dfun optimization) by Gerd Moellmann.
+(defgeneric cpl (x)
+  (:method-combination list)
+  (:method list ((x broadcast-stream)) 'broadcast-stream)
+  (:method list ((x integer)) 'integer)
+  (:method list ((x number)) 'number)
+  (:method list ((x stream)) 'stream)
+  (:method list ((x structure-object)) 'structure-object))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl (make-broadcast-stream))
+              '(broadcast-stream stream structure-object)))
+(assert (equal (cpl (make-broadcast-stream))
+              '(broadcast-stream stream structure-object)))
+(assert (equal (cpl (make-broadcast-stream))
+              '(broadcast-stream stream structure-object)))
+\f
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index ba26d22..ac56de0 100644 (file)
--- 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".)
-"0.8.0.43"
+"0.8.0.44"