summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/foreign-object.c1
-rw-r--r--libguile/goops.c128
-rw-r--r--libguile/goops.h22
-rw-r--r--libguile/struct.h12
-rw-r--r--libguile/vm-engine.c3
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));
}