From: Christophe Rhodes Date: Wed, 2 Nov 2005 17:53:36 +0000 (+0000) Subject: 0.9.6.11: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7cde9fabcd145901785a468a87108f7d9c4291fc;p=sbcl.git 0.9.6.11: Fixed vicious metacircle bug on multiple subclasses of standard-generic-function. ... implement Gerd Moellmann's error message from cmucl-imp 2005-05-29; ... be a little more disciplined over slot accesses from within dfun computation; ... uncomment a bunch of test cases, and write a specific test case. --- diff --git a/NEWS b/NEWS index a899569..10af208 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,8 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-0.9.7 relative to sbcl-0.9.6: + * bug fix: it is now possible to have more than one subclass of + STANDARD-GENERIC-FUNCTION without causing stack overflow. + (reported by Bruno Haible, Pascal Costanza and others) * bug fix: *COMPILE-FILE-PATHNAME* now contains the user's pathname merged with *DEFAULT-PATHNAME-DEFAULTS*. * optimization: performance improvements to IO on file streams of diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 6ec7f1a..c37947e 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -2023,12 +2023,26 @@ bootstrapping. (when lambda-list-p (proclaim (defgeneric-declaration fun-name lambda-list))))) +;;; FIXME: this function took on a slightly greater role than it +;;; previously had around 2005-11-02, when CSR fixed the bug whereby +;;; having more than one subclass of standard-generic-function caused +;;; the whole system to die horribly through a metacircle in +;;; GF-ARG-INFO. The fix is to be slightly more disciplined about +;;; calling accessor methods -- we call GET-GENERIC-FUN-INFO when +;;; computing discriminating functions, so we need to be careful about +;;; having a base case for the recursion, and we provide that with the +;;; STANDARD-GENERIC-FUNCTION case below. However, we are not (yet) +;;; as disciplined as CLISP's CLOS/MOP, and it would be nice to get to +;;; that stage, where all potentially dangerous cases are enumerated +;;; and stopped. -- CSR, 2005-11-02. (defun get-generic-fun-info (gf) ;; values nreq applyp metatypes nkeys arg-info (multiple-value-bind (applyp metatypes arg-info) (let* ((arg-info (if (early-gf-p gf) (early-gf-arg-info gf) - (gf-arg-info gf))) + (if (eq (class-of gf) *the-class-standard-generic-function*) + (clos-slots-ref (fsc-instance-slots gf) *sgf-arg-info-index*) + (gf-arg-info gf)))) (metatypes (arg-info-metatypes arg-info))) (values (arg-info-applyp arg-info) metatypes diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index ae44d78..2d8acb7 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -470,7 +470,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun make-final-checking-dfun (generic-function function classes-list new-class) - (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) + (multiple-value-bind (nreq applyp metatypes nkeys) + (get-generic-fun-info generic-function) + (declare (ignore nreq applyp nkeys)) (if (every (lambda (mt) (eq mt t)) metatypes) (values (lambda (&rest args) (invoke-emf function args)) @@ -669,8 +671,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defparameter *secondary-dfun-call-cost* 1) (defun caching-dfun-cost (gf) - (let* ((arg-info (gf-arg-info gf)) - (nreq (length (arg-info-metatypes arg-info)))) + (let ((nreq (get-generic-fun-info gf))) (+ *cache-lookup-cost* (* *wrapper-of-cost* nreq) (if (methods-contain-eql-specializer-p @@ -963,22 +964,29 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (t (make-final-caching-dfun gf classes-list new-class))))) +(defvar *accessor-miss-history* nil) + (defun accessor-miss (gf new object dfun-info) - (let* ((ostate (type-of dfun-info)) - (otype (dfun-info-accessor-type dfun-info)) - oindex ow0 ow1 cache - (args (ecase otype - ;; The congruence rules ensure that this is safe - ;; despite not knowing the new type yet. - ((reader boundp) (list object)) - (writer (list new object))))) - (dfun-miss (gf args wrappers invalidp nemf ntype nindex) - - ;; The following lexical functions change the state of the - ;; dfun to that which is their name. They accept arguments - ;; which are the parameters of the new state, and get other - ;; information from the lexical variables bound above. - (flet ((two-class (index w0 w1) + (let ((wrapper (wrapper-of object)) + (previous-miss (assq gf *accessor-miss-history*))) + (when (eq wrapper (cdr previous-miss)) + (error "~@" + gf object)) + (let* ((*accessor-miss-history* (acons gf wrapper *accessor-miss-history*)) + (ostate (type-of dfun-info)) + (otype (dfun-info-accessor-type dfun-info)) + oindex ow0 ow1 cache + (args (ecase otype + ((reader boundp) (list object)) + (writer (list new object))))) + (dfun-miss (gf args wrappers invalidp nemf ntype nindex) + ;; The following lexical functions change the state of the + ;; dfun to that which is their name. They accept arguments + ;; which are the parameters of the new state, and get other + ;; information from the lexical variables bound above. + (flet ((two-class (index w0 w1) (when (zerop (random 2)) (psetf w0 w1 w1 w0)) (dfun-update gf #'make-two-class-accessor-dfun @@ -1040,7 +1048,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (setq cache (dfun-info-cache dfun-info)) (if (consp nindex) (caching) - (do-fill #'n-n)))))))))) + (do-fill #'n-n))))))))))) (defun checking-miss (generic-function args dfun-info) (let ((oemf (dfun-info-function dfun-info)) @@ -1361,7 +1369,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((definite-p t) (possibly-applicable-methods nil)) (dolist (method (if (early-gf-p generic-function) (early-gf-methods generic-function) - (generic-function-methods generic-function))) + (if (eq (class-of generic-function) + *the-class-standard-generic-function*) + ;; KLUDGE: see comment by GET-GENERIC-FUN-INFO + (clos-slots-ref (fsc-instance-slots generic-function) *sgf-methods-index*) + (generic-function-methods generic-function)))) (let ((specls (if (consp method) (early-method-specializers method t) (method-specializers method))) @@ -1378,15 +1390,14 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (when possibly-applicable-p (unless applicable-p (setq definite-p nil)) (push method possibly-applicable-methods)))) - (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) - (early-gf-arg-info - generic-function) - (gf-arg-info - generic-function))))) - (values (sort-applicable-methods precedence - (nreverse possibly-applicable-methods) - types) - definite-p)))) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-fun-info generic-function) + (declare (ignore nreq applyp metatypes nkeys)) + (let* ((precedence (arg-info-precedence arg-info))) + (values (sort-applicable-methods precedence + (nreverse possibly-applicable-methods) + types) + definite-p))))) (defun sort-applicable-methods (precedence methods types) (sort-methods methods @@ -1732,17 +1743,17 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (return t))))) (defun update-dfun (generic-function &optional dfun cache info) - (let* ((early-p (early-gf-p generic-function)) - (gf-name (if early-p - (!early-gf-name generic-function) - (generic-function-name generic-function)))) + (let* ((early-p (early-gf-p generic-function))) (set-dfun generic-function dfun cache info) (let ((dfun (if early-p (or dfun (make-initial-dfun generic-function)) (compute-discriminating-function generic-function)))) (set-funcallable-instance-function generic-function dfun) - (set-fun-name generic-function gf-name) - dfun))) + (let ((gf-name (if early-p + (!early-gf-name generic-function) + (generic-function-name generic-function)))) + (set-fun-name generic-function gf-name) + dfun)))) (defvar *dfun-count* nil) (defvar *dfun-list* nil) diff --git a/tests/mop-3.impure-cload.lisp b/tests/mop-3.impure-cload.lisp index 74bb0f0..cb6f609 100644 --- a/tests/mop-3.impure-cload.lisp +++ b/tests/mop-3.impure-cload.lisp @@ -12,10 +12,7 @@ ;;;; more information. ;;; This file contains two tests for COMPUTE-APPLICABLE-METHODS on -;;; subclasses of generic functions. However, at present it is -;;; impossible to have both of these in the same image, because of a -;;; vicious metacircle. Once the vicious metacircle is dealt with, -;;; uncomment the second test case. +;;; subclasses of generic functions. ;;; tests from Bruno Haible (sbcl-devel 2004-08-02) @@ -58,7 +55,6 @@ (assert (equalp (list (testgf07 5.0) (testgf07 17)) '((number real) #(number real integer)))) -#| (defclass nonumber-generic-function (standard-generic-function) () (:metaclass funcallable-standard-class)) @@ -89,4 +85,3 @@ (assert (equalp (list (testgf08 5.0) (testgf08 17)) '((real) #(integer real)))) -|# diff --git a/tests/mop-4.impure-cload.lisp b/tests/mop-4.impure-cload.lisp index 2923f05..e4c7d0f 100644 --- a/tests/mop-4.impure-cload.lisp +++ b/tests/mop-4.impure-cload.lisp @@ -12,10 +12,7 @@ ;;;; more information. ;;; This file contains tests for COMPUTE-DISCRIMINATING-FUNCTION on -;;; subclasses of generic functions. However, at present it is -;;; impossible to have more than one of these in the same image, -;;; because of a vicious metacircle. Once the vicious metacircle is -;;; dealt with, uncomment the test cases. +;;; subclasses of generic functions. (defpackage "MOP-4" (:use "CL" "SB-MOP")) @@ -38,19 +35,30 @@ (assert (= (foo 5) 11)) -#| - ;;; from PCL sources -(defmethod compute-discriminating-function ((gf my-generic-function)) +(defclass my-generic-function-pcl1 (standard-generic-function) () + (:metaclass funcallable-standard-class)) + +(defmethod compute-discriminating-function ((gf my-generic-function-pcl1)) (let ((std (call-next-method))) (lambda (arg) (print (list 'call-to-gf gf arg)) (funcall std arg)))) -and +(defgeneric pcl1 (x) + (:generic-function-class my-generic-function-pcl1)) -(defmethod compute-discriminating-function ((gf my-generic-function)) +(defmethod pcl1 ((x integer)) (1+ x)) + +(let ((output (with-output-to-string (*standard-output*) + (pcl1 3)))) + (assert (search "(CALL-TO-GF # 3)" output))) + +#| +(defclass my-generic-function-pcl2 (standard-generic-function) () + (:metaclass funcallable-standard-class)) +(defmethod compute-discriminating-function ((gf my-generic-function-pcl2)) (lambda (arg) (cond ( @@ -60,23 +68,19 @@ and (funcall gf arg)) (t )))) - |# -#| - ;;; from clisp's test suite (progn (defclass traced-generic-function (standard-generic-function) () - (:metaclass clos:funcallable-standard-class)) + (:metaclass funcallable-standard-class)) (defvar *last-traced-arguments* nil) (defvar *last-traced-values* nil) - (defmethod clos:compute-discriminating-function ((gf traced-generic-function)) (let ((orig-df (call-next-method)) - (name (clos:generic-function-name gf))) + (defmethod compute-discriminating-function ((gf traced-generic-function)) (let ((orig-df (call-next-method)) + (name (generic-function-name gf))) #'(lambda (&rest arguments) - (declare (compile)) (format *trace-output* "~%=> ~S arguments: ~:S" name arguments) (setq *last-traced-arguments* arguments) (let ((values (multiple-value-list (apply orig-df arguments)))) @@ -86,9 +90,8 @@ and (defgeneric testgf15 (x) (:generic-function-class traced-generic-function) (:method ((x number)) (values x (- x) (* x x) (/ x)))) (testgf15 5) - (list *last-traced-arguments* *last-traced-values*)) + (assert (equal (list *last-traced-arguments* *last-traced-values*) + '((5) (5 -5 25 1/5))))) ;;; also we might be in a position to run the "application example" ;;; from mop.tst in clisp's test suite - -|# diff --git a/tests/mop-7.impure-cload.lisp b/tests/mop-7.impure-cload.lisp new file mode 100644 index 0000000..57dff0d --- /dev/null +++ b/tests/mop-7.impure-cload.lisp @@ -0,0 +1,35 @@ +;;;; 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. + +;;; This file contains the simplest test that the multiple subclasses +;;; of generic function metacircle is gone. + +(defpackage "MOP-7" + (:use "CL" "SB-MOP" "TEST-UTIL")) + +(in-package "MOP-7") + +(defclass g1 (standard-generic-function) + () + (:metaclass funcallable-standard-class)) +(defclass g2 (standard-generic-function) + () + (:metaclass funcallable-standard-class)) + +(defgeneric f1 () + (:generic-function-class g1)) +(defgeneric f2 () + (:generic-function-class g2)) + +(print #'f1) +(print #'f2) diff --git a/version.lisp-expr b/version.lisp-expr index 6b5e937..082b84e 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.9.6.10" +"0.9.6.11"