From: Nikodemus S. <de...@us...> - 2008-03-14 19:03:11
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv19460/src/pcl Modified Files: braid.lisp defs.lisp early-low.lisp macros.lisp wrapper.lisp Log Message: 1.0.15.31: thread-safe FIND-CLASS -- really this time Call It Myopia: it turns out FIND-CLASSOID &co underneath FIND-CLASS (when called for non-existent classes) were not thread-safe either. * Get rid of *FIND-CLASS* hash-table, moving the actual PCL classes into corresponding CLASSOID-CELL (new slot PCL-CLASS). * Move classoid-cells from the infodb into into *CLASSOID-CELLS* hash-table. We want to be able to lock around (or (get-cell) (setf (get-cell) (make-cell))) and infodb isn't really designed for that. This is the crux of the breakage: *** parallel writes to infodb are not thread safe! *** * Lock over *CLASSOID-CELLS* and *FORWARD-REFERENCED-LAYOUTS*. The latter should not be really necessary as long as we don't assume (SETF FIND-CLASS) to be thread-safe, but easier to reason about it this way. ...and it would be nice for the SETF to be safe as well. Related work: * Don't create cells for non-exitent classes unless we know we are going to need them -- previously both FIND-CLASSOID and FIND-CLASS created a cell for every name they were called with, which is isn't too good. This is especially important as once created these cells never go away! Index: braid.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v retrieving revision 1.72 retrieving revision 1.73 diff -u -d -r1.72 -r1.73 --- braid.lisp 21 Jan 2008 14:44:45 -0000 1.72 +++ braid.lisp 14 Mar 2008 19:03:06 -0000 1.73 @@ -538,12 +538,10 @@ (defun eval-form (form) (lambda () (eval form))) -(defun ensure-non-standard-class (name &optional existing-class) +(defun ensure-non-standard-class (name classoid &optional existing-class) (flet ((ensure (metaclass &optional (slots nil slotsp)) - (let ((supers - (mapcar #'classoid-name (classoid-direct-superclasses - (find-classoid name))))) + (let ((supers (mapcar #'classoid-name (classoid-direct-superclasses classoid)))) (if slotsp (ensure-class-using-class existing-class name :metaclass metaclass :name name @@ -584,16 +582,16 @@ ((condition-type-p name) (ensure 'condition-class (mapcar #'slot-initargs-from-condition-slot - (condition-classoid-slots (find-classoid name))))) + (condition-classoid-slots classoid)))) (t (error "~@<~S is not the name of a class.~@:>" name))))) (defun ensure-deffoo-class (classoid) (let ((class (classoid-pcl-class classoid))) (cond (class - (ensure-non-standard-class (class-name class) class)) + (ensure-non-standard-class (class-name class) classoid class)) ((eq 'complete *boot-state*) - (ensure-non-standard-class (classoid-name classoid)))))) + (ensure-non-standard-class (classoid-name classoid) classoid))))) (pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*) (pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*) @@ -670,7 +668,6 @@ (setf (info :type :translator class) (lambda (spec) (declare (ignore spec)) classoid))))) -(clrhash *find-class*) (!bootstrap-meta-braid) (!bootstrap-accessor-definitions t) (!bootstrap-class-predicates t) @@ -678,24 +675,25 @@ (!bootstrap-class-predicates nil) (!bootstrap-built-in-classes) -(dohash ((name x) *find-class*) - (let* ((class (find-class-from-cell name x)) - (layout (class-wrapper class)) - (lclass (layout-classoid layout)) - (lclass-pcl-class (classoid-pcl-class lclass)) - (olclass (find-classoid name nil))) - (if lclass-pcl-class - (aver (eq class lclass-pcl-class)) - (setf (classoid-pcl-class lclass) class)) +(dohash ((name x) sb-kernel::*classoid-cells*) + (when (classoid-cell-pcl-class x) + (let* ((class (find-class-from-cell name x)) + (layout (class-wrapper class)) + (lclass (layout-classoid layout)) + (lclass-pcl-class (classoid-pcl-class lclass)) + (olclass (find-classoid name nil))) + (if lclass-pcl-class + (aver (eq class lclass-pcl-class)) + (setf (classoid-pcl-class lclass) class)) - (update-lisp-class-layout class layout) + (update-lisp-class-layout class layout) - (cond (olclass - (aver (eq lclass olclass))) - (t - (setf (find-classoid name) lclass))) + (cond (olclass + (aver (eq lclass olclass))) + (t + (setf (find-classoid name) lclass))) - (set-class-type-translation class name))) + (set-class-type-translation class name)))) (setq *boot-state* 'braid) Index: defs.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/defs.lisp,v retrieving revision 1.65 retrieving revision 1.66 diff -u -d -r1.65 -r1.66 --- defs.lisp 21 Jan 2008 14:40:55 -0000 1.65 +++ defs.lisp 14 Mar 2008 19:03:06 -0000 1.66 @@ -76,7 +76,7 @@ ;; FIXME: do we still need this? ((and (null args) (typep type 'classoid)) (or (classoid-pcl-class type) - (ensure-non-standard-class (classoid-name type)))) + (ensure-non-standard-class (classoid-name type) type))) ((specializerp type) type))) ;;; interface Index: early-low.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/early-low.lisp,v retrieving revision 1.12 retrieving revision 1.13 diff -u -d -r1.12 -r1.13 --- early-low.lisp 28 Jul 2006 14:47:23 -0000 1.12 +++ early-low.lisp 14 Mar 2008 19:03:06 -0000 1.13 @@ -44,6 +44,12 @@ ;;; and use that to replace all three variables.) (defvar *pcl-package* (find-package "SB-PCL")) +(declaim (inline defstruct-classoid-p)) +(defun defstruct-classoid-p (classoid) + ;; It is non-obvious to me why STRUCTURE-CLASSOID-P doesn't + ;; work instead of this. -- NS 2008-03-14 + (typep (layout-info (classoid-layout classoid)) 'defstruct-description)) + ;;; This excludes structure types created with the :TYPE option to ;;; DEFSTRUCT. It also doesn't try to deal with types created by ;;; hairy DEFTYPEs, e.g. @@ -53,12 +59,10 @@ ;;; it needs a more mnemonic name. -- WHN 19991204 (defun structure-type-p (type) (and (symbolp type) - (not (condition-type-p type)) (let ((classoid (find-classoid type nil))) (and classoid - (typep (layout-info - (classoid-layout classoid)) - 'defstruct-description))))) + (not (condition-classoid-p classoid)) + (defstruct-classoid-p classoid))))) ;;; Symbol contruction utilities (defun format-symbol (package format-string &rest format-arguments) Index: macros.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/macros.lisp,v retrieving revision 1.28 retrieving revision 1.29 diff -u -d -r1.28 -r1.29 --- macros.lisp 13 Mar 2008 18:35:49 -0000 1.28 +++ macros.lisp 14 Mar 2008 19:03:06 -0000 1.29 @@ -79,49 +79,31 @@ (/show "pcl/macros.lisp 119") -(defvar *find-class* (make-hash-table :test 'eq)) - -(defmacro find-class-cell-class (cell) - `(car ,cell)) - -(defmacro find-class-cell-predicate (cell) - `(cadr ,cell)) - -(defmacro make-find-class-cell (class-name) - (declare (ignore class-name)) - '(list* nil #'constantly-nil nil)) - -(defun find-class-cell (symbol &optional dont-create-p) - (let ((table *find-class*)) - (with-locked-hash-table (table) - (or (gethash symbol table) - (unless dont-create-p - (unless (legal-class-name-p symbol) - (error "~S is not a legal class name." symbol)) - (setf (gethash symbol table) (make-find-class-cell symbol))))))) - -(/show "pcl/macros.lisp 157") +(declaim (inline legal-class-name-p)) +(defun legal-class-name-p (x) + (symbolp x)) (defvar *create-classes-from-internal-structure-definitions-p* t) (defun find-class-from-cell (symbol cell &optional (errorp t)) - (or (find-class-cell-class cell) - (and *create-classes-from-internal-structure-definitions-p* - (or (structure-type-p symbol) (condition-type-p symbol)) - (ensure-non-standard-class symbol)) + (or (when cell + (or (classoid-cell-pcl-class cell) + (when *create-classes-from-internal-structure-definitions-p* + (let ((classoid (classoid-cell-classoid cell))) + (when (and classoid + (or (condition-classoid-p classoid) + (defstruct-classoid-p classoid))) + (ensure-non-standard-class symbol classoid)))))) (cond ((null errorp) nil) ((legal-class-name-p symbol) (error "There is no class named ~S." symbol)) (t (error "~S is not a legal class name." symbol))))) -(defun legal-class-name-p (x) - (symbolp x)) - (defun find-class (symbol &optional (errorp t) environment) (declare (ignore environment)) (find-class-from-cell symbol - (find-class-cell symbol errorp) + (find-classoid-cell symbol) errorp)) @@ -143,49 +125,34 @@ (constantp errorp) (member *boot-state* '(braid complete))) (let ((errorp (not (null (constant-form-value errorp)))) - (class-cell (make-symbol "CLASS-CELL"))) - `(let ((,class-cell (load-time-value (find-class-cell ',symbol)))) - (or (find-class-cell-class ,class-cell) + (cell (make-symbol "CLASSOID-CELL"))) + `(let ((,cell (load-time-value (find-classoid-cell ',symbol :create t)))) + (or (classoid-cell-pcl-class ,cell) ,(if errorp - `(find-class-from-cell ',symbol ,class-cell t) - `(and (classoid-cell-classoid - ',(find-classoid-cell symbol)) - (find-class-from-cell ',symbol ,class-cell nil)))))) + `(find-class-from-cell ',symbol ,cell t) + `(when (classoid-cell-classoid ,cell) + (find-class-from-cell ',symbol ,cell nil)))))) form)) +(declaim (inline class-classoid)) +(defun class-classoid (class) + (layout-classoid (class-wrapper class))) + (defun (setf find-class) (new-value name &optional errorp environment) (declare (ignore errorp environment)) (cond ((legal-class-name-p name) (with-single-package-locked-error - (:symbol name "using ~A as the class-name argument in ~ + (:symbol name "Using ~A as the class-name argument in ~ (SETF FIND-CLASS)")) - (let* ((cell (find-class-cell name)) - (class (find-class-cell-class cell))) - (setf (find-class-cell-class cell) new-value) - (when (eq *boot-state* 'complete) - (if (null new-value) - (progn - (setf (find-classoid name) new-value) - (when class - ;; KLUDGE: This horror comes about essentially - ;; because we use the proper name of a classoid - ;; to do TYPEP, which needs to be available - ;; early, and also to determine whether TYPE-OF - ;; should return the name or the class (using - ;; CLASSOID-PROPER-NAME). So if we are removing - ;; proper nameness, arrange for - ;; CLASSOID-PROPER-NAME to do the right thing - ;; too. (This is almost certainly not the right - ;; solution; instead, CLASSOID-NAME and - ;; FIND-CLASSOID should be direct parallels to - ;; CLASS-NAME and FIND-CLASS, and TYPEP on - ;; not-yet-final classes should be compileable. - (let ((classoid (layout-classoid (slot-value class 'wrapper)))) - (setf (classoid-name classoid) nil)))) - - (let ((classoid (layout-classoid (slot-value new-value 'wrapper)))) - (setf (find-classoid name) classoid) - (set-class-type-translation new-value classoid)))) + (let ((cell (find-classoid-cell name :create new-value))) + (cond (new-value + (setf (classoid-cell-pcl-class cell) new-value) + (when (eq *boot-state* 'complete) + (let ((classoid (class-classoid new-value))) + (setf (find-classoid name) classoid) + (set-class-type-translation new-value classoid)))) + (cell + (clear-classoid name cell))) (when (or (eq *boot-state* 'complete) (eq *boot-state* 'braid)) (update-ctors 'setf-find-class :class new-value :name name)) Index: wrapper.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/wrapper.lisp,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- wrapper.lisp 9 Sep 2007 07:32:28 -0000 1.8 +++ wrapper.lisp 14 Mar 2008 19:03:06 -0000 1.9 @@ -99,8 +99,10 @@ (declaim (inline wrapper-class*)) (defun wrapper-class* (wrapper) (or (wrapper-class wrapper) - (ensure-non-standard-class - (classoid-name (layout-classoid wrapper))))) + (let ((classoid (layout-classoid wrapper))) + (ensure-non-standard-class + (classoid-name classoid) + classoid)))) ;;; The wrapper cache machinery provides general mechanism for ;;; trapping on the next access to any instance of a given class. This |