Commit f1bc883e authored by Daniel Kochmański's avatar Daniel Kochmański Committed by Marius Gerbershagen
Browse files

clos: introduce class stamps for marking instances obsolete

We should call make-instances-obsolete from finalize-inheritance if we
want to be conforming, because user may have added their own auxiliary
methods.

This change while being last in a serie of commits was locally the
first change which solved problems. It will enable us to implement the
fast generic dispatch after the release.
parent 81a85f37
......@@ -686,6 +686,15 @@ ecl_alloc_instance(cl_index slots)
return i;
}
static cl_index stamp = 0;
cl_index ecl_next_stamp() {
#if ECL_THREADS
return AO_fetch_and_add((AO_t*)&stamp, 1) + 1;
#else
return ++stamp;
#endif
}
void *
ecl_alloc_uncollectable(size_t size)
{
......
......@@ -60,6 +60,8 @@ reshape_instance(cl_object x, int delta)
cl_object aux = ecl_allocate_instance(ECL_CLASS_OF(x), size);
/* Except for the different size, this must match si_copy_instance */
aux->instance.sig = x->instance.sig;
aux->instance.stamp = x->instance.stamp;
aux->instance.class_stamp = x->instance.class_stamp;
memcpy(aux->instance.slots, x->instance.slots,
(delta < 0 ? aux->instance.length : x->instance.length) *
sizeof(cl_object));
......
......@@ -43,17 +43,30 @@ si_allocate_raw_instance(cl_object orig, cl_object clas, cl_object size)
cl_object
si_instance_obsolete_p(cl_object x)
{
/* The up-to-date status of a class is determined by instance.sig.
This slot contains a list of slot definitions that was used to
create the instance. When the class is updated, the list is newly
created. Structures are also "instances" but keep ECL_UNBOUND
instead of the list. */
if (x->instance.sig == ECL_UNBOUND)
/* Each class has a slot class_stamp and each instance has a slot
stamp. When an instance stamp its class class_stamp don't match,
then the instance is obsolete. Structure stamp is always 0. */
if (x->instance.stamp == 0)
return ECL_NIL;
return (x->instance.sig != ECL_CLASS_SLOTS(ECL_CLASS_OF(x)))
return (x->instance.stamp != ECL_CLASS_OF(x)->instance.class_stamp)
? ECL_T : ECL_NIL;
}
cl_object
si_instance_new_stamp(cl_object x)
{
x->instance.class_stamp = ecl_next_stamp();
return ecl_make_fixnum(x->instance.class_stamp);
}
cl_object
si_instance_get_stamp(cl_object x)
{
cl_object a = ecl_make_fixnum(x->instance.stamp);
cl_object b = ecl_make_fixnum(ECL_CLASS_OF(x)->instance.class_stamp);
@(return a b);
}
cl_object
si_instance_sig(cl_object x)
{
......@@ -63,6 +76,7 @@ si_instance_sig(cl_object x)
cl_object
si_instance_sig_set(cl_object x)
{
x->instance.stamp = ECL_CLASS_OF(x)->instance.class_stamp;
@(return (x->instance.sig = ECL_CLASS_SLOTS(ECL_CLASS_OF(x))));
}
......@@ -283,6 +297,8 @@ si_copy_instance(cl_object x)
}
y = ecl_allocate_instance(x->instance.clas, x->instance.length);
y->instance.sig = x->instance.sig;
y->instance.stamp = x->instance.stamp;
y->instance.class_stamp = x->instance.class_stamp;
memcpy(y->instance.slots, x->instance.slots,
x->instance.length * sizeof(cl_object));
@(return y);
......
......@@ -1295,6 +1295,8 @@ cl_symbols[] = {
{SYS_ "INSTANCE-REF", SI_ORDINARY, si_instance_ref, 2, OBJNULL},
{SYS_ "INSTANCE-SET", SI_ORDINARY, si_instance_set, 3, OBJNULL},
{SYS_ "INSTANCE-OBSOLETE-P", SI_ORDINARY, si_instance_obsolete_p, 1, OBJNULL},
{SYS_ "INSTANCE-NEW-STAMP", SI_ORDINARY, si_instance_new_stamp, 1, OBJNULL},
{SYS_ "INSTANCE-GET-STAMP", SI_ORDINARY, si_instance_get_stamp, 1, OBJNULL},
{SYS_ "INSTANCE-SIG", SI_ORDINARY, si_instance_sig, 1, OBJNULL},
{SYS_ "INSTANCE-SIG-SET", SI_ORDINARY, si_instance_sig_set, 1, OBJNULL},
{SYS_ "INSTANCE-CLASS", SI_ORDINARY, si_instance_class, 1, OBJNULL},
......
......@@ -1295,6 +1295,8 @@ cl_symbols[] = {
{SYS_ "INSTANCE-REF","si_instance_ref",2},
{SYS_ "INSTANCE-SET","si_instance_set",3},
{SYS_ "INSTANCE-OBSOLETE-P","si_instance_obsolete_p",1},
{SYS_ "INSTANCE-NEW-STAMP","si_instance_new_stamp",1},
{SYS_ "INSTANCE-GET-STAMP","si_instance_get_stamp",1},
{SYS_ "INSTANCE-SIG","si_instance_sig",1},
{SYS_ "INSTANCE-SIG-SET","si_instance_sig_set",1},
{SYS_ "INSTANCE-CLASS","si_instance_class",1},
......
......@@ -56,6 +56,7 @@
(compute-clos-class-precedence-list class superclasses)))
(when index
(setf (aref +builtin-classes-pre-array+ index) class))
(si:instance-new-stamp class)
class)))
(defun remove-accessors (slotds)
......
......@@ -83,15 +83,21 @@
;;;
;;; PART 2: UPDATING AN INSTANCE THAT BECAME OBSOLETE
;;;
;;; Each instance has a hidden field (readable with SI::INSTANCE-SIG), which
;;; contains the list of slots of its class. This field is updated every time
;;; the class is initialized or reinitialized. Generally
;;; (EQ (SI::INSTANCE-SIG x) (CLASS-SLOTS (CLASS-OF x)))
;;; returns NIL whenever the class became obsolete.
;;; Each instance has a hidden field (readable with SI::INSTANCE-SIG),
;;; which contains the list of slots of its class which are needed to
;;; update it when it is obsolete. Generally
;;;
;;; There are two circumstances under which a instance may become obsolete:
;;; either the class has been modified using REDEFINE-INSTANCE (and thus the
;;; list of slots changed), or MAKE-INSTANCES-OBSOLETE has been used.
;;; (SI::INSTANCE-OBSOLETE-P x)
;;;
;;; returns T whenever the instance became obsolete. We track that by
;;; comparing the class stamp (which is updated by M-I-O) with a stamp
;;; embedded in the instance. When the instance is being updated its
;;; stamp is corrected to match its class stamp.
;;;
;;; There are two circumstances under which a instance may become
;;; obsolete: either the class has been modified so the list of slots
;;; has changed in an incompatible way (see FINALIZE-INHERITANCE), or
;;; MAKE-INSTANCES-OBSOLETE has been called explicitly.
;;;
;;; The function UPDATE-INSTANCE (hidden to the user) does the job of
;;; updating an instance that has become obsolete.
......@@ -235,7 +241,7 @@
(null new-slotds)))))
(defmethod make-instances-obsolete ((class class))
(setf (class-slots class) (copy-list (class-slots class)))
(si::instance-new-stamp class)
class)
(defun remove-optional-slot-accessors (class)
......
......@@ -302,63 +302,59 @@ because it contains a reference to the undefined class~% ~A"
(finalize-inheritance x))))
(setf (class-precedence-list class) cpl)
(let ((slots (compute-slots class)))
;; We don't change identity of class-slots when slot definitions
;; are compatible to avoid making instances obsolete. This is
;; allowed by the standard (see MAKE-INSTANCES-OBSOLETE).
(if (and (slot-boundp class 'slots)
(slot-definitions-compatible-p (class-slots class) slots))
(map-into (class-slots class) #'identity slots)
(setf (class-slots class) slots))
(setf (class-size class) (compute-instance-size slots)
(let ((oslotds (and (slot-boundp class 'slots) (class-slots class)))
(nslotds (compute-slots class)))
(setf (class-slots class) nslotds
(class-size class) (compute-instance-size nslotds)
(class-default-initargs class) (compute-default-initargs class)
(class-finalized-p class) t))
(class-finalized-p class) t)
;;
;; When a class is sealed we rewrite the list of direct slots to fix
;; their locations. This may imply adding _new_ direct slots.
;;
(when (class-sealedp class)
(let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name
(class-slots class))))
(all-slots (class-slots class)))
;;
;; We first search all slots that belonged to unsealed classes and which
;; therefore have no fixed position.
;;
(loop for c in cpl
do (loop for slotd in (class-direct-slots c)
when (safe-slot-definition-location slotd)
do (setf free-slots (delete (slot-definition-name slotd)
free-slots))))
;;
;; We now copy the locations of the effective slots in this class to
;; the class direct slots.
;;
(loop for slotd in (class-direct-slots class)
do (let* ((name (slot-definition-name slotd))
(other-slotd (find name all-slots :key #'slot-definition-name)))
(setf (slot-definition-location slotd)
(slot-definition-location other-slotd)
free-slots (delete name free-slots))))
;;
;; And finally we add one direct slot for each inherited slot that did
;; not have a fixed location.
;;
(loop for name in free-slots
with direct-slots = (class-direct-slots class)
do (let* ((effective-slotd (find name all-slots :key #'slot-definition-name))
(def (direct-slot-to-canonical-slot effective-slotd)))
(push (apply #'make-instance (direct-slot-definition-class class def)
def)
direct-slots))
finally (setf (class-direct-slots class) direct-slots))))
;;
;; Make all class instances obsolete when slot definitions are
;; not compatible.
;;
(unless (slot-definitions-compatible-p oslotds nslotds)
(make-instances-obsolete class)))
;;
;; When a class is sealed we rewrite the list of direct slots to fix
;; their locations. This may imply adding _new_ direct slots.
;;
(when (class-sealedp class)
(let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name
(class-slots class))))
(all-slots (class-slots class)))
;;
;; We first search all slots that belonged to unsealed classes and which
;; therefore have no fixed position.
;;
(loop for c in cpl
do (loop for slotd in (class-direct-slots c)
when (safe-slot-definition-location slotd)
do (setf free-slots (delete (slot-definition-name slotd)
free-slots))))
;;
;; We now copy the locations of the effective slots in this class to
;; the class direct slots.
;;
(loop for slotd in (class-direct-slots class)
do (let* ((name (slot-definition-name slotd))
(other-slotd (find name all-slots :key #'slot-definition-name)))
(setf (slot-definition-location slotd)
(slot-definition-location other-slotd)
free-slots (delete name free-slots))))
;;
;; And finally we add one direct slot for each inherited slot that did
;; not have a fixed location.
;;
(loop for name in free-slots
with direct-slots = (class-direct-slots class)
do (let* ((effective-slotd (find name all-slots :key #'slot-definition-name))
(def (direct-slot-to-canonical-slot effective-slotd)))
(push (apply #'make-instance (direct-slot-definition-class class def)
def)
direct-slots))
finally (setf (class-direct-slots class) direct-slots))))
;;
;; This is not really needed, because when we modify the list of slots
;; all instances automatically become obsolete (See change.lsp)
#+ (or) (make-instances-obsolete class)
;;
;; But this is really needed: we have to clear the different type caches
;; for type comparisons and so on.
;; Clear the different type caches for type comparisons and so on.
;;
(si::subtypep-clear-cache))
;; As mentioned above, when a parent is finalized, it is responsible for
......
......@@ -141,16 +141,11 @@
;;; INSTANCE UPDATE PREVIOUS
;;;
(eval-when (:compile-toplevel :execute)
(defmacro ensure-up-to-date-instance (instance)
;; The up-to-date status of a class is determined by
;; instance.sig. This slot of the C structure contains a list of
;; slot definitions that was used to create the instance. When the
;; class is updated, the list is newly created. Structures are
;; also "instances" but keep ECL_UNBOUND instead of the list.
`(let ((instance ,instance))
(declare (:read-only instance))
(when (si::instance-obsolete-p instance)
(update-instance instance)))))
(defmacro ensure-up-to-date-instance (instance)
`(let ((instance ,instance))
(declare (:read-only instance))
(when (si::instance-obsolete-p instance)
(update-instance instance)))))
(defun update-instance (x)
(si::instance-sig-set x))
......
......@@ -841,6 +841,8 @@ extern ECL_API cl_object si_unbound(void);
extern ECL_API cl_object si_sl_boundp(cl_object x);
extern ECL_API cl_object si_sl_makunbound(cl_object x, cl_object index);
extern ECL_API cl_object si_instance_obsolete_p(cl_object x);
extern ECL_API cl_object si_instance_new_stamp(cl_object x);
extern ECL_API cl_object si_instance_get_stamp(cl_object x);
extern ECL_API cl_object si_instance_sig(cl_object x);
extern ECL_API cl_object si_instance_sig_set(cl_object x);
......
......@@ -63,6 +63,7 @@ extern void _ecl_dealloc_env(cl_env_ptr);
extern void _ecl_set_max_heap_size(size_t new_size);
extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size);
extern cl_index ecl_object_byte_size(cl_type t);
extern cl_index ecl_next_stamp();
/* array.d */
......
......@@ -1039,13 +1039,15 @@ struct ecl_condition_variable {
#define ECL_WRITER_DISPATCH 4
#define ECL_USER_DISPATCH 5
struct ecl_instance { /* instance header */
_ECL_HDR1(isgf);
cl_index length; /* instance length */
cl_object clas; /* instance class */
cl_objectfn entry; /* entry address */
cl_object sig; /* generation signature */
cl_object *slots; /* instance slots */
struct ecl_instance { /* -- instance header -- */
_ECL_HDR1(isgf); /* gf type */
cl_index length; /* instance length */
cl_object clas; /* instance class */
cl_objectfn entry; /* entry address */
cl_object sig; /* instance class slots */
cl_object *slots; /* instance slots */
cl_index stamp; /* instance stamp */
cl_index class_stamp; /* class stamp */
};
#ifdef ECL_SSE2
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment