;; :SEALED = We can't even add subclasses.
;; NIL = Anything could happen.
(state nil :type (member nil :read-only :sealed))
- ;; direct superclasses of this class
+ ;; direct superclasses of this class. Always NIL for CLOS classes.
(direct-superclasses () :type list)
;; representation of all of the subclasses (direct or indirect) of
;; this class. This is NIL if no subclasses or not initalized yet;
;;; cold-load time.
(defvar *forward-referenced-layouts*)
(!cold-init-forms
+ ;; Protected by *WORLD-LOCK*
(setq *forward-referenced-layouts* (make-hash-table :test 'equal))
#-sb-xc-host (progn
(/show0 "processing *!INITIAL-LAYOUTS*")
(dolist (x *!initial-layouts*)
+ (setf (layout-clos-hash (cdr x)) (random-layout-clos-hash))
(setf (gethash (car x) *forward-referenced-layouts*)
(cdr x)))
(/show0 "done processing *!INITIAL-LAYOUTS*")))
;; 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)
+ (with-world-lock ()
(let ((classoid (find-classoid name nil)))
(or (and classoid (classoid-layout classoid))
(gethash name table)
(declaim (ftype (function (layout classoid index simple-vector layout-depthoid
index)
layout)
- init-or-check-layout))
-(defun init-or-check-layout
+ %init-or-check-layout))
+(defun %init-or-check-layout
(layout classoid length inherits depthoid nuntagged)
(cond ((eq (layout-invalid layout) :uninitialized)
;; There was no layout before, we just created one which
`(find-layout ',name)
;; "initialization" form (which actually doesn't initialize
;; preexisting LAYOUTs, just checks that they're consistent).
- `(init-or-check-layout ',layout
- ',(layout-classoid layout)
- ',(layout-length layout)
- ',(layout-inherits layout)
- ',(layout-depthoid layout)
- ',(layout-n-untagged-slots layout)))))
+ `(%init-or-check-layout ',layout
+ ',(layout-classoid layout)
+ ',(layout-length layout)
+ ',(layout-inherits layout)
+ ',(layout-depthoid layout)
+ ',(layout-n-untagged-slots layout)))))
;;; If LAYOUT's slot values differ from the specified slot values in
;;; any interesting way, then give a warning and return T.
layout)
find-and-init-or-check-layout))
(defun find-and-init-or-check-layout (name length inherits depthoid nuntagged)
- (let ((layout (find-layout name)))
- (init-or-check-layout layout
- (or (find-classoid name nil)
- (layout-classoid layout))
- length
- inherits
- depthoid
- nuntagged)))
+ (with-world-lock ()
+ (let ((layout (find-layout name)))
+ (%init-or-check-layout layout
+ (or (find-classoid name nil)
+ (layout-classoid layout))
+ length
+ inherits
+ depthoid
+ nuntagged))))
;;; Record LAYOUT as the layout for its class, adding it as a subtype
;;; of all superclasses. This is the operation that "installs" a
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun register-layout (layout &key (invalidate t) destruct-layout)
(declare (type layout layout) (type (or layout null) destruct-layout))
- (let* ((classoid (layout-classoid layout))
- (classoid-layout (classoid-layout classoid))
- (subclasses (classoid-subclasses classoid)))
-
- ;; Attempting to register ourselves with a temporary undefined
- ;; class placeholder is almost certainly a programmer error. (I
- ;; should know, I did it.) -- WHN 19990927
- (aver (not (undefined-classoid-p classoid)))
-
- ;; This assertion dates from classic CMU CL. The rationale is
- ;; probably that calling REGISTER-LAYOUT more than once for the
- ;; same LAYOUT is almost certainly a programmer error.
- (aver (not (eq classoid-layout layout)))
-
- ;; Figure out what classes are affected by the change, and issue
- ;; appropriate warnings and invalidations.
- (when classoid-layout
- (modify-classoid classoid)
- (when subclasses
- (dohash ((subclass subclass-layout) subclasses :locked t)
- (modify-classoid subclass)
- (when invalidate
- (invalidate-layout subclass-layout))))
- (when invalidate
- (invalidate-layout classoid-layout)
- (setf (classoid-subclasses classoid) nil)))
-
- (if destruct-layout
- (setf (layout-invalid destruct-layout) nil
- (layout-inherits destruct-layout) (layout-inherits layout)
- (layout-depthoid destruct-layout)(layout-depthoid layout)
- (layout-length destruct-layout) (layout-length layout)
- (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
- (layout-info destruct-layout) (layout-info layout)
- (classoid-layout classoid) destruct-layout)
- (setf (layout-invalid layout) nil
- (classoid-layout classoid) layout))
-
- (dovector (super-layout (layout-inherits layout))
- (let* ((super (layout-classoid super-layout))
- (subclasses (or (classoid-subclasses super)
- (setf (classoid-subclasses super)
- (make-hash-table :test 'eq
- #-sb-xc-host #-sb-xc-host
- :synchronized t)))))
- (when (and (eq (classoid-state super) :sealed)
- (not (gethash classoid subclasses)))
- (warn "unsealing sealed class ~S in order to subclass it"
- (classoid-name super))
- (setf (classoid-state super) :read-only))
- (setf (gethash classoid subclasses)
- (or destruct-layout layout)))))
+ (with-world-lock ()
+ (let* ((classoid (layout-classoid layout))
+ (classoid-layout (classoid-layout classoid))
+ (subclasses (classoid-subclasses classoid)))
+
+ ;; Attempting to register ourselves with a temporary undefined
+ ;; class placeholder is almost certainly a programmer error. (I
+ ;; should know, I did it.) -- WHN 19990927
+ (aver (not (undefined-classoid-p classoid)))
+
+ ;; This assertion dates from classic CMU CL. The rationale is
+ ;; probably that calling REGISTER-LAYOUT more than once for the
+ ;; same LAYOUT is almost certainly a programmer error.
+ (aver (not (eq classoid-layout layout)))
+
+ ;; Figure out what classes are affected by the change, and issue
+ ;; appropriate warnings and invalidations.
+ (when classoid-layout
+ (%modify-classoid classoid)
+ (when subclasses
+ (dohash ((subclass subclass-layout) subclasses :locked t)
+ (%modify-classoid subclass)
+ (when invalidate
+ (%invalidate-layout subclass-layout))))
+ (when invalidate
+ (%invalidate-layout classoid-layout)
+ (setf (classoid-subclasses classoid) nil)))
+
+ (if destruct-layout
+ (setf (layout-invalid destruct-layout) nil
+ (layout-inherits destruct-layout) (layout-inherits layout)
+ (layout-depthoid destruct-layout)(layout-depthoid layout)
+ (layout-length destruct-layout) (layout-length layout)
+ (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
+ (layout-info destruct-layout) (layout-info layout)
+ (classoid-layout classoid) destruct-layout)
+ (setf (layout-invalid layout) nil
+ (classoid-layout classoid) layout))
+
+ (dovector (super-layout (layout-inherits layout))
+ (let* ((super (layout-classoid super-layout))
+ (subclasses (or (classoid-subclasses super)
+ (setf (classoid-subclasses super)
+ (make-hash-table :test 'eq
+ #-sb-xc-host #-sb-xc-host
+ :synchronized t)))))
+ (when (and (eq (classoid-state super) :sealed)
+ (not (gethash classoid subclasses)))
+ (warn "unsealing sealed class ~S in order to subclass it"
+ (classoid-name super))
+ (setf (classoid-state super) :read-only))
+ (setf (gethash classoid subclasses)
+ (or destruct-layout layout))))))
(values))
); EVAL-WHEN
(:make-load-form-fun (lambda (c)
`(find-classoid-cell
',(classoid-cell-name c)
- :errorp t)))
+ :create t)))
#-no-ansi-print-object
(:print-object (lambda (s stream)
(print-unreadable-object (s stream :type t)
;; PCL class, if any
(pcl-class nil))
+;;; Protected by the hash-table lock, used only in FIND-CLASSOID-CELL.
(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 (with-locked-system-table (table)
(or (gethash real-name table)
(when create
(setf (gethash real-name table) (make-classoid-cell real-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)
+ (with-world-lock ()
(let ((cell (find-classoid-cell name :create t)))
(ecase (info :type :kind name)
((nil))
(:primitive
(error "Cannot redefine standard type ~S." name))
(:defined
- (warn "Redefining DEFTYPE type to be a class: ~S" name)
+ (warn "redefining DEFTYPE type to be a class: ~
+ ~/sb-impl::print-symbol-with-prefix/" name)
(setf (info :type :expander name) nil
(info :type :lambda-list name) nil
(info :type :source-location name) nil)))
(classoid-layout new-value))))))
new-value)
- (defun clear-classoid (name cell)
+ (defun %clear-classoid (name cell)
(ecase (info :type :kind name)
((nil))
(:defined)
;; 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)
+ ;; Remove the proper name of the classoid, if this was it.
+ (let* ((classoid (classoid-cell-classoid cell))
+ (proper-name (classoid-name classoid)))
+ (when (eq proper-name name)
+ (setf (classoid-name classoid) nil)))
+
;; Clear the cell.
(setf (classoid-cell-classoid cell) nil
(classoid-cell-pcl-class cell) nil))
(defun insured-find-classoid (name predicate constructor)
(declare (type function predicate constructor))
(let ((table *forward-referenced-layouts*))
- (with-locked-hash-table (table)
+ (with-locked-system-table (table)
(let* ((old (find-classoid name nil))
(res (if (and old (funcall predicate old))
old
;;; We might be passed classoids with invalid layouts; in any pairwise
;;; class comparison, we must ensure that both are valid before
;;; proceeding.
-(defun ensure-classoid-valid (classoid layout)
+(defun %ensure-classoid-valid (classoid layout error-context)
(aver (eq classoid (layout-classoid layout)))
- (when (layout-invalid layout)
- (if (typep classoid 'standard-classoid)
- (let ((class (classoid-pcl-class classoid)))
- (cond
- ((sb!pcl:class-finalized-p class)
- (sb!pcl::force-cache-flushes class))
- ((sb!pcl::class-has-a-forward-referenced-superclass-p class)
- (error "Invalid, unfinalizeable class ~S (classoid ~S)."
- class classoid))
- (t (sb!pcl:finalize-inheritance class))))
- (error "Don't know how to ensure validity of ~S (not ~
- a STANDARD-CLASSOID)." classoid))))
-
-(defun ensure-both-classoids-valid (class1 class2)
+ (or (not (layout-invalid layout))
+ (if (typep classoid 'standard-classoid)
+ (let ((class (classoid-pcl-class classoid)))
+ (cond
+ ((sb!pcl:class-finalized-p class)
+ (sb!pcl::%force-cache-flushes class)
+ t)
+ ((sb!pcl::class-has-a-forward-referenced-superclass-p class)
+ (when error-context
+ (bug "~@<Invalid class ~S with forward-referenced superclass ~
+ ~S in ~A.~%~:@>"
+ class
+ (sb!pcl::class-has-a-forward-referenced-superclass-p class)
+ error-context))
+ nil)
+ (t
+ (sb!pcl:finalize-inheritance class)
+ t)))
+ (bug "~@<Don't know how to ensure validity of ~S (not a STANDARD-CLASSOID) ~
+ for ~A.~%~:@>"
+ classoid (or error-context 'subtypep)))))
+
+(defun %ensure-both-classoids-valid (class1 class2 &optional errorp)
(do ((layout1 (classoid-layout class1) (classoid-layout class1))
(layout2 (classoid-layout class2) (classoid-layout class2))
(i 0 (+ i 1)))
- ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))))
+ ((and (not (layout-invalid layout1)) (not (layout-invalid layout2)))
+ t)
(aver (< i 2))
- (ensure-classoid-valid class1 layout1)
- (ensure-classoid-valid class2 layout2)))
+ (unless (and (%ensure-classoid-valid class1 layout1 errorp)
+ (%ensure-classoid-valid class2 layout2 errorp))
+ (return-from %ensure-both-classoids-valid nil))))
(defun update-object-layout-or-invalid (object layout)
- (if (typep (classoid-of object) 'standard-classoid)
+ (if (layout-for-std-class-p (layout-of object))
(sb!pcl::check-wrapper-validity object)
(sb!c::%layout-invalid-error object layout)))
(!define-type-method (classoid :simple-subtypep) (class1 class2)
(aver (not (eq class1 class2)))
- (ensure-both-classoids-valid class1 class2)
- (let ((subclasses (classoid-subclasses class2)))
- (if (and subclasses (gethash class1 subclasses))
- (values t t)
- (values nil t))))
+ (with-world-lock ()
+ (if (%ensure-both-classoids-valid class1 class2)
+ (let ((subclasses2 (classoid-subclasses class2)))
+ (if (and subclasses2 (gethash class1 subclasses2))
+ (values t t)
+ (if (and (typep class1 'standard-classoid)
+ (typep class2 'standard-classoid)
+ (or (sb!pcl::class-has-a-forward-referenced-superclass-p
+ (classoid-pcl-class class1))
+ (sb!pcl::class-has-a-forward-referenced-superclass-p
+ (classoid-pcl-class class2))))
+ ;; If there's a forward-referenced class involved we don't know for sure.
+ ;; (There are cases which we /could/ figure out, but that doesn't seem
+ ;; to be required or important, really.)
+ (values nil nil)
+ (values nil t))))
+ (values nil nil))))
;;; When finding the intersection of a sealed class and some other
;;; class (not hierarchically related) the intersection is the union
(!define-type-method (classoid :simple-intersection2) (class1 class2)
(declare (type classoid class1 class2))
- (ensure-both-classoids-valid class1 class2)
- (cond ((eq class1 class2)
- class1)
- ;; If one is a subclass of the other, then that is the
- ;; intersection.
- ((let ((subclasses (classoid-subclasses class2)))
- (and subclasses (gethash class1 subclasses)))
- class1)
- ((let ((subclasses (classoid-subclasses class1)))
- (and subclasses (gethash class2 subclasses)))
- class2)
- ;; Otherwise, we can't in general be sure that the
- ;; intersection is empty, since a subclass of both might be
- ;; defined. But we can eliminate it for some special cases.
- ((or (structure-classoid-p class1)
- (structure-classoid-p class2))
- ;; No subclass of both can be defined.
- *empty-type*)
- ((eq (classoid-state class1) :sealed)
- ;; checking whether a subclass of both can be defined:
- (sealed-class-intersection2 class1 class2))
- ((eq (classoid-state class2) :sealed)
- ;; checking whether a subclass of both can be defined:
- (sealed-class-intersection2 class2 class1))
- (t
- ;; uncertain, since a subclass of both might be defined
- nil)))
+ (with-world-lock ()
+ (%ensure-both-classoids-valid class1 class2 "type intersection")
+ (cond ((eq class1 class2)
+ class1)
+ ;; If one is a subclass of the other, then that is the
+ ;; intersection.
+ ((let ((subclasses (classoid-subclasses class2)))
+ (and subclasses (gethash class1 subclasses)))
+ class1)
+ ((let ((subclasses (classoid-subclasses class1)))
+ (and subclasses (gethash class2 subclasses)))
+ class2)
+ ;; Otherwise, we can't in general be sure that the
+ ;; intersection is empty, since a subclass of both might be
+ ;; defined. But we can eliminate it for some special cases.
+ ((or (structure-classoid-p class1)
+ (structure-classoid-p class2))
+ ;; No subclass of both can be defined.
+ *empty-type*)
+ ((eq (classoid-state class1) :sealed)
+ ;; checking whether a subclass of both can be defined:
+ (sealed-class-intersection2 class1 class2))
+ ((eq (classoid-state class2) :sealed)
+ ;; checking whether a subclass of both can be defined:
+ (sealed-class-intersection2 class2 class1))
+ (t
+ ;; uncertain, since a subclass of both might be defined
+ nil))))
;;; KLUDGE: we need this to deal with the special-case INSTANCE and
;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
:inherits (complex number)
:codes (#.sb!vm:complex-long-float-widetag)
:prototype-form (complex 42l0 42l0))
+ #!+sb-simd-pack
+ (simd-pack
+ :translation simd-pack
+ :codes (#.sb!vm:simd-pack-widetag)
+ :prototype-form (%make-simd-pack-ub64 42 42))
(real :translation real :inherits (number))
(float
:translation float
:translation (integer #.sb!xc:most-negative-fixnum
#.sb!xc:most-positive-fixnum)
:inherits (integer rational real number)
- :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)
+ :codes #.(mapcar #'symbol-value sb!vm::fixnum-lowtags)
:prototype-form 42)
(bignum
:translation (and integer (not fixnum))
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence)
:prototype-form (make-array 0 :element-type '(unsigned-byte 16)))
- #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
- (simple-array-unsigned-byte-29
- :translation (simple-array (unsigned-byte 29) (*))
- :codes (#.sb!vm:simple-array-unsigned-byte-29-widetag)
+
+ (simple-array-unsigned-fixnum
+ :translation (simple-array (unsigned-byte #.sb!vm:n-positive-fixnum-bits) (*))
+ :codes (#.sb!vm:simple-array-unsigned-fixnum-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence)
- :prototype-form (make-array 0 :element-type '(unsigned-byte 29)))
+ :prototype-form (make-array 0
+ :element-type '(unsigned-byte #.sb!vm:n-positive-fixnum-bits)))
+
(simple-array-unsigned-byte-31
:translation (simple-array (unsigned-byte 31) (*))
:codes (#.sb!vm:simple-array-unsigned-byte-31-widetag)
:inherits (vector simple-array array sequence)
:prototype-form (make-array 0 :element-type '(unsigned-byte 32)))
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
- (simple-array-unsigned-byte-60
- :translation (simple-array (unsigned-byte 60) (*))
- :codes (#.sb!vm:simple-array-unsigned-byte-60-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence)
- :prototype-form (make-array 0 :element-type '(unsigned-byte 60)))
- #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
(simple-array-unsigned-byte-63
:translation (simple-array (unsigned-byte 63) (*))
:codes (#.sb!vm:simple-array-unsigned-byte-63-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence)
:prototype-form (make-array 0 :element-type '(signed-byte 16)))
- #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
- (simple-array-signed-byte-30
- :translation (simple-array (signed-byte 30) (*))
- :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
+
+ (simple-array-fixnum
+ :translation (simple-array (signed-byte #.sb!vm:n-fixnum-bits)
+ (*))
+ :codes (#.sb!vm:simple-array-fixnum-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence)
- :prototype-form (make-array 0 :element-type '(signed-byte 30)))
+ :prototype-form (make-array 0
+ :element-type
+ '(signed-byte #.sb!vm:n-fixnum-bits)))
+
(simple-array-signed-byte-32
:translation (simple-array (signed-byte 32) (*))
:codes (#.sb!vm:simple-array-signed-byte-32-widetag)
:inherits (vector simple-array array sequence)
:prototype-form (make-array 0 :element-type '(signed-byte 32)))
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
- (simple-array-signed-byte-61
- :translation (simple-array (signed-byte 61) (*))
- :codes (#.sb!vm:simple-array-signed-byte-61-widetag)
- :direct-superclasses (vector simple-array)
- :inherits (vector simple-array array sequence)
- :prototype-form (make-array 0 :element-type '(signed-byte 61)))
- #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
(simple-array-signed-byte-64
:translation (simple-array (signed-byte 64) (*))
:codes (#.sb!vm:simple-array-signed-byte-64-widetag)
;;;; class definition/redefinition
;;; This is to be called whenever we are altering a class.
-(defun modify-classoid (classoid)
+(defun %modify-classoid (classoid)
(clear-type-caches)
(when (member (classoid-state classoid) '(:read-only :frozen))
;; FIXME: This should probably be CERROR.
;;; nominal superclasses.) We set the layout-clos-hash slots to 0 to
;;; invalidate the wrappers for specialized dispatch functions, which
;;; use those slots as indexes into tables.
-(defun invalidate-layout (layout)
+(defun %invalidate-layout (layout)
(declare (type layout layout))
(setf (layout-invalid layout) t
(layout-depthoid layout) -1)
(setf (layout-clos-hash layout) 0)
(let ((inherits (layout-inherits layout))
(classoid (layout-classoid layout)))
- (modify-classoid classoid)
+ (%modify-classoid classoid)
(dovector (super inherits)
(let ((subs (classoid-subclasses (layout-classoid super))))
(when subs
projects / sbcl.git / blobdiff