diff options
author | Andy Wingo <wingo@pobox.com> | 2017-09-08 10:44:54 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-09-14 09:44:30 +0200 |
commit | 48989599016c218da68899aee2af8264df98e34c (patch) | |
tree | d5b934930b72eb54e1395414837d2ac8a2f1460e | |
parent | 5c8bb1363032eb5797fbd232dec162350304a768 (diff) | |
download | guile-48989599016c218da68899aee2af8264df98e34c.tar.gz |
Implement class redefinition on top of fixed structs
* libguile/struct.h: Steal another flag for GOOPS.
* libguile/goops.h (SCM_VTABLE_FLAG_GOOPS_INDIRECT)
(SCM_VTABLE_FLAG_GOOPS_NEEDS_MIGRATION): New flags.
(SCM_CLASSF_GOOPS_VALID, SCM_CLASSF_GOOPS_OR_VALID): Remove obsolete
definitions.
(SCM_IS_A_P): Use the scm_class_of function.
* libguile/goops.c (var_class_of_obsolete_indirect_instance): Rename
from var_migrate_instance.
(scm_is_generic, scm_is_method, scm_sys_init_layout_x): Use
scm_class_of instead of the SCM_CLASS_OF macro.
(get_indirect_slots): New helper.
(scm_class_of): This patch moves us in a direction where we won't be
able to separately address a struct's data and its identity.
Therefore to check whether a class needs migration, we check an
embedded pointer from a slot instead of the vtable data.
(scm_sys_struct_data): Remove this temporary function.
(scm_sys_modify_instance): Update to swap slot values instead of the
data pointers themselves.
(scm_sys_modify_class): Use scm_sys_modify_instance.
(scm_sys_goops_loaded): Capture class-of-obsolete-indirect-instance
instead of migrate-instance.
(scm_init_goops_builtins): Don't export the "valid" flag any more;
export instead the "indirect" and "needs-migration" flags.
* libguile/foreign-object.c (scm_assert_foreign_object_type): Add a
FIXME.
* libguile/vm-engine.c (class-of): Take away fast path for the time
being.
* module/oop/goops.scm (class-has-indirect-instances?)
(indirect-slots-need-migration?): New helpers.
(<class>, <slot>, %class-slot-definition, initialize): Remove use of
vtable-flag-goops-valid.
(define-class): Always push redefined values through
`class-redefinition'.
(<redefinable-class>): New public definition. Use it as a metaclass
for redefinable classes. Provide a compute-slots function that
declares the indirect slots mechanism. Add the "indirect" flag to
instances of <redefinable-class>. Create indirect-slots objects for
instances of those classes as part of their allocate-instance.
(change-object-class, class-of-obsolete-indirect-instance): Update for
new representation change.
* test-suite/tests/goops.test ("object update"): Add #:metaclass
<redefinable-class> to all redefinable classes. For the "hell" test,
make the new classes with class-direct-slots, not class-slots; this
was an error in the test.
-rw-r--r-- | libguile/foreign-object.c | 1 | ||||
-rw-r--r-- | libguile/goops.c | 128 | ||||
-rw-r--r-- | libguile/goops.h | 22 | ||||
-rw-r--r-- | libguile/struct.h | 12 | ||||
-rw-r--r-- | libguile/vm-engine.c | 3 | ||||
-rw-r--r-- | module/oop/goops.scm | 554 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 39 |
7 files changed, 472 insertions, 287 deletions
diff --git a/libguile/foreign-object.c b/libguile/foreign-object.c index 830f73f80..f074463a1 100644 --- a/libguile/foreign-object.c +++ b/libguile/foreign-object.c @@ -58,6 +58,7 @@ scm_make_foreign_object_type (SCM name, SCM slot_names, void scm_assert_foreign_object_type (SCM type, SCM val) { + /* FIXME: Add fast path for when type == struct vtable */ if (!SCM_IS_A_P (val, type)) scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S", scm_list_2 (scm_class_name (type), val), scm_list_1 (val)); diff --git a/libguile/goops.c b/libguile/goops.c index ed9dd1e60..12a3687a4 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -68,7 +68,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_args, "args"); static int goops_loaded_p = 0; static SCM var_make_standard_class = SCM_BOOL_F; -static SCM var_migrate_instance = SCM_BOOL_F; +static SCM var_class_of_obsolete_indirect_instance = SCM_BOOL_F; static SCM var_make = SCM_BOOL_F; static SCM var_inherit_applicable = SCM_BOOL_F; static SCM var_class_name = SCM_BOOL_F; @@ -174,8 +174,8 @@ SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0, SCM_VALIDATE_STRING (2, layout); SCM_SET_VTABLE_LAYOUT (class, scm_make_struct_layout (layout)); - scm_i_struct_inherit_vtable_magic (SCM_CLASS_OF (class), class); - SCM_SET_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_OR_VALID); + scm_i_struct_inherit_vtable_magic (scm_class_of (class), class); + SCM_SET_CLASS_FLAGS (class, SCM_VTABLE_FLAG_GOOPS_CLASS); return SCM_UNSPECIFIED; } @@ -184,6 +184,17 @@ SCM_DEFINE (scm_sys_init_layout_x, "%init-layout!", 2, 0, 0, +static SCM +get_indirect_slots (SCM x) +{ + /* Precondition: X is an indirect instance. The indirect slots are in + the last field. */ + scm_t_bits nfields = + SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (x), scm_vtable_index_size); + + return SCM_STRUCT_SLOT_REF (x, nfields - 1); +} + /* This function is used for efficient type dispatch. */ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, (SCM x), @@ -283,24 +294,34 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return ptob->output_class; } case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID) - /* A GOOPS object with a valid class. */ - return SCM_CLASS_OF (x); - else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS) - /* A GOOPS object whose class might have been redefined; - try to migrate it over to the new class. */ - { - scm_call_1 (scm_variable_ref (var_migrate_instance), x); - /* At this point, either the migration succeeded, in which - case SCM_CLASS_OF is the new class, or the migration - failed because it's already in progress on the current - thread, in which case we want to return the old class - for the time being. SCM_CLASS_OF (x) is the right - answer for both cases. */ - return SCM_CLASS_OF (x); - } - else - return scm_i_define_class_for_vtable (SCM_CLASS_OF (x)); + { + SCM vtable = SCM_STRUCT_VTABLE (x); + scm_t_bits flags = SCM_VTABLE_FLAGS (vtable); + scm_t_bits direct = SCM_VTABLE_FLAG_GOOPS_CLASS; + scm_t_bits indirect = direct | SCM_VTABLE_FLAG_GOOPS_INDIRECT; + scm_t_bits mask = indirect; + if ((flags & mask) == direct) + /* A direct GOOPS object. */ + return vtable; + else if ((flags & mask) == indirect) + /* An indirect GOOPS object. If the vtable of the slots + object is flagged to indicate that there's a new class + definition available, migrate the instance before + returning the class. */ + { + SCM slots = get_indirect_slots (x); + scm_t_bits slot_flags = SCM_OBJ_CLASS_FLAGS (slots); + if (slot_flags & SCM_VTABLE_FLAG_GOOPS_NEEDS_MIGRATION) + return scm_call_1 + (scm_variable_ref (var_class_of_obsolete_indirect_instance), + x); + else + return vtable; + } + else + /* A non-GOOPS struct. */ + return scm_i_define_class_for_vtable (vtable); + } default: if (scm_is_pair (x)) return class_pair; @@ -334,13 +355,13 @@ SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0, int scm_is_generic (SCM x) { - return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_generic); + return SCM_INSTANCEP (x) && SCM_SUBCLASSP (scm_class_of (x), class_generic); } int scm_is_method (SCM x) { - return SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), class_method); + return SCM_INSTANCEP (x) && SCM_SUBCLASSP (scm_class_of (x), class_method); } @@ -483,39 +504,40 @@ SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 2, 0, 0, static scm_i_pthread_mutex_t goops_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; -SCM_INTERNAL SCM scm_sys_struct_data (SCM); -SCM_DEFINE (scm_sys_struct_data, "%struct-data", 1, 0, 0, - (SCM s), - "Internal function used when migrating classes") -#define FUNC_NAME s_scm_sys_struct_data -{ - SCM_VALIDATE_INSTANCE (1, s); - return scm_from_uintptr_t (SCM_CELL_WORD_1 (s)); -} -#undef FUNC_NAME - SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, (SCM old, SCM new), "Used by change-class to modify objects in place.") #define FUNC_NAME s_scm_sys_modify_instance { + scm_t_bits i, old_nfields, new_nfields; + SCM_VALIDATE_INSTANCE (1, old); SCM_VALIDATE_INSTANCE (2, new); + old_nfields = SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (old), + scm_vtable_index_size); + new_nfields = SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (new), + scm_vtable_index_size); + SCM_ASSERT (old_nfields == new_nfields, new, SCM_ARG2, FUNC_NAME); + /* Exchange the data contained in old and new. We exchange rather than * scratch the old value with new to be correct with GC. * See "Class redefinition protocol above". */ scm_i_pthread_mutex_lock (&goops_lock); + /* Swap vtables. */ { - scm_t_bits word0, word1; - word0 = SCM_CELL_WORD_0 (old); - word1 = SCM_CELL_WORD_1 (old); + scm_t_bits tmp = SCM_CELL_WORD_0 (old); SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new)); - SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new)); - SCM_SET_CELL_WORD_0 (new, word0); - SCM_SET_CELL_WORD_1 (new, word1); + SCM_SET_CELL_WORD_0 (new, tmp); } + /* Swap data. */ + for (i = 0; i < old_nfields; i++) + { + scm_t_bits tmp = SCM_STRUCT_DATA_REF (old, i); + SCM_STRUCT_DATA_SET (old, i, SCM_STRUCT_DATA_REF (new, i)); + SCM_STRUCT_DATA_SET (new, i, tmp); + } scm_i_pthread_mutex_unlock (&goops_lock); return SCM_UNSPECIFIED; } @@ -529,19 +551,10 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0, SCM_VALIDATE_CLASS (1, old); SCM_VALIDATE_CLASS (2, new); - scm_i_pthread_mutex_lock (&goops_lock); - { - scm_t_bits word0, word1; - word0 = SCM_CELL_WORD_0 (old); - word1 = SCM_CELL_WORD_1 (old); - SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new)); - SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new)); - SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old); - SCM_SET_CELL_WORD_0 (new, word0); - SCM_SET_CELL_WORD_1 (new, word1); - SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new); - } - scm_i_pthread_mutex_unlock (&goops_lock); + scm_sys_modify_instance (old, new); + SCM_STRUCT_DATA (old)[scm_vtable_index_self] = SCM_UNPACK (old); + SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -997,7 +1010,8 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, var_method_specializers = scm_c_lookup ("method-specializers"); var_method_procedure = scm_c_lookup ("method-procedure"); - var_migrate_instance = scm_c_lookup ("migrate-instance"); + var_class_of_obsolete_indirect_instance = + scm_c_lookup ("class-of-obsolete-indirect-instance"); return SCM_UNSPECIFIED; } @@ -1020,12 +1034,14 @@ scm_init_goops_builtins (void *unused) scm_from_int (SCM_VTABLE_FLAG_VALIDATED)); scm_c_define ("vtable-flag-goops-class", scm_from_int (SCM_VTABLE_FLAG_GOOPS_CLASS)); - scm_c_define ("vtable-flag-goops-valid", - scm_from_int (SCM_VTABLE_FLAG_GOOPS_VALID)); scm_c_define ("vtable-flag-goops-slot", scm_from_int (SCM_VTABLE_FLAG_GOOPS_SLOT)); scm_c_define ("vtable-flag-goops-static-slot-allocation", scm_from_int (SCM_VTABLE_FLAG_GOOPS_STATIC_SLOT_ALLOCATION)); + scm_c_define ("vtable-flag-goops-indirect", + scm_from_int (SCM_VTABLE_FLAG_GOOPS_INDIRECT)); + scm_c_define ("vtable-flag-goops-needs-migration", + scm_from_int (SCM_VTABLE_FLAG_GOOPS_NEEDS_MIGRATION)); } void diff --git a/libguile/goops.h b/libguile/goops.h index 8565f4f16..202fef9eb 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -40,10 +40,22 @@ * certain class or its subclasses when traversal of the inheritance * graph would be too costly. */ +/* Set for all GOOPS classes. */ #define SCM_VTABLE_FLAG_GOOPS_CLASS SCM_VTABLE_FLAG_GOOPS_0 -#define SCM_VTABLE_FLAG_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_1 -#define SCM_VTABLE_FLAG_GOOPS_SLOT SCM_VTABLE_FLAG_GOOPS_2 -#define SCM_VTABLE_FLAG_GOOPS_STATIC_SLOT_ALLOCATION SCM_VTABLE_FLAG_GOOPS_3 +/* Set for GOOPS classes whose instances are <slot> objects. */ +#define SCM_VTABLE_FLAG_GOOPS_SLOT SCM_VTABLE_FLAG_GOOPS_1 +/* Set for GOOPS classes whose instance's slots must always be allocated + to the same indices, for all concrete subclasses. */ +#define SCM_VTABLE_FLAG_GOOPS_STATIC_SLOT_ALLOCATION SCM_VTABLE_FLAG_GOOPS_2 +/* Set for GOOPS classes whose instances are "indirect", meaning they + just have one slot that indirects to a direct instance with the + slots. For non-class instances, this is at struct slot 0. For class + instances, it's the first slot after the <class> fixed slots. */ +#define SCM_VTABLE_FLAG_GOOPS_INDIRECT SCM_VTABLE_FLAG_GOOPS_3 +/* For indirect classes, the slots object itself has a direct vtable. + This flag will be set on that vtable if the instance needs to migrate + to a new class. */ +#define SCM_VTABLE_FLAG_GOOPS_NEEDS_MIGRATION SCM_VTABLE_FLAG_GOOPS_4 #define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x) #define SCM_CLASS_FLAGS(class) (SCM_VTABLE_FLAGS (class)) @@ -52,9 +64,7 @@ #define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLEAR_VTABLE_FLAGS (c, f)) #define SCM_CLASSF_METACLASS (SCM_VTABLE_FLAG_GOOPS_CLASS|SCM_VTABLE_FLAG_VTABLE) -#define SCM_CLASSF_GOOPS_VALID SCM_VTABLE_FLAG_GOOPS_VALID #define SCM_CLASSF_GOOPS SCM_VTABLE_FLAG_GOOPS_CLASS -#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID) #define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x) @@ -72,7 +82,7 @@ #define SCM_SUBCLASSP(c1, c2) \ (scm_is_true (scm_c_memq (c2, scm_class_precedence_list (c1)))) #define SCM_IS_A_P(x, c) \ - (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), c)) + (SCM_INSTANCEP (x) && SCM_SUBCLASSP (scm_class_of (x), c)) #define SCM_GENERICP(x) (scm_is_generic (x)) #define SCM_VALIDATE_GENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, GENERICP, "generic function") diff --git a/libguile/struct.h b/libguile/struct.h index e8db316c8..e7007b7e0 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -112,12 +112,12 @@ #define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 7) /* instances of this vtable have only "pw" fields and no tail array */ #define SCM_VTABLE_FLAG_RESERVED_0 (1L << 8) #define SCM_VTABLE_FLAG_RESERVED_1 (1L << 9) -#define SCM_VTABLE_FLAG_RESERVED_2 (1L << 10) -#define SCM_VTABLE_FLAG_SMOB_0 (1L << 11) -#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 12) -#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 13) -#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 14) -#define SCM_VTABLE_FLAG_GOOPS_3 (1L << 15) +#define SCM_VTABLE_FLAG_SMOB_0 (1L << 10) +#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 11) +#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 12) +#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 13) +#define SCM_VTABLE_FLAG_GOOPS_3 (1L << 14) +#define SCM_VTABLE_FLAG_GOOPS_4 (1L << 15) #define SCM_VTABLE_USER_FLAG_SHIFT 16 typedef void (*scm_t_struct_finalize) (SCM obj); diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 6c88ebf11..bd9191909 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2905,8 +2905,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (113, class_of, "class-of", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (obj); - if (SCM_INSTANCEP (obj)) - RETURN (SCM_CLASS_OF (obj)); + /* FIXME: restore fast path for direct instances. */ RETURN_EXP (scm_class_of (obj)); } diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 3e725241f..f94332472 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -46,6 +46,9 @@ <protected-hidden-slot> <protected-read-only-slot> <scm-slot> <int-slot> <float-slot> <double-slot> + ;; Redefinable classes. + <redefinable-class> + ;; Methods are implementations of generic functions. <method> <accessor-method> @@ -250,9 +253,11 @@ ;;; a vtable are themselves vtables, and `vtable-flag-validated' ;;; indicates that the struct's layout has been validated. goops.c ;;; defines a few additional flags: one to indicate that a vtable is -;;; actually a class, one to indicate that the class is "valid" (meaning -;;; that it hasn't been redefined), and one to indicate that instances -;;; of a class are slot definition objects (<slot> instances). +;;; actually a class, one to indicate that instances of a class are slot +;;; definition objects (<slot> instances), one to indicate that this +;;; class has "static slot allocation" (meaning that its slots must +;;; always be allocated to the same indices in all subclasses), and two +;;; more flags used for redefinable classes (more below). ;;; (define vtable-flag-goops-metaclass (logior vtable-flag-vtable vtable-flag-goops-class)) @@ -282,6 +287,12 @@ (define (class-has-statically-allocated-slots? class) (class-has-flags? class vtable-flag-goops-static-slot-allocation)) +(define (class-has-indirect-instances? class) + (class-has-flags? class vtable-flag-goops-indirect)) + +(define (indirect-slots-need-migration? slots) + (class-has-flags? (struct-vtable slots) vtable-flag-goops-needs-migration)) + ;;; ;;; Now that we know the slots that must be present in classes, and ;;; their offsets, we can create the root of the class hierarchy. @@ -311,8 +322,7 @@ (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! <class> class-index-direct-supers '()) @@ -422,8 +432,7 @@ followed by its associated value. If @var{l} does not hold a value for (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! <slot> class-index-direct-supers '()) @@ -1094,8 +1103,7 @@ function." (#:body body ()) (#:make-procedure make-procedure #f)))) ((memq <class> (class-precedence-list class)) - (class-add-flags! z (logior vtable-flag-goops-class - vtable-flag-goops-valid)) + (class-add-flags! z vtable-flag-goops-class) (for-each (match-lambda ((kw slot default) (slot-set! z slot (get-keyword kw args default)))) @@ -1112,18 +1120,6 @@ function." ;;; ;;; Slot access. ;;; -;;; Before we go on, some notes about class redefinition. In GOOPS, -;;; classes can be redefined. Redefinition of a class marks the class -;;; as invalid, and instances will be lazily migrated over to the new -;;; representation as they are accessed. Migration happens when -;;; `class-of' is called on an instance. For more technical details on -;;; object redefinition, see struct.h. -;;; -;;; In the following interfaces, class-of handles the redefinition -;;; protocol. I would think though that there is some thread-unsafety -;;; here though as the { class, object data } pair needs to be accessed -;;; atomically, not the { class, object } pair. -;;; (define-inlinable (%class-slot-definition class slot-name kt kf) (let lp ((slots (struct-ref class class-index-slots))) (match slots @@ -1716,12 +1712,12 @@ function." (define-syntax-rule (define-class name supers slot ...) (begin (define-class-pre-definitions (slot ...)) - (if (and (defined? 'name) - (is-a? name <class>) - (memq <object> (class-precedence-list name))) - (class-redefinition name - (class supers slot ... #:name 'name)) - (toplevel-define! 'name (class supers slot ... #:name 'name))))) + (let ((cls (class supers slot ... #:name 'name))) + (toplevel-define! + 'name + (if (defined? 'name) + (class-redefinition name cls) + cls))))) (define-syntax-rule (standard-define-class arg ...) (define-class arg ...)) @@ -2118,14 +2114,14 @@ function." ;;; have a rest argument. ;;; -(define (map* fn . l) ; A map which accepts dotted lists (arg lists +(define (map* fn . l) ; A map which accepts dotted lists (arg lists (cond ; must be "isomorph" ((null? (car l)) '()) ((pair? (car l)) (cons (apply fn (map car l)) (apply map* fn (map cdr l)))) (else (apply fn l)))) -(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists +(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists (cond ; must be "isomorph" ((null? (car l)) '()) ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l))) @@ -2517,115 +2513,6 @@ function." clone)) ;;; -;;; {Class redefinition utilities} -;;; - -;;; (class-redefinition OLD NEW) -;;; - -;;; Has correct the following conditions: - -;;; Methods -;;; -;;; 1. New accessor specializers refer to new header -;;; -;;; Classes -;;; -;;; 1. New class cpl refers to the new class header -;;; 2. Old class header exists on old super classes direct-subclass lists -;;; 3. New class header exists on new super classes direct-subclass lists - -(define-method (class-redefinition (old <class>) (new <class>)) - ;; 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-class 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 instances slot accesses invoke - ;; change-object-class - (struct-set! new class-index-redefined old) - (class-clear-flags! new vtable-flag-goops-valid) ;must come after slot-set! - - old) - -;;; -;;; remove-class-accessors! -;;; - -(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))) - -;;; -;;; update-direct-method! -;;; - -(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))))) - -;;; -;;; update-direct-subclass! -;;; - -(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)))) - -;;; ;;; {Utilities for INITIALIZE methods} ;;; @@ -2807,8 +2694,7 @@ 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! class class-index-direct-supers @@ -2898,68 +2784,6 @@ var{initargs}." ;;; -;;; {Change-class} -;;; - -(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) - (if (and (slot-exists? old-instance slot) - (eq? (%slot-definition-allocation - (class-slot-definition old-class slot)) - #:instance) - (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 <class>)) - (change-object-class old-instance (class-of old-instance) new-class)) - -(define migrate-instance - (let ((lock (make-mutex)) - (stack '())) - (lambda (instance) - (let ((key (%struct-data instance))) - (let/ec return - (dynamic-wind - (lambda () - (with-mutex lock - (if (memv key stack) - (return #f) - (set! stack (cons key stack))))) - (lambda () - (let* ((old-class (struct-vtable instance)) - (new-class (slot-ref old-class 'redefined))) - ;; Although migrate-indirect-instance-if-needed should - ;; only be called if the "valid" flag is not present on - ;; the old-class, it's possible that multiple threads can - ;; race, so we need to check again here. - (when new-class - (change-class instance new-class)))) - (lambda () - (with-mutex lock - (set! stack (delq! key stack)))))))))) - -;;; ;;; {make} ;;; ;;; A new definition which overwrites the previous one which was built-in @@ -3077,6 +2901,332 @@ var{initargs}." 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)) + (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)) + 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-class 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)) + ;; 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} ;;; diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 6c6660478..390cd8c74 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -337,25 +337,31 @@ (with-test-prefix "object update" (pass-if "defining class" (eval '(define-class <foo> () - (x #:accessor x #:init-value 123) - (z #:accessor z #:init-value 789)) - (current-module)) + (x #:accessor x #:init-value 123) + (z #:accessor z #:init-value 789) + #:metaclass <redefinable-class>) + (current-module)) (eval '(is-a? <foo> <class>) (current-module))) (pass-if "making instance" (eval '(define foo (make <foo>)) (current-module)) (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module))) (pass-if "redefining class" (eval '(define-class <foo> () - (x #:accessor x #:init-value 123) - (y #:accessor y #:init-value 456) - (z #:accessor z #:init-value 789)) - (current-module)) + (x #:accessor x #:init-value 123) + (y #:accessor y #:init-value 456) + (z #:accessor z #:init-value 789) + #:metaclass <redefinable-class>) + (current-module)) (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))) (pass-if "changing class" - (let* ((c1 (class () (the-slot #:init-keyword #:value))) - (c2 (class () (the-slot #:init-keyword #:value) - (the-other-slot #:init-value 888))) + (let* ((c1 (class () + (the-slot #:init-keyword #:value) + #:metaclass <redefinable-class>)) + (c2 (class () + (the-slot #:init-keyword #:value) + (the-other-slot #:init-value 888) + #:metaclass <redefinable-class>)) (o1 (make c1 #:value 777))) (and (is-a? o1 c1) (not (is-a? o1 c2)) @@ -373,7 +379,8 @@ ;; array, leading to out-of-bounds accesses. (let* ((parent-class (class () - #:name '<class-that-will-be-redefined>)) + #:name '<class-that-will-be-redefined> + #:metaclass <redefinable-class>)) (classes (unfold (lambda (i) (>= i 20)) (lambda (i) @@ -383,7 +390,8 @@ #:name (string->symbol (string-append "<foo-to-redefine-" (number->string i) - ">")))) + ">")) + #:metaclass <redefinable-class>)) (lambda (i) (+ 1 i)) 0)) @@ -393,7 +401,7 @@ classes))) (define-method (change-class (foo parent-class) - (new <class>)) + (new <redefinable-class>)) ;; Called by `scm_change_object_class ()', via `purgatory ()'. (if (null? classes) (next-method) @@ -407,8 +415,9 @@ ;; nested `scm_change_object_class ()' calls, which increases ;; the size of HELL and increments N_HELL. (class-redefinition class - (make-class '() (class-slots class) - #:name (class-name class))) + (make-class '() (class-direct-slots class) + #:name (class-name class) + #:metaclass <redefinable-class>)) ;; Use `slot-ref' to trigger the `scm_change_object_class ()' ;; and `go_to_hell ()' calls. |