[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Merge 'stable-2.2'
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Merge 'stable-2.2' |
|
Date: |
Mon, 25 Sep 2017 16:18:47 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 84259f54e31064851c82031080f894e2099584a6
Merge: 9211981 a74d4ee
Author: Andy Wingo <address@hidden>
Date: Mon Sep 25 22:18:02 2017 +0200
Merge 'stable-2.2'
Resolve conflicts by removing capability of struct-ref / struct-set! to
access unboxed slots.
NEWS | 9 ++++
doc/ref/api-data.texi | 25 +++++++---
libguile/struct.c | 129 ++++++++++++++++++++++++++++++++------------------
libguile/struct.h | 2 +
module/oop/goops.scm | 93 +++++++++++++++++++++++-------------
5 files changed, 174 insertions(+), 84 deletions(-)
diff --cc doc/ref/api-data.texi
index 923d0f2,677454b..6e0ddf9
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@@ -8781,30 -8781,27 +8781,29 @@@ it's protected against garbage collecti
@item
@code{u} -- an arbitrary word of data (an @code{scm_t_bits}). At the
- Scheme level it's read and written as an unsigned integer. ``u''
- stands for ``uninterpreted'' (it's not treated as a Scheme value), or
- ``unprotected'' (it's not marked during GC), or ``unsigned long'' (its
- size), or all of these things.
+ Scheme level it's read and written as an unsigned integer. ``u'' stands
+ for ``unboxed'', as it's stored as a raw value without additional type
+ annotations.
@end itemize
-The second letter for each field is a permission code,
-
address@hidden @bullet{}
address@hidden
address@hidden -- writable, the field can be read and written.
address@hidden
address@hidden -- read-only, the field can be read but not written.
address@hidden
address@hidden itemize
-
-Here are some examples.
+It used to be that the second letter for each field was a permission
+code, such as @code{w} for writable or @code{r} for read-only. However
+over time structs have become more of a raw low-level facility; access
+control is better implemented as a layer on top. After all,
address@hidden is a cross-cutting operator that can bypass
+abstractions made by higher-level record facilities; it's not generally
+safe (in the sense of abstraction-preserving) to expose
address@hidden to ``untrusted'' code, even if the fields happen to
+be writable. Additionally, permission checks added overhead to every
+structure access in a way that couldn't be optimized out, hampering the
+ability of structs to act as a low-level building block. For all of
+these reasons, all fields in Guile structs are now writable; attempting
+to make a read-only field will now issue a deprecation warning, and the
+field will be writable regardless.
@example
-(make-vtable "pw") ;; one writable field
-(make-vtable "prpw") ;; one read-only and one writable
-(make-vtable "pwuwuw") ;; one scheme and two unboxed
+(make-vtable "pw") ;; one scheme field
- (make-vtable "pwuwuw") ;; one scheme and two uninterpreted fields
++(make-vtable "pwuwuw") ;; one scheme and two unboxed fields
@end example
The optional @var{print} argument is a function called by
diff --cc libguile/struct.c
index eb2bfbb,b0604f7..57195bc
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@@ -587,22 -676,41 +587,27 @@@ scm_i_struct_equalp (SCM s1, SCM s2
for (field_num = 0; field_num < struct_size; field_num++)
{
- SCM s_field_num;
- SCM field1, field2;
-
- /* We have to use `scm_struct_ref ()' here so that fields are accessed
- consistently, notably wrt. field types and access rights. */
- s_field_num = scm_from_size_t (field_num);
- field1 = scm_struct_ref (s1, s_field_num);
- field2 = scm_struct_ref (s2, s_field_num);
-
- /* Self-referencing fields (type `s') must be skipped to avoid infinite
- recursion. */
- if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2))))
- if (scm_is_false (scm_equal_p (field1, field2)))
- return SCM_BOOL_F;
+ scm_t_bits field1, field2;
+
+ field1 = SCM_STRUCT_DATA_REF (s1, field_num);
+ field2 = SCM_STRUCT_DATA_REF (s2, field_num);
+
+ if (field1 != field2) {
- switch (scm_i_symbol_ref (layout, field_num * 2))
++ if (scm_i_symbol_ref (layout, field_num * 2) == 'u')
++ return SCM_BOOL_F;
++
++ /* Having a normal field point to the object itself is a bit
++ bonkers, but R6RS enums do it, so here we have a horrible
++ hack. */
++ if (field1 != SCM_UNPACK (s1) && field2 != SCM_UNPACK (s2))
+ {
- case 'p':
- /* Having a normal field point to the object itself is a bit
- bonkers, but R6RS enums do it, so here we have a horrible
- hack. */
- if (field1 != SCM_UNPACK (s1) && field2 != SCM_UNPACK (s2))
- {
- if (scm_is_false
- (scm_equal_p (SCM_PACK (field1), SCM_PACK (field2))))
- return SCM_BOOL_F;
- }
- break;
- case 's':
- /* Skip to avoid infinite recursion. */
- break;
- case 'u':
- return SCM_BOOL_F;
- default:
- /* Don't bother inspecting tail arrays; we never did this in
- the past and in the future tail arrays are going away
- anyway. */
- return SCM_BOOL_F;
++ if (scm_is_false
++ (scm_equal_p (SCM_PACK (field1), SCM_PACK (field2))))
++ return SCM_BOOL_F;
+ }
+ }
}
- /* FIXME: Tail elements should be tested for equality. */
-
return SCM_BOOL_T;
}
#undef FUNC_NAME
@@@ -624,34 -732,75 +629,22 @@@ SCM_DEFINE (scm_struct_ref, "struct-ref
"word.")
#define FUNC_NAME s_scm_struct_ref
{
- SCM vtable;
- scm_t_bits data;
- SCM vtable, answer = SCM_UNDEFINED;
- scm_t_bits *data;
- size_t p;
++ SCM vtable, layout;
+ size_t nfields, p;
SCM_VALIDATE_STRUCT (1, handle);
vtable = SCM_STRUCT_VTABLE (handle);
- data = SCM_STRUCT_DATA (handle);
++ layout = SCM_VTABLE_LAYOUT (vtable);
+ nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
p = scm_to_size_t (pos);
- if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
- && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)))
- /* The fast path: HANDLE is a struct with only "p" fields. */
- answer = SCM_PACK (data[p]);
- else
- {
- SCM layout;
- size_t layout_len, n_fields;
- scm_t_wchar field_type = 0;
-
- layout = SCM_STRUCT_LAYOUT (handle);
- layout_len = scm_i_symbol_length (layout);
- n_fields = layout_len / 2;
-
- if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
- n_fields += data[n_fields - 1];
+ SCM_ASSERT_RANGE (2, pos, p < nfields);
- data = SCM_STRUCT_DATA_REF (handle, p);
- SCM_ASSERT_RANGE (1, pos, p < n_fields);
++ /* Only 'p' fields. */
++ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME);
- if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)))
- /* The fast path: HANDLE is a struct with only readable "p"
- fields. */
- return SCM_PACK (data);
- else
- {
- SCM layout;
- scm_t_wchar field_type;
- if (p * 2 < layout_len)
- {
- scm_t_wchar ref;
- field_type = scm_i_symbol_ref (layout, p * 2);
- ref = scm_i_symbol_ref (layout, p * 2 + 1);
- if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
- {
- if ((ref == 'R') || (ref == 'W'))
- field_type = 'u';
- else
- SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
- }
- }
- else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O')
- field_type = scm_i_symbol_ref(layout, layout_len - 2);
- else
- SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
--
- layout = SCM_STRUCT_LAYOUT (handle);
- field_type = scm_i_symbol_ref (layout, p * 2);
- switch (field_type)
- {
- case 'u':
- scm_c_issue_deprecation_warning
- ("Accessing unboxed struct fields with struct-ref is deprecated.
"
- "Use struct-ref/unboxed instead.");
- answer = scm_from_ulong (data[p]);
- break;
--
- return (field_type == 'p') ? SCM_PACK (data) : scm_from_uintptr_t
(data);
- case 's':
- case 'p':
- answer = SCM_PACK (data[p]);
- break;
-
-
- default:
- SCM_MISC_ERROR ("unrecognized field type: ~S",
- scm_list_1 (SCM_MAKE_CHAR (field_type)));
- }
-- }
-
- return answer;
++ return SCM_STRUCT_SLOT_REF (handle, p);
}
#undef FUNC_NAME
@@@ -663,33 -812,144 +656,77 @@@ SCM_DEFINE (scm_struct_set_x, "struct-s
"to.")
#define FUNC_NAME s_scm_struct_set_x
{
-- SCM vtable;
- scm_t_bits *data;
- size_t p;
++ SCM vtable, layout;
+ size_t nfields, p;
SCM_VALIDATE_STRUCT (1, handle);
vtable = SCM_STRUCT_VTABLE (handle);
- data = SCM_STRUCT_DATA (handle);
++ layout = SCM_VTABLE_LAYOUT (vtable);
+ nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
p = scm_to_size_t (pos);
- if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
- && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE_RW)
- && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)))
- /* The fast path: HANDLE is a struct with only "pw" fields. */
- data[p] = SCM_UNPACK (val);
- else
- {
- SCM layout;
- size_t layout_len, n_fields;
- scm_t_wchar field_type = 0;
-
- layout = SCM_STRUCT_LAYOUT (handle);
- layout_len = scm_i_symbol_length (layout);
- n_fields = layout_len / 2;
-
- if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
- n_fields += data[n_fields - 1];
+ SCM_ASSERT_RANGE (2, pos, p < nfields);
- if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE_RW)))
- /* The fast path: HANDLE is a struct with only "p" fields. */
- SCM_STRUCT_SLOT_SET (handle, p, val);
- else
- {
- SCM layout;
- scm_t_wchar field_type;
- SCM_ASSERT_RANGE (1, pos, p < n_fields);
++ /* Only 'p' fields. */
++ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'p', layout, 0, FUNC_NAME);
- layout = SCM_STRUCT_LAYOUT (handle);
- field_type = scm_i_symbol_ref (layout, p * 2);
- if (p * 2 < layout_len)
- {
- char set_x;
- field_type = scm_i_symbol_ref (layout, p * 2);
- set_x = scm_i_symbol_ref (layout, p * 2 + 1);
- if (set_x != 'w' && set_x != 'h')
- SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
- }
- else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
- field_type = scm_i_symbol_ref (layout, layout_len - 2);
- else
- SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
-
- switch (field_type)
- {
- case 'u':
- scm_c_issue_deprecation_warning
- ("Accessing unboxed struct fields with struct-set! is deprecated.
"
- "Use struct-set!/unboxed instead.");
- data[p] = SCM_NUM2ULONG (3, val);
- break;
-
- case 'p':
- data[p] = SCM_UNPACK (val);
- break;
-
- case 's':
- SCM_MISC_ERROR ("self fields immutable", SCM_EOL);
-
- default:
- SCM_MISC_ERROR ("unrecognized field type: ~S",
- scm_list_1 (SCM_MAKE_CHAR (field_type)));
- }
- }
++ SCM_STRUCT_SLOT_SET (handle, p, val);
- if (field_type == 'p')
- SCM_STRUCT_SLOT_SET (handle, p, val);
- else
- SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val));
- }
+ return val;
+ }
+ #undef FUNC_NAME
+
+
+ SCM_DEFINE (scm_struct_ref_unboxed, "struct-ref/unboxed", 2, 0, 0,
+ (SCM handle, SCM pos),
+ "Access the @var{pos}th field of struct associated with\n"
+ "@var{handle}. The field must be of type 'u'.")
+ #define FUNC_NAME s_scm_struct_ref_unboxed
+ {
+ SCM vtable, layout;
- size_t layout_len, n_fields;
- size_t p;
++ size_t nfields, p;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ vtable = SCM_STRUCT_VTABLE (handle);
- p = scm_to_size_t (pos);
-
+ layout = SCM_VTABLE_LAYOUT (vtable);
- layout_len = scm_i_symbol_length (layout);
- n_fields = layout_len / 2;
-
- SCM_ASSERT_RANGE (1, pos, p < n_fields);
++ nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
++ p = scm_to_size_t (pos);
+
- /* Only 'u' fields, no tail arrays. */
- SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u',
- layout, 0, FUNC_NAME);
++ SCM_ASSERT_RANGE (2, pos, p < nfields);
+
- /* Don't support opaque fields. */
- SCM_ASSERT (scm_i_symbol_ref (layout, p * 2 + 1) != 'o',
- layout, 0, FUNC_NAME);
++ /* Only 'u' fields. */
++ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', layout, 0, FUNC_NAME);
+
+ return scm_from_uintptr_t (SCM_STRUCT_DATA_REF (handle, p));
+ }
+ #undef FUNC_NAME
+
+
+ SCM_DEFINE (scm_struct_set_x_unboxed, "struct-set!/unboxed", 3, 0, 0,
+ (SCM handle, SCM pos, SCM val),
+ "Set the slot of the structure @var{handle} with index @var{pos}\n"
+ "to @var{val}. Signal an error if the slot can not be written\n"
+ "to.")
+ #define FUNC_NAME s_scm_struct_set_x_unboxed
+ {
+ SCM vtable, layout;
- size_t layout_len, n_fields;
- size_t p;
++ size_t nfields, p;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ vtable = SCM_STRUCT_VTABLE (handle);
- p = scm_to_size_t (pos);
-
+ layout = SCM_VTABLE_LAYOUT (vtable);
- layout_len = scm_i_symbol_length (layout);
- n_fields = layout_len / 2;
-
- SCM_ASSERT_RANGE (1, pos, p < n_fields);
-
- /* Only 'u' fields, no tail arrays. */
- SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u',
- layout, 0, FUNC_NAME);
++ nfields = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
++ p = scm_to_size_t (pos);
+
- /* Don't support opaque fields. */
- SCM_ASSERT (scm_i_symbol_ref (layout, p * 2 + 1) != 'o',
- layout, 0, FUNC_NAME);
++ SCM_ASSERT_RANGE (2, pos, p < nfields);
+
- if (scm_i_symbol_ref (layout, p * 2 + 1) == 'r')
- SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
++ /* Only 'u' fields. */
++ SCM_ASSERT (scm_i_symbol_ref (layout, p * 2) == 'u', layout, 0, FUNC_NAME);
+
+ SCM_STRUCT_DATA_SET (handle, p, scm_to_uintptr_t (val));
return val;
}
diff --cc module/oop/goops.scm
index a8a02f5,3c787d7..f77b77a
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@@ -317,9 -313,10 +321,9 @@@
(let* ((layout (fold-class-slots macro-fold-right cons-layout ""))
(nfields (/ (string-length layout) 2))
(<class> (%make-vtable-vtable layout)))
- (class-add-flags! <class> (logior vtable-flag-goops-class
- vtable-flag-goops-valid))
+ (class-add-flags! <class> vtable-flag-goops-class)
(struct-set! <class> class-index-name '<class>)
- (struct-set! <class> class-index-nfields nfields)
+ (struct-set!/unboxed <class> class-index-nfields nfields)
(struct-set! <class> class-index-direct-supers '())
(struct-set! <class> class-index-direct-slots '())
(struct-set! <class> class-index-direct-subclasses '())
@@@ -426,9 -425,10 +431,9 @@@ followed by its associated value. If @
(nfields (/ (string-length layout) 2))
(<slot> (make-struct/no-tail <class> (make-struct-layout layout))))
(class-add-flags! <slot> (logior vtable-flag-goops-class
- vtable-flag-goops-slot
- vtable-flag-goops-valid))
+ vtable-flag-goops-slot))
(struct-set! <slot> class-index-name '<slot>)
- (struct-set! <slot> class-index-nfields nfields)
+ (struct-set!/unboxed <slot> class-index-nfields nfields)
(struct-set! <slot> class-index-direct-supers '())
(struct-set! <slot> class-index-direct-slots '())
(struct-set! <slot> class-index-direct-subclasses '())
@@@ -911,6 -937,13 +937,9 @@@ slots as we go.
(define (opaque-slot? slot) (is-a? slot <opaque-slot>))
(define (read-only-slot? slot) (is-a? slot <read-only-slot>))
+ (define (unboxed-slot? slot)
+ (and (is-a? slot <foreign-slot>)
- (not (is-a? slot <self-slot>))
+ (not (is-a? slot <protected-slot>))))
@@@ -2718,9 -2889,10 +2747,9 @@@ var{initargs}.
(compute-direct-slot-definition class initargs)))
(next-method)
- (class-add-flags! class (logior vtable-flag-goops-class
- vtable-flag-goops-valid))
+ (class-add-flags! class vtable-flag-goops-class)
(struct-set! class class-index-name (get-keyword #:name initargs '???))
- (struct-set! class class-index-nfields 0)
+ (struct-set!/unboxed class class-index-nfields 0)
(struct-set! class class-index-direct-supers
(get-keyword #:dsupers initargs '()))
(struct-set! class class-index-direct-subclasses '())
@@@ -2924,332 -3134,6 +2953,332 @@@
no-method
))
+
+
+;;;
+;;; Class redefinition
+;;;
+
+;;; GOOPS has a facility to allow a user to change the definition of
+;;; class. This will cause instances of that class to lazily migrate
+;;; over to the new definition. Implementing this is tricky because
+;;; identity is a fundamental part of object-oriented programming; you
+;;; can't just make a new class and start using it, just like that. In
+;;; GOOPS, classes are objects too and need to be addressable by
+;;; identity (by `eq?'). Classes need the ability to change their
+;;; definition "in place". The same goes for instances; redefining a
+;;; class might change the amount of storage associated with each
+;;; instance, and yet we need to update the instances in place, and
+;;; without having classes maintain a list of all of their instances.
+;;;
+;;; The way that we implement this is by adding an indirection. An
+;;; instance of a redefinable class becomes a small object containing
+;;; only a single field, a reference to an external "slots" objects that
+;;; holds the actual slots. There is an exception however for objects
+;;; that have statically allocated slots, most importantly classes -- in
+;;; that case the indirected slots are allocated "directly" in the
+;;; object.
+;;;
+;;; Instances update by checking the class of their their indirected
+;;; slots object. In addition to describing the slots of the indirected
+;;; slots object, that slots class (which is a direct class) has a
+;;; "redefined" slot. If the indirect slots object is current, this
+;;; value is #f. Otherwise it points to the old class definition
+;;; corresponding to its instances.
+;;;
+;;; To try to clarify things, here is a diagram of the "normal" state of
+;;; affairs. The redefinable class has an associated slots class. When
+;;; it makes instances, the instances have a pointer to the indirect
+;;; "slots" object. The class of the indirect slots object is the slots
+;;; class associated with the instance's class. The "V" arrows indicate
+;;; a vtable (class-of) relationship. Dashed arrows indicate a reference
+;;; from a struct slot to an object.
+;;;
+;;; Initial state.
+;;; +-------------+ +------------------------------+
+;;; | class ----> slots class, redefined: #f |
+;;; +-V-----------+ +-V----------------------------+
+;;; V V
+;;; +-V-----------+ +-V----------------------------+
+;;; | instance ----> slots ... |
+;;; +-------------+ +------------------------------+
+;;;
+;;; When a class is redefined, it is updated in place. However existing
+;;; instances are only migrated lazily. So after a class has been
+;;; redefined but before the instance has been updated, the state looks
+;;; like this:
+;;;
+;;; Redefined state.
+;;; ,-------------------------------------------.
+;;; | |
+;;; +-v-----------+ +----------------------------|-+
+;;; | old class ----> old slots class, redefined:' VVV
+;;; +-------------+ +------------------------------+ V
+;;; V
+;;; +-------------+ +------------------------------+ V
+;;; | new class ----> new slots class, redefined:#f| V
+;;; +-V-----------+ +------------------------------+ V
+;;; V V
+;;; +-V-----------+ +------------------------------+ V
+;;; | old inst ----> slots ... VVV
+;;; +-------------+ +------------------------------+
+;;;
+;;; That is to say, because the class was updated in place, the old
+;;; instance's vtable is the new class, even though the old instance's
+;;; slots still correspond to the old class. The vtable of the old slots
+;;; has the "redefined" field, which has been set to point to a fresh
+;;; object containing the direct slots of the old class, and a pointer to
+;;; the old slots class -- as if it were the old class, but with a new
+;;; temporary identity. This allows us to then call
+;;;
+;;; (change-object-class obj old-class new-class)
+;;;
+;;; which will allocate a fresh slots object for the old instance
+;;; corresponding to the new class, completing the migration for that
+;;; instance.
+;;;
+;;; Lazy instance migration is triggered by "class-of". Calling
+;;; "class-of" on an indirect instance will check the indirect slots to
+;;; see if they need redefinition. If so, we construct a fresh instance
+;;; of the new class and swap fields with the old instance (including
+;;; the indirect-slots field). Unfortunately there is some
+;;; thread-unsafety here, as retrieving the class is unsynchronized with
+;;; retrieving the indirect slots.
+;;;
+(define-class <indirect-slots-class> (<class>)
+ (%redefined #:init-value #f))
+(define-class <redefinable-class> (<class>)
+ (indirect-slots-class))
+
+(define-method (compute-slots (class <redefinable-class>))
+ (let* ((slots (next-method))
+ ;; The base method ensured that at most one superclass has
+ ;; statically allocated slots.
+ (static-slots
+ (match (filter class-has-statically-allocated-slots?
+ (cdr (class-precedence-list class)))
+ (() '())
+ ((class) (struct-ref class class-index-direct-slots)))))
+ (define (simplify-slot-definition s)
+ ;; Here we take a slot definition and strip it to just be a plain
+ ;; old name, suitable for use as a slot for the plain-old-data
+ ;; indirect-slots class.
+ (and (eq? (slot-definition-allocation s) #:instance)
+ (make (class-of s) #:name (slot-definition-name s))))
+ (define (maybe-make-indirect-slot-definition s)
+ ;; Here we copy over all the frippery of a slot definition
+ ;; (accessors, init-keywords, and so on), but we change the slot
+ ;; to have virtual allocation and we provide explicit
+ ;; slot-ref/slot-set! functions that access the slot value through
+ ;; the indirect slots object. For slot definitions without
+ ;; instance allocation though, we just pass them through.
+ (cond
+ ((eq? (slot-definition-allocation s) #:instance)
+ (let* ((s* (class-slot-definition (slot-ref class
'indirect-slots-class)
+ (slot-definition-name s)))
+ (ref (slot-definition-slot-ref/raw s*))
+ (set! (slot-definition-slot-set! s*)))
+ (make (class-of s) #:name (slot-definition-name s)
+ #:getter (slot-definition-getter s)
+ #:setter (slot-definition-setter s)
+ #:accessor (slot-definition-accessor s)
+ #:init-keyword (slot-definition-init-keyword s)
+ #:init-thunk (slot-definition-init-thunk s)
+ #:allocation #:virtual
+ ;; TODO: Make faster.
+ #:slot-ref (lambda (o)
+ (ref (slot-ref o 'indirect-slots)))
+ #:slot-set! (lambda (o v)
+ (set! (slot-ref o 'indirect-slots) v)))))
+ (else s)))
+ (unless (equal? (list-head slots (length static-slots))
+ static-slots)
+ (error "unexpected slots"))
+ (let* ((indirect-slots (list-tail slots (length static-slots)))
+ (indirect-slots-class
+ (make-class '()
+ (filter-map simplify-slot-definition
+ indirect-slots)
+ #:name 'indirect-slots
+ #:metaclass <indirect-slots-class>)))
+ (slot-set! class 'indirect-slots-class indirect-slots-class)
+ (append static-slots
+ (cons (make <slot> #:name 'indirect-slots)
+ (map maybe-make-indirect-slot-definition
+ indirect-slots))))))
+
+(define-method (initialize (class <redefinable-class>) initargs)
+ (next-method)
+ (class-add-flags! class vtable-flag-goops-indirect))
+
+(define-method (allocate-instance (class <redefinable-class>) initargs)
+ (let ((instance (next-method))
- (nfields (struct-ref class class-index-nfields))
++ (nfields (struct-ref/unboxed class class-index-nfields))
+ (indirect-slots-class (slot-ref class 'indirect-slots-class)))
+ ;; Indirect slots will be last struct field.
- (struct-set! instance (1- nfields) (make indirect-slots-class))
++ (struct-set!/unboxed instance (1- nfields) (make indirect-slots-class))
+ instance))
+
+;; Called when redefining an existing binding, and the new binding is a
+;; class. Two arguments: the old value, and the new.
+(define-generic class-redefinition)
+
+(define-method (class-redefinition (old <top>) (new <class>))
+ ;; Default class-redefinition method is to just replace old binding
+ ;; with the class.
+ new)
+
+(define-method (class-redefinition (old <redefinable-class>)
+ (new <redefinable-class>))
+ ;; When redefining a redefinable class with a redefinable class, we
+ ;; migrate the old definition and its instances to become the new
+ ;; definition.
+ ;;
+ ;; Work on direct methods:
+ ;; 1. Remove accessor methods from the old class
+ ;; 2. Patch the occurences of new in the specializers by old
+ ;; 3. Displace the methods from old to new
+ (remove-class-accessors! old) ;; -1-
+ (let ((methods (class-direct-methods new)))
+ (for-each (lambda (m)
+ (update-direct-method! m new old)) ;; -2-
+ methods)
+ (struct-set! new
+ class-index-direct-methods
+ (append methods (class-direct-methods old))))
+
+ ;; Substitute old for new in new cpl
+ (set-car! (struct-ref new class-index-cpl) old)
+
+ ;; Remove the old class from the direct-subclasses list of its super classes
+ (for-each (lambda (c) (struct-set! c class-index-direct-subclasses
+ (delv! old (class-direct-subclasses c))))
+ (class-direct-supers old))
+
+ ;; Replace the new class with the old in the direct-subclasses of the supers
+ (for-each (lambda (c)
+ (struct-set! c class-index-direct-subclasses
+ (cons old (delv! new (class-direct-subclasses
c)))))
+ (class-direct-supers new))
+
+ ;; Swap object headers
+ (%modify-instance old new)
+
+ ;; Now old is NEW!
+
+ ;; Redefine all the subclasses of old to take into account modification
+ (for-each
+ (lambda (c)
+ (update-direct-subclass! c new old))
+ (class-direct-subclasses new))
+
+ ;; Invalidate class so that subsequent instance slot accesses invoke
+ ;; change-object-class
+ (let ((slots-class (slot-ref new 'indirect-slots-class)))
+ (slot-set! slots-class '%redefined new)
+ (class-add-flags! slots-class vtable-flag-goops-needs-migration))
+
+ old)
+
+(define-method (remove-class-accessors! (c <class>))
+ (for-each (lambda (m)
+ (when (is-a? m <accessor-method>)
+ (let ((gf (slot-ref m 'generic-function)))
+ ;; remove the method from its GF
+ (slot-set! gf 'methods
+ (delq1! m (slot-ref gf 'methods)))
+ (invalidate-method-cache! gf)
+ ;; remove the method from its specializers
+ (remove-method-in-classes! m))))
+ (class-direct-methods c)))
+
+(define-method (update-direct-method! (m <method>)
+ (old <class>)
+ (new <class>))
+ (let loop ((l (method-specializers m)))
+ ;; Note: the <top> in dotted list is never used.
+ ;; So we can work as if we had only proper lists.
+ (when (pair? l)
+ (when (eqv? (car l) old)
+ (set-car! l new))
+ (loop (cdr l)))))
+
+(define-method (update-direct-subclass! (c <class>)
+ (old <class>)
+ (new <class>))
+ (class-redefinition c
+ (make-class (class-direct-supers c)
+ (class-direct-slots c)
+ #:name (class-name c)
+ #:metaclass (class-of c))))
+
+(define (change-object-class old-instance old-class new-class)
+ (let ((new-instance (allocate-instance new-class '())))
+ ;; Initialize the slots of the new instance
+ (for-each
+ (lambda (slot)
+ (unless (eq? slot 'indirect-slots)
+ (if (and (slot-exists? old-instance slot)
+ (memq (%slot-definition-allocation
+ (class-slot-definition old-class slot))
+ '(#:instance #:virtual))
+ (slot-bound? old-instance slot))
+ ;; Slot was present and allocated in old instance; copy it
+ (slot-set! new-instance slot (slot-ref old-instance slot))
+ ;; slot was absent; initialize it with its default value
+ (let ((init (slot-init-function new-class slot)))
+ (when init
+ (slot-set! new-instance slot (init)))))))
+ (map slot-definition-name (class-slots new-class)))
+ ;; Exchange old and new instance in place to keep pointers valid
+ (%modify-instance old-instance new-instance)
+ ;; Allow class specific updates of instances (which now are swapped)
+ (update-instance-for-different-class new-instance old-instance)
+ old-instance))
+
+
+(define-method (update-instance-for-different-class (old-instance <object>)
+ (new-instance
+ <object>))
+ ;;not really important what we do, we just need a default method
+ new-instance)
+
+(define-method (change-class (old-instance <object>)
+ (new-class <redefinable-class>))
+ (unless (is-a? (class-of old-instance) <redefinable-class>)
+ (error (string-append
+ "Default change-class implementation only works on"
+ " instances of redefinable classes")))
+ (change-object-class old-instance (class-of old-instance) new-class))
+
+(define class-of-obsolete-indirect-instance
+ (let ((lock (make-mutex))
+ (stack '()))
+ (lambda (instance)
+ (let* ((new-class (struct-vtable instance))
- (nfields (struct-ref new-class class-index-nfields))
++ (nfields (struct-ref/unboxed new-class class-index-nfields))
+ ;; Indirect slots are in last instance slot. For normal
+ ;; instances last slot is 0 of course.
+ (slots (struct-ref instance (1- nfields)))
+ (old-class (slot-ref (class-of slots) '%redefined)))
+ (let/ec return
+ (dynamic-wind
+ (lambda ()
+ (with-mutex lock
+ (if (memv slots stack)
+ (return (or old-class new-class))
+ (set! stack (cons slots stack)))))
+ (lambda ()
+ (when old-class
+ (change-class instance new-class))
+ new-class)
+ (lambda ()
+ (with-mutex lock
+ (set! stack (delq! slots stack))))))))))
+
+
+
+
;;;
;;; {Final initialization}
;;;