mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

Implement class redefinition on top of fixed structs

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-09-08 10:44:54 +02:00
parent 5c8bb13630
commit 4898959901
7 changed files with 472 additions and 287 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile/foreign-object.c
View file

@ -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));

128
libguile/goops.c
View file

@ -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

22
libguile/goops.h
View file

@ -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")

12
libguile/struct.h
View file

@ -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);

3
libguile/vm-engine.c
View file

@ -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));
}