From 0756ed4c948806fe79460b1da00c2487cb5ad82b Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sat, 7 Jun 2003 15:09:22 +0000 Subject: [PATCH] 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 --- src/pcl/dfun.lisp | 74 +++++++++++++++++++++++++++++++----------------- tests/clos.impure.lisp | 23 +++++++++++++++ version.lisp-expr | 2 +- 3 files changed, 72 insertions(+), 27 deletions(-) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 066585c..2acc37e 100644 --- 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))))))) ;;; 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 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -638,5 +638,28 @@ (assert (typep (allocate-instance (find-class 'allocatable-structure)) 'allocatable-structure)) +;;; 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))) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index ba26d22..ac56de0 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".) -"0.8.0.43" +"0.8.0.44" -- 1.7.10.4