Menu
▾
▴
[Sbcl-commits] master: break infinite recursion in GENERATE-SLOTD-TYPECHECK
|
From: Nikodemus S. <de...@us...> - 2012-05-21 05:43:43
|
The branch "master" has been updated in SBCL:
via 522a3c95b9b7a044ff0ab8df1ca29460ef2ad3a7 (commit)
from 77d8891494a0de35a6095e1ddb0a0a71361efce8 (commit)
- Log -----------------------------------------------------------------
commit 522a3c95b9b7a044ff0ab8df1ca29460ef2ad3a7
Author: Nikodemus Siivola <nik...@ra...>
Date: Sun May 20 12:25:25 2012 +0300
break infinite recursion in GENERATE-SLOTD-TYPECHECK
Compilation of a typecheck can cause class finalization, which in turn can
cause calls to GENERATE-SLOTD-TYPECHECK.
Given the right sort of dependency graph, this can cause a cycle which needs
to be broken.
Regression from 1.0.46.11, fixed bug 1001799.
---
NEWS | 4 +++
src/pcl/init.lisp | 67 ++++++++++++++++++++++++++++++------------------
tests/clos.impure.lisp | 19 +++++++++++++
3 files changed, 65 insertions(+), 25 deletions(-)
diff --git a/NEWS b/NEWS
index 2a31378..ba2ca03 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,8 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
+changes relative to sbcl-1.0.57:
+ * bug fix: potential for infinite recursion during compilation of CLOS slot
+ typechecks when dependency graph had loops. (lp#1001799)
+
changes in sbcl-1.0.57 relative to sbcl-1.0.56:
* RANDOM enhancements and bug fixes:
** bug fix: the range and distribution of random integers could be
diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 5b6d913..5d3a325 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -60,37 +60,54 @@
(apply #'shared-initialize instance nil initargs)
instance)
-(defglobal **typecheck-cache** (make-hash-table :test #'equal))
+(defglobal **typecheck-cache** (make-hash-table :test #'equal :synchronized t))
+(defvar *typecheck-stack* nil)
-(defun generate-slotd-typecheck (slotd)
- (let ((type (slot-definition-type slotd)))
- (values
- (when (and (neq t type) (safe-p (slot-definition-class slotd)))
- (with-locked-system-table (**typecheck-cache**)
- (or (gethash type **typecheck-cache**)
- (setf (gethash type **typecheck-cache**)
- (handler-bind (((or style-warning compiler-note)
- #'muffle-warning))
- (funcall (compile
- nil
- `(lambda ()
- (declare (optimize (sb-c:store-coverage-data 0)
- (sb-c::type-check 3)
- (sb-c::verify-arg-count 0)))
- (named-lambda (slot-typecheck ,type) (value)
- (the ,type value))))))))))
- type)))
+(defun generate-slotd-typecheck (slotd info)
+ (let* ((type (slot-definition-type slotd))
+ (class (slot-definition-class slotd))
+ (cookie (cons class (slot-definition-name slotd))))
+ (declare (dynamic-extent cookie))
+ (when (and (neq t type) (safe-p class))
+ (or
+ ;; Have one already!
+ (awhen (gethash type **typecheck-cache**)
+ (setf (slot-info-typecheck info) it))
+ ;; It is possible for compilation of a typecheck to trigger class
+ ;; finalization, which in turn may trigger compilation of a
+ ;; slot-typechecking function -- detects and break those cycles.
+ ;;
+ ;; We use the slow function here, but the outer call will replace it
+ ;; with the fast one.
+ (when (member cookie *typecheck-stack* :test #'equal)
+ (setf (slot-info-typecheck info)
+ (named-lambda slow-slot-typecheck (value)
+ (if (typep value type)
+ value
+ (error 'type-error
+ :datum value
+ :expected-type type)))))
+ ;; The normal, good case: compile an efficient typecheck function.
+ (let ((*typecheck-stack* (cons cookie *typecheck-stack*)))
+ (handler-bind (((or style-warning compiler-note) #'muffle-warning))
+ (let ((fun (compile
+ nil
+ `(named-lambda (slot-typecheck ,type) (value)
+ (declare (optimize (sb-c:store-coverage-data 0)
+ (sb-c::type-check 3)
+ (sb-c::verify-arg-count 0)))
+ (the ,type value)))))
+ (setf (gethash type **typecheck-cache**) fun
+ (slot-info-typecheck info) fun))))))))
(defmethod initialize-instance :after ((slotd effective-slot-definition) &key)
- (setf (slot-definition-info slotd)
- (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
- (make-slot-info :slotd slotd
- :typecheck typecheck))))
+ (let ((info (make-slot-info :slotd slotd)))
+ (generate-slotd-typecheck slotd info)
+ (setf (slot-definition-info slotd) info)))
;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all?
(defmethod (setf slot-definition-type) :after (new-type (slotd effective-slot-definition))
- (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
- (setf (slot-info-typecheck (slot-definition-info slotd)) typecheck)))
+ (generate-slotd-typecheck slotd (slot-definition-info slotd)))
(defmethod update-instance-for-different-class
((previous standard-object) (current standard-object) &rest initargs)
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 24b24d9..4184438 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1920,4 +1920,23 @@
(declare (ignore all-segment-requests))
(check-type request t)))))
+(with-test (:name :bug-1001799)
+ ;; compilation of the defmethod used to cause infinite recursion
+ (let ((pax (gensym "PAX"))
+ (pnr (gensym "PNR"))
+ (sup (gensym "SUP"))
+ (frob (gensym "FROB"))
+ (sb-ext:*evaluator-mode* :compile))
+ (eval
+ `(progn
+ (declaim (optimize (speed 1) (space 1) (safety 3) (debug 3) (compilation-speed 1)))
+ (defclass ,pax (,sup)
+ ((,pnr :type (or null ,pnr))))
+ (defclass ,pnr (,sup)
+ ((,pax :type (or null ,pax))))
+ (defclass ,sup ()
+ ())
+ (defmethod ,frob ((pnr ,pnr))
+ (slot-value pnr ',pax))))))
+
;;;; success
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|