X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=fc7ed296f292a9a40e9a67d13b89b50967ff502c;hb=993c261469bbf6201c6fae04fcdf255d38cf419d;hp=86827210e3d6e118041d52df04e8cc9a7492dca0;hpb=5ee902ed6ceef841efee4a50459ff545293a1d95;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index 8682721..fc7ed29 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -51,7 +51,7 @@ ;; :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; @@ -84,9 +84,10 @@ ;;; 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 ;;; @@ -100,10 +101,12 @@ ;;; 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*"))) @@ -113,6 +116,13 @@ ;;; 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 @@ -136,30 +146,9 @@ ;; 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: @@ -205,7 +194,19 @@ ;; 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) @@ -220,23 +221,6 @@ ;;;; 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 @@ -254,7 +238,7 @@ ;; ;; 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* @@ -266,14 +250,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-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 @@ -287,8 +275,8 @@ (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 @@ -343,12 +331,12 @@ `(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. @@ -381,7 +369,7 @@ (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 @@ -435,8 +423,7 @@ ;; 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)) @@ -450,14 +437,15 @@ 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 @@ -471,56 +459,59 @@ (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 @@ -613,7 +604,7 @@ (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))) @@ -693,122 +684,220 @@ (: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) - (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))) ;;;; CLASS type operations (!define-type-class classoid) +;;; 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 error-context) + (aver (eq classoid (layout-classoid layout))) + (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 "~@" + class + (sb!pcl::class-has-a-forward-referenced-superclass-p class) + error-context)) + nil) + (t + (sb!pcl:finalize-inheritance class) + t))) + (bug "~@" + 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))) + t) + (aver (< i 2)) + (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 (layout-for-std-class-p (layout-of object)) + (sb!pcl::check-wrapper-validity object) + (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 ;;; operations. @@ -818,10 +907,23 @@ NIL is returned when no such class exists." (!define-type-method (classoid :simple-subtypep) (class1 class2) (aver (not (eq 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 @@ -832,7 +934,7 @@ NIL is returned when no such class exists." (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)))) @@ -841,32 +943,34 @@ NIL is returned when no such class exists." (!define-type-method (classoid :simple-intersection2) (class1 class2) (declare (type classoid 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 @@ -899,12 +1003,16 @@ NIL is returned when no such class exists." ;;;; PCL stuff -(def!struct (std-classoid (:include classoid) - (:constructor nil))) -(def!struct (standard-classoid (:include std-classoid) +;;; the CLASSOID that we use to represent type information for +;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system +;;; side does not need to distinguish between STANDARD-CLASS and +;;; FUNCALLABLE-STANDARD-CLASS. +(def!struct (standard-classoid (:include classoid) (:constructor make-standard-classoid))) -(def!struct (random-pcl-classoid (:include std-classoid) - (:constructor make-random-pcl-classoid))) +;;; a metaclass for classes which aren't standardlike but will never +;;; change either. +(def!struct (static-classoid (:include classoid) + (:constructor make-static-classoid))) ;;;; built-in classes @@ -996,6 +1104,11 @@ NIL is returned when no such class exists." :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 @@ -1031,7 +1144,7 @@ NIL is returned when no such class exists." :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)) @@ -1047,7 +1160,9 @@ NIL is returned when no such class exists." :inherits (array) :prototype-form (make-array nil)) (sequence - :translation (or cons (member nil) vector)) + :translation (or cons (member nil) vector extended-sequence) + :state :read-only + :depth 2) (vector :translation vector :codes (#.sb!vm:complex-vector-widetag) :direct-superclasses (array sequence) @@ -1103,13 +1218,15 @@ NIL is returned when no such class exists." :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) @@ -1123,13 +1240,6 @@ NIL is returned when no such class exists." :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) @@ -1155,13 +1265,17 @@ NIL is returned when no such class exists." :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) @@ -1169,13 +1283,6 @@ NIL is returned when no such class exists." :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) @@ -1326,7 +1433,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 @@ -1379,11 +1486,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) @@ -1404,7 +1510,7 @@ NIL is returned when no such class exists." ;;;; 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. @@ -1419,15 +1525,14 @@ NIL is returned when no such class exists." ;;; 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 @@ -1442,17 +1547,15 @@ NIL is returned when no such class exists." ;;; 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*") @@ -1473,6 +1576,13 @@ NIL is returned when no such class exists." (let ((layout (classoid-layout (find-classoid name)))) (dolist (code codes) (setf (svref res code) layout))))))) + (setq *null-classoid-layout* + ;; KLUDGE: we use (LET () ...) instead of a LOCALLY here to + ;; work around a bug in the LOCALLY handling in the fopcompiler + ;; (present in 0.9.13-0.9.14.18). -- JES, 2006-07-16 + (let () + (declare (notinline find-classoid)) + (classoid-layout (find-classoid 'null)))) #-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*")) (!defun-from-collected-cold-init-forms !classes-cold-init)