From 4f7161165647d655392713a0d95c951e4e1749ea Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 14 Mar 2008 19:03:05 +0000 Subject: [PATCH] 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! --- package-data-list.lisp-expr | 11 +- src/code/class-init.lisp | 2 +- src/code/class.lisp | 283 ++++++++++++++++++++---------------- src/code/defstruct.lisp | 4 - src/compiler/compiler-deftype.lisp | 2 +- src/compiler/fndb.lisp | 2 +- src/compiler/globaldb.lisp | 11 -- src/compiler/typetran.lisp | 8 +- src/pcl/braid.lisp | 50 +++---- src/pcl/defs.lisp | 2 +- src/pcl/early-low.lisp | 12 +- src/pcl/macros.lisp | 97 ++++-------- src/pcl/wrapper.lisp | 6 +- tests/threads.pure.lisp | 3 +- version.lisp-expr | 2 +- 15 files changed, 246 insertions(+), 249 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 86fd959..f8da734 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1632,19 +1632,24 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%OTHER-POINTER-P" "STANDARD-CLASSOID" "CLASSOID-OF" - "MAKE-STANDARD-CLASSOID" "CLASSOID-CELL-TYPEP" + "MAKE-STANDARD-CLASSOID" + "CLASSOID-CELL-CLASSOID" + "CLASSOID-CELL-NAME" + "CLASSOID-CELL-PCL-CLASS" + "CLASSOID-CELL-TYPEP" + "CLEAR-CLASSOID" "FIND-CLASSOID-CELL" "EXTRACT-FUN-TYPE" "%RANDOM-DOUBLE-FLOAT" #!+long-float "%RANDOM-LONG-FLOAT" "%RANDOM-SINGLE-FLOAT" "STATIC-CLASSOID" "%FUNCALLABLE-INSTANCE-INFO" "RANDOM-CHUNK" "BIG-RANDOM-CHUNK" - "LAYOUT-CLOS-HASH-LIMIT" "CLASSOID-CELL-NAME" + "LAYOUT-CLOS-HASH-LIMIT" "BUILT-IN-CLASSOID-DIRECT-SUPERCLASSES" "BUILT-IN-CLASSOID-TRANSLATION" "RANDOM-LAYOUT-CLOS-HASH" "CLASSOID-PCL-CLASS" "FUNCALLABLE-STRUCTURE" "FUNCALLABLE-INSTANCE-FUN" "%FUNCALLABLE-INSTANCE-LAYOUT" "%SET-FUNCALLABLE-INSTANCE-LAYOUT" - "BASIC-STRUCTURE-CLASSOID" "CLASSOID-CELL-CLASSOID" + "BASIC-STRUCTURE-CLASSOID" "REGISTER-LAYOUT" "FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX" "MAKE-STATIC-CLASSOID" "INSTANCE-LAMBDA" diff --git a/src/code/class-init.lisp b/src/code/class-init.lisp index b6aab5f..2f67ee1 100644 --- a/src/code/class-init.lisp +++ b/src/code/class-init.lisp @@ -24,7 +24,7 @@ (/primitive-print (symbol-name name)) (when trans-p (/show0 "in TRANS-P case") - (let ((classoid (classoid-cell-classoid (find-classoid-cell name))) + (let ((classoid (classoid-cell-classoid (find-classoid-cell name :create t))) (type (specifier-type translation))) (setf (built-in-classoid-translation classoid) type) (setf (info :type :builtin name) type))))) diff --git a/src/code/class.lisp b/src/code/class.lisp index 082484c..abe8d0e 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -101,9 +101,7 @@ ;;; cold-load time. (defvar *forward-referenced-layouts*) (!cold-init-forms - (setq *forward-referenced-layouts* (make-hash-table :test 'equal - #-sb-xc-host #-sb-xc-host - :synchronized t)) + (setq *forward-referenced-layouts* (make-hash-table :test 'equal)) #-sb-xc-host (progn (/show0 "processing *!INITIAL-LAYOUTS*") (dolist (x *!initial-layouts*) @@ -250,14 +248,18 @@ ;;; cross-compilability reasons (i.e. convenience of using this ;;; function in a MAKE-LOAD-FORM expression) that functionality has ;;; been split off into INIT-OR-CHECK-LAYOUT. -(declaim (ftype (function (symbol) layout) find-layout)) +(declaim (ftype (sfunction (symbol) layout) find-layout)) (defun find-layout (name) - (let ((classoid (find-classoid name nil))) - (or (and classoid (classoid-layout classoid)) - (gethash name *forward-referenced-layouts*) - (setf (gethash name *forward-referenced-layouts*) - (make-layout :classoid (or classoid - (make-undefined-classoid name))))))) + ;; This seems to be currently used only from the compiler, but make + ;; it thread-safe all the same. We need to lock *F-R-L* before doing + ;; FIND-CLASSOID in case (SETF FIND-CLASSOID) happens in parallel. + (let ((table *forward-referenced-layouts*)) + (with-locked-hash-table (table) + (let ((classoid (find-classoid name nil))) + (or (and classoid (classoid-layout classoid)) + (gethash name table) + (setf (gethash name table) + (make-layout :classoid (or classoid (make-undefined-classoid name))))))))) ;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH, ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent @@ -679,128 +681,166 @@ (:constructor make-classoid-cell (name &optional classoid)) (:make-load-form-fun (lambda (c) `(find-classoid-cell - ',(classoid-cell-name c)))) + ',(classoid-cell-name c) + :errorp t))) #-no-ansi-print-object (:print-object (lambda (s stream) (print-unreadable-object (s stream :type t) (prin1 (classoid-cell-name s) stream))))) ;; Name of class we expect to find. (name nil :type symbol :read-only t) - ;; Class or NIL if not yet defined. - (classoid nil :type (or classoid null))) -(defun find-classoid-cell (name) - (or (info :type :classoid name) - (setf (info :type :classoid name) - (make-classoid-cell name)))) + ;; Classoid or NIL if not yet defined. + (classoid nil :type (or classoid null)) + ;; PCL class, if any + (pcl-class nil)) + +(defvar *classoid-cells*) +(!cold-init-forms + (setq *classoid-cells* (make-hash-table :test 'eq))) + +(defun find-classoid-cell (name &key create errorp) + (let ((table *classoid-cells*) + (real-name (uncross name))) + (or (with-locked-hash-table (table) + (or (gethash real-name table) + (when create + (setf (gethash real-name table) (make-classoid-cell real-name))))) + (when errorp + (error 'simple-type-error + :datum nil + :expected-type 'class + :format-control "Class not yet defined: ~S" + :format-arguments (list name)))))) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) -(defun find-classoid (name &optional (errorp t) environment) - #!+sb-doc - "Return the class with the specified NAME. If ERRORP is false, then -NIL is returned when no such class exists." - (declare (type symbol name) (ignore environment)) - (let ((res (classoid-cell-classoid (find-classoid-cell name)))) - (if (or res (not errorp)) - res - (error 'simple-type-error - :datum nil - :expected-type 'class - :format-control "class not yet defined:~% ~S" - :format-arguments (list name))))) -(defun (setf find-classoid) (new-value name) - #-sb-xc (declare (type (or null classoid) new-value)) - (cond - ((null new-value) - (ecase (info :type :kind name) - ((nil)) - (:defined) - (:primitive - (error "attempt to redefine :PRIMITIVE type: ~S" name)) - ((:forthcoming-defclass-type :instance) - (setf (info :type :kind name) nil - (info :type :classoid name) nil - (info :type :documentation name) nil - (info :type :compiler-layout name) nil)))) - (t - (ecase (info :type :kind name) - ((nil)) - (:forthcoming-defclass-type - ;; XXX Currently, nothing needs to be done in this - ;; case. Later, when PCL is integrated tighter into SBCL, this - ;; might need more work. - nil) - (:instance - ;; KLUDGE: The reason these clauses aren't directly parallel - ;; is that we need to use the internal CLASSOID structure - ;; ourselves, because we don't have CLASSes to work with until - ;; PCL is built. In the host, CLASSes have an approximately - ;; one-to-one correspondence with the target CLASSOIDs (as - ;; well as with the target CLASSes, modulo potential - ;; differences with respect to conditions). - #+sb-xc-host - (let ((old (class-of (find-classoid name))) - (new (class-of new-value))) - (unless (eq old new) - (bug "trying to change the metaclass of ~S from ~S to ~S in the ~ - cross-compiler." - name (class-name old) (class-name new)))) - #-sb-xc-host - (let ((old (classoid-of (find-classoid name))) - (new (classoid-of new-value))) - (unless (eq old new) - (warn "changing meta-class of ~S from ~S to ~S" - name (classoid-name old) (classoid-name new))))) - (:primitive - (error "illegal to redefine standard type ~S" name)) - (:defined - (warn "redefining DEFTYPE type to be a class: ~S" name) - (setf (info :type :expander name) nil))) - - (remhash name *forward-referenced-layouts*) - (%note-type-defined name) - ;; we need to handle things like - ;; (setf (find-class 'foo) (find-class 'integer)) - ;; and - ;; (setf (find-class 'integer) (find-class 'integer)) - (cond - ((built-in-classoid-p new-value) - (setf (info :type :kind name) (or (info :type :kind name) :defined)) - (let ((translation (built-in-classoid-translation new-value))) - (when translation - (setf (info :type :translator name) - (lambda (c) (declare (ignore c)) translation))))) - (t (setf (info :type :kind name) :instance))) - (setf (classoid-cell-classoid (find-classoid-cell name)) new-value) - (unless (eq (info :type :compiler-layout name) - (classoid-layout new-value)) - (setf (info :type :compiler-layout name) (classoid-layout new-value))))) - new-value) -) ; EVAL-WHEN + + ;; Return the classoid with the specified NAME. If ERRORP is false, + ;; then NIL is returned when no such class exists." + (defun find-classoid (name &optional (errorp t)) + (declare (type symbol name)) + (let ((cell (find-classoid-cell name :errorp errorp))) + (when cell (classoid-cell-classoid cell)))) + + ;; This is definitely not thread safe with itself -- but should be + ;; OK with parallel FIND-CLASSOID & FIND-LAYOUT. + (defun (setf find-classoid) (new-value name) + #-sb-xc (declare (type (or null classoid) new-value)) + (aver new-value) + (let ((table *forward-referenced-layouts*)) + (with-locked-hash-table (table) + (let ((cell (find-classoid-cell name :create t))) + (ecase (info :type :kind name) + ((nil)) + (:forthcoming-defclass-type + ;; FIXME: Currently, nothing needs to be done in this case. + ;; Later, when PCL is integrated tighter into SBCL, this + ;; might need more work. + nil) + (:instance + (aver cell) + (let ((old-value (classoid-cell-classoid cell))) + (aver old-value) + ;; KLUDGE: The reason these clauses aren't directly + ;; parallel is that we need to use the internal + ;; CLASSOID structure ourselves, because we don't + ;; have CLASSes to work with until PCL is built. In + ;; the host, CLASSes have an approximately + ;; one-to-one correspondence with the target + ;; CLASSOIDs (as well as with the target CLASSes, + ;; modulo potential differences with respect to + ;; conditions). + #+sb-xc-host + (let ((old (class-of old-value)) + (new (class-of new-value))) + (unless (eq old new) + (bug "Trying to change the metaclass of ~S from ~S to ~S in the ~ + cross-compiler." + name (class-name old) (class-name new)))) + #-sb-xc-host + (let ((old (classoid-of old-value)) + (new (classoid-of new-value))) + (unless (eq old new) + (warn "Changing meta-class of ~S from ~S to ~S." + name (classoid-name old) (classoid-name new)))))) + (:primitive + (error "Cannot redefine standard type ~S." name)) + (:defined + (warn "Redefining DEFTYPE type to be a class: ~S" name) + (setf (info :type :expander name) nil))) + + (remhash name table) + (%note-type-defined name) + ;; we need to handle things like + ;; (setf (find-class 'foo) (find-class 'integer)) + ;; and + ;; (setf (find-class 'integer) (find-class 'integer)) + (cond ((built-in-classoid-p new-value) + (setf (info :type :kind name) + (or (info :type :kind name) :defined)) + (let ((translation (built-in-classoid-translation new-value))) + (when translation + (setf (info :type :translator name) + (lambda (c) (declare (ignore c)) translation))))) + (t + (setf (info :type :kind name) :instance))) + (setf (classoid-cell-classoid cell) new-value) + (unless (eq (info :type :compiler-layout name) + (classoid-layout new-value)) + (setf (info :type :compiler-layout name) + (classoid-layout new-value)))))) + new-value) + + (defun clear-classoid (name cell) + (ecase (info :type :kind name) + ((nil)) + (:defined) + (:primitive + (error "Attempt to remove :PRIMITIVE type: ~S" name)) + ((:forthcoming-defclass-type :instance) + (when cell + ;; Note: We cannot remove the classoid cell from the table, + ;; since compiled code may refer directly to the cell, and + ;; getting a different cell for a classoid with the same name + ;; just would not do. + + ;; Remove the proper name of the classoid. + (setf (classoid-name (classoid-cell-classoid cell)) nil) + ;; Clear the cell. + (setf (classoid-cell-classoid cell) nil + (classoid-cell-pcl-class cell) nil)) + (setf (info :type :kind name) nil + (info :type :documentation name) nil + (info :type :compiler-layout name) nil))))) ;;; Called when we are about to define NAME as a class meeting some ;;; predicate (such as a meta-class type test.) The first result is ;;; always of the desired class. The second result is any existing ;;; LAYOUT for this name. +;;; +;;; Again, this should be compiler-only, but easier to make this +;;; thread-safe. (defun insured-find-classoid (name predicate constructor) (declare (type function predicate constructor)) - (let* ((old (find-classoid name nil)) - (res (if (and old (funcall predicate old)) - old - (funcall constructor :name name))) - (found (or (gethash name *forward-referenced-layouts*) - (when old (classoid-layout old))))) - (when found - (setf (layout-classoid found) res)) - (values res found))) - -;;; If the class has a proper name, return the name, otherwise return -;;; the class. -(defun classoid-proper-name (class) - #-sb-xc (declare (type classoid class)) - (let ((name (classoid-name class))) - (if (and name (eq (find-classoid name nil) class)) + (let ((table *forward-referenced-layouts*)) + (with-locked-hash-table (table) + (let* ((old (find-classoid name nil)) + (res (if (and old (funcall predicate old)) + old + (funcall constructor :name name))) + (found (or (gethash name table) + (when old (classoid-layout old))))) + (when found + (setf (layout-classoid found) res)) + (values res found))))) + +;;; If the classoid has a proper name, return the name, otherwise return +;;; the classoid. +(defun classoid-proper-name (classoid) + #-sb-xc (declare (type classoid classoid)) + (let ((name (classoid-name classoid))) + (if (and name (eq (find-classoid name nil) classoid)) name - class))) + classoid))) ;;;; CLASS type operations @@ -1363,7 +1403,7 @@ NIL is returned when no such class exists." nil (mapcar #'find-classoid direct-superclasses))))) (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive - (classoid-cell-classoid (find-classoid-cell name)) classoid) + (classoid-cell-classoid (find-classoid-cell name :create t)) classoid) (unless trans-p (setf (info :type :builtin name) classoid)) (let* ((inherits-vector @@ -1416,11 +1456,10 @@ NIL is returned when no such class exists." (let* ((name (first x)) (inherits-list (second x)) (classoid (make-standard-classoid :name name)) - (classoid-cell (find-classoid-cell name))) + (classoid-cell (find-classoid-cell name :create t))) ;; Needed to open-code the MAP, below (declare (type list inherits-list)) (setf (classoid-cell-classoid classoid-cell) classoid - (info :type :classoid name) classoid-cell (info :type :kind name) :instance) (let ((inherits (map 'simple-vector (lambda (x) @@ -1485,10 +1524,8 @@ NIL is returned when no such class exists." ((eq (classoid-layout class) layout) (remhash name *forward-referenced-layouts*)) (t - ;; FIXME: ERROR? - (warn "something strange with forward layout for ~S:~% ~S" - name - layout)))))) + (error "Something strange with forward layout for ~S:~% ~S" + name layout)))))) (!cold-init-forms #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*") diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 26b5058..97dc74e 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -58,10 +58,6 @@ (error "Class is not a structure class: ~S" ',name)) ,layout)))))) -;;; Get layout right away. -(sb!xc:defmacro compile-time-find-layout (name) - (find-layout name)) - ;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above.. ;;; ;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY? diff --git a/src/compiler/compiler-deftype.lisp b/src/compiler/compiler-deftype.lisp index 322b06b..c4a92a5 100644 --- a/src/compiler/compiler-deftype.lisp +++ b/src/compiler/compiler-deftype.lisp @@ -23,7 +23,7 @@ (:instance (warn "The class ~S is being redefined to be a DEFTYPE." name) (undefine-structure (layout-info (classoid-layout (find-classoid name)))) - (setf (classoid-cell-classoid (find-classoid-cell name)) nil) + (setf (classoid-cell-classoid (find-classoid-cell name :create t)) nil) (setf (info :type :compiler-layout name) nil) (setf (info :type :kind name) :defined)) (:defined diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 1d3f521..e5c72f5 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -81,7 +81,7 @@ (sb!xc:deftype name-for-class () t) (defknown classoid-name (classoid) name-for-class (flushable)) -(defknown find-classoid (name-for-class &optional t lexenv-designator) +(defknown find-classoid (name-for-class &optional t) (or classoid null) ()) (defknown classoid-of (t) classoid (flushable)) (defknown layout-of (t) layout (flushable)) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index e55bc34..bb75e15 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1169,17 +1169,6 @@ :type-spec (or ctype null) :default nil) -;;; If this is a class name, then the value is a cons (NAME . CLASS), -;;; where CLASS may be null if the class hasn't been defined yet. Note -;;; that for built-in classes, the kind may be :PRIMITIVE and not -;;; :INSTANCE. The name is in the cons so that we can signal a -;;; meaningful error if we only have the cons. -(define-info-type - :class :type - :type :classoid - :type-spec (or sb!kernel::classoid-cell null) - :default nil) - ;;; layout for this type being used by the compiler (define-info-type :class :type diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 67f5873..53f3c64 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -101,11 +101,11 @@ (aver ctype) (ir1-transform-type-predicate object ctype))) -;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL -;;; at load time. +;;; If FIND-CLASSOID is called on a constant class, locate the +;;; CLASSOID-CELL at load time. (deftransform find-classoid ((name) ((constant-arg symbol)) *) (let* ((name (lvar-value name)) - (cell (find-classoid-cell name))) + (cell (find-classoid-cell name :create t))) `(or (classoid-cell-classoid ',cell) (error "class not yet defined: ~S" name)))) @@ -492,7 +492,7 @@ (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP") `(and (,pred object) (classoid-cell-typep (,get-layout object) - ',(find-classoid-cell name) + ',(find-classoid-cell name :create t) object))))))))) ;;; If the specifier argument is a quoted constant, then we consider diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index ab4588a..518abf7 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -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)) - - (update-lisp-class-layout class layout) - - (cond (olclass - (aver (eq lclass olclass))) - (t - (setf (find-classoid name) lclass))) - - (set-class-type-translation class name))) +(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) + + (cond (olclass + (aver (eq lclass olclass))) + (t + (setf (find-classoid name) lclass))) + + (set-class-type-translation class name)))) (setq *boot-state* 'braid) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 985bf5c..cea2b0e 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -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 diff --git a/src/pcl/early-low.lisp b/src/pcl/early-low.lisp index 7fca8d3..b69c592 100644 --- a/src/pcl/early-low.lisp +++ b/src/pcl/early-low.lisp @@ -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) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index bc6fdf1..a9a657f 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -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)) diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp index eb567cd..3ea3a2c 100644 --- a/src/pcl/wrapper.lisp +++ b/src/pcl/wrapper.lisp @@ -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 diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index ef019a4..b10820a 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -56,8 +56,7 @@ #+sb-thread (with-test (:name without-interrupts+get-mutex) (let* ((lock (make-mutex)) - (foo (get-mutex lock)) - (bar nil) + (bar (progn (get-mutex lock) nil)) (thread (make-thread (lambda () (sb-sys:without-interrupts (with-mutex (lock) diff --git a/version.lisp-expr b/version.lisp-expr index c90cbf0..b8ba138 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".) -"1.0.15.30" +"1.0.15.31" -- 1.7.10.4