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.

1 files changed, 72 insertions, 56 deletions

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