;; :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;
;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
;;; in order to guarantee that several hash values can be added without
;;; overflowing into a bignum.
-(def!constant layout-clos-hash-max (ash sb!xc:most-positive-fixnum -3)
+(def!constant layout-clos-hash-limit (1+ (ash sb!xc:most-positive-fixnum -3))
#!+sb-doc
- "the inclusive upper bound on LAYOUT-CLOS-HASH values")
+ "the exclusive upper bound on LAYOUT-CLOS-HASH values")
+(def!type layout-clos-hash () '(integer 0 #.layout-clos-hash-limit))
;;; a list of conses, initialized by genesis
;;;
;;; 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*")))
;;; type checking and garbage collection. Whenever a class is
;;; incompatibly redefined, a new layout is allocated. If two object's
;;; layouts are EQ, then they are exactly the same type.
+;;;
+;;; *** IMPORTANT ***
+;;;
+;;; If you change the slots of LAYOUT, you need to alter genesis as
+;;; well, since the initialization of layout slots is hardcoded there.
+;;;
+;;; FIXME: ...it would be better to automate this, of course...
(def!struct (layout
;; KLUDGE: A special hack keeps this from being
;; called when building code for the
;; DEF!STRUCT setup. -- WHN 19990930
#+sb-xc-host
make-load-form-for-layout))
- ;; hash bits which should be set to constant pseudo-random values
- ;; for use by CLOS. Sleazily accessed via %INSTANCE-REF, see
- ;; LAYOUT-CLOS-HASH.
- ;;
- ;; FIXME: We should get our story straight on what the type of these
- ;; values is. (declared INDEX here, described as <=
- ;; LAYOUT-CLOS-HASH-MAX by the doc string of that constant,
- ;; generated as strictly positive in RANDOM-LAYOUT-CLOS-HASH..)
- ;;
- ;; [ CSR notes, several years later (2005-11-30) that the value 0 is
- ;; special for these hash slots, indicating that the wrapper is
- ;; obsolete. ]
- ;;
- ;; KLUDGE: The fact that the slots here start at offset 1 is known
- ;; to the LAYOUT-CLOS-HASH function and to the LAYOUT-dumping code
- ;; in GENESIS.
- (clos-hash-0 (random-layout-clos-hash) :type index)
- (clos-hash-1 (random-layout-clos-hash) :type index)
- (clos-hash-2 (random-layout-clos-hash) :type index)
- (clos-hash-3 (random-layout-clos-hash) :type index)
- (clos-hash-4 (random-layout-clos-hash) :type index)
- (clos-hash-5 (random-layout-clos-hash) :type index)
- (clos-hash-6 (random-layout-clos-hash) :type index)
- (clos-hash-7 (random-layout-clos-hash) :type index)
+ ;; a pseudo-random hash value for use by CLOS. KLUDGE: The fact
+ ;; that this slot is at offset 1 is known to GENESIS.
+ (clos-hash (random-layout-clos-hash) :type layout-clos-hash)
;; the class that this is a layout for
(classoid (missing-arg) :type classoid)
;; The value of this slot can be:
;; This slot is known to the C runtime support code.
(n-untagged-slots 0 :type index)
;; Definition location
- (source-location nil))
+ (source-location nil)
+ ;; Information about slots in the class to PCL: this provides fast
+ ;; access to slot-definitions and locations by name, etc.
+ (slot-table #(nil) :type simple-vector)
+ ;; True IFF the layout belongs to a standand-instance or a
+ ;; standard-funcallable-instance -- that is, true only if the layout
+ ;; is really a wrapper.
+ ;;
+ ;; FIXME: If we unify wrappers and layouts this can go away, since
+ ;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then
+ ;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot
+ ;; layouts, there are no slots for it to pull.)
+ (for-std-class-p nil :type boolean :read-only t))
(def!method print-object ((layout layout) stream)
(print-unreadable-object (layout stream :type t :identity t)
\f
;;;; support for the hash values used by CLOS when working with LAYOUTs
-(def!constant layout-clos-hash-length 8)
-#!-sb-fluid (declaim (inline layout-clos-hash))
-(defun layout-clos-hash (layout i)
- ;; FIXME: Either this I should be declared to be `(MOD
- ;; ,LAYOUT-CLOS-HASH-LENGTH), or this is used in some inner loop
- ;; where we can't afford to check that kind of thing and therefore
- ;; should have some insane level of optimization. (This is true both
- ;; of this function and of the SETF function below.)
- (declare (type layout layout) (type index i))
- ;; FIXME: LAYOUT slots should have type `(MOD ,LAYOUT-CLOS-HASH-MAX),
- ;; not INDEX.
- (truly-the index (%instance-ref layout (1+ i))))
-#!-sb-fluid (declaim (inline (setf layout-clos-hash)))
-(defun (setf layout-clos-hash) (new-value layout i)
- (declare (type layout layout) (type index new-value i))
- (setf (%instance-ref layout (1+ i)) new-value))
-
;;; a generator for random values suitable for the CLOS-HASH slots of
;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
;;; pseudo-random values to come the same way in the target even when
;;
;; an explanation is provided in Kiczales and Rodriguez, "Efficient
;; Method Dispatch in PCL", 1990. -- CSR, 2005-11-30
- (1+ (random layout-clos-hash-max
+ (1+ (random (1- layout-clos-hash-limit)
(if (boundp '*layout-clos-hash-random-state*)
*layout-clos-hash-random-state*
(setf *layout-clos-hash-random-state*
;;; 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-world-lock ()
+ (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
(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.
(when diff
(warn
"in class ~S:~% ~
- ~:(~A~) definition of superclass ~S is incompatible with~% ~
+ ~@(~A~) definition of superclass ~S is incompatible with~% ~
~A definition."
name
old-context
;; priority. (3) We now have the ability to rebuild the SBCL
;; system from scratch, so we no longer need this functionality in
;; order to maintain the SBCL system by modifying running images.
- (error "The class ~S was not changed, and there's no guarantee that~@
- the loaded code (which expected another layout) will work."
+ (error "The loaded code expects an incompatible layout for class ~S."
(layout-proper-name layout)))
(values))
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)
- (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)))))
- (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
(when (zerop count)
(push successor free-objs))))))
(cond ((endp free-objs)
- (dohash (obj info obj-info)
+ (dohash ((obj info) obj-info)
(unless (zerop (first info))
(error "Topological sort failed due to constraint on ~S."
obj)))
(:constructor make-classoid-cell (name &optional classoid))
(:make-load-form-fun (lambda (c)
`(find-classoid-cell
- ',(classoid-cell-name c))))
+ ',(classoid-cell-name c)
+ :create 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))
+
+;;; 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-system-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))))
+
+ (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-world-lock ()
+ (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: ~
+ ~/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)))
+
+ (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, 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))
+ (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-system-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)))
\f
;;;; CLASS type operations
;;; 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)
- (%layout-invalid-error object layout)))
+ (sb!c::%layout-invalid-error object layout)))
;;; Simple methods for TYPE= and SUBTYPEP should never be called when
;;; the two classes are equal, since there are EQ checks in those
(!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
(o-sub (classoid-subclasses other)))
(if (and s-sub o-sub)
(collect ((res *empty-type* type-union))
- (dohash (subclass layout s-sub)
+ (dohash ((subclass layout) s-sub :locked t)
(declare (ignore layout))
(when (gethash subclass o-sub)
(res (specifier-type subclass))))
(!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)))
-
-;;; KLUDGE: we need this for the special-case SEQUENCE type, which
-;;; (because of multiple inheritance with ARRAY for the VECTOR types)
-;;; doesn't have the nice hierarchical properties we want. This is
-;;; basically DELEGATE-COMPLEX-INTERSECTION2 with a special-case for
-;;; SEQUENCE/ARRAY interactions.
-(!define-type-method (classoid :complex-intersection2) (type1 class2)
- (cond
- ((and (eq class2 (find-classoid 'sequence))
- (array-type-p type1))
- (type-intersection2 (specifier-type 'vector) type1))
- (t
- (let ((method (type-class-complex-intersection2 (type-class-info type1))))
- (if (and method (not (eq method #'delegate-complex-intersection2)))
- :call-other-method
- (hierarchical-intersection2 type1 class2))))))
+ (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))
:inherits (array)
:prototype-form (make-array nil))
(sequence
+ :translation (or cons (member nil) vector extended-sequence)
:state :read-only
:depth 2)
(vector
: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)
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
(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)
;;;; 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)
- (dotimes (i layout-clos-hash-length)
- (setf (layout-clos-hash layout i) 0))
+ (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
;;; late in the build-order.lisp-expr sequence, and be put in
;;; !COLD-INIT-FORMS there?
(defun !class-finalize ()
- (dohash (name layout *forward-referenced-layouts*)
+ (dohash ((name layout) *forward-referenced-layouts*)
(let ((class (find-classoid name nil)))
(cond ((not class)
(setf (layout-classoid layout) (make-undefined-classoid name)))
((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*")
projects / sbcl.git / blobdiff