From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sun, 20 May 2012 09:25:25 +0000 (+0300)
Subject: break infinite recursion in GENERATE-SLOTD-TYPECHECK
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=522a3c95b9b7a044ff0ab8df1ca29460ef2ad3a7;p=sbcl.git

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.
---

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))
-
-(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)))
+(defglobal **typecheck-cache** (make-hash-table :test #'equal :synchronized t))
+(defvar *typecheck-stack* nil)
+
+(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