diff options
Diffstat (limited to 'libguile')
-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 |
5 files changed, 96 insertions, 70 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)); } |