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

GOOPS instance migration implemented in Scheme

Browse source 
* libguile/goops.c (scm_class_of): Call out directly to the GOOPS-local
  `migrate-instance' if an instance needs to migrate.
  (scm_sys_struct_data): New internal temporary function used by the
  Scheme `migrate-instance'.  Exorcise the evil one from the old C
  implementation.
* libguile/goops.h (scm_change_object_class): Remove function used only
  internally in GOOPS.
* module/oop/goops.scm (migrate-instance): Implement the
  hell/purgatory/etc logic in Scheme instead of C.
This commit is contained in:
Andy Wingo 2017-09-08 10:44:44 +02:00
parent cfe2279fea
commit 95f66b197c
3 changed files with 54 additions and 86 deletions
Download patch file Download diff file Expand all files Collapse all files

108
libguile/goops.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015,2017
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@ -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_change_class = SCM_BOOL_F;
static SCM var_migrate_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;
@ -287,15 +287,18 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
/* 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. */
/* A GOOPS object whose class might have been redefined;
try to migrate it over to the new class. */
{
SCM class = SCM_CLASS_OF (x);
SCM new_class = scm_slot_ref (class, sym_redefined);
if (!scm_is_false (new_class))
scm_change_object_class (x, class, new_class);
/* Re-load class from instance. */
return SCM_CLASS_OF (x);
}
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));
default:
@ -480,6 +483,17 @@ 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.")
@ -532,75 +546,6 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
}
#undef FUNC_NAME
/* When instances change class, they finally get a new body, but
* before that, they go through purgatory in hell. Odd as it may
* seem, this data structure saves us from eternal suffering in
* infinite recursions.
*/
static scm_t_bits **hell;
static long n_hell = 1; /* one place for the evil one himself */
static long hell_size = 4;
static SCM hell_mutex;
static long
burnin (SCM o)
{
long i;
for (i = 1; i < n_hell; ++i)
if (SCM_STRUCT_DATA (o) == hell[i])
return i;
return 0;
}
static void
go_to_hell (void *o)
{
SCM obj = *(SCM*)o;
scm_lock_mutex (hell_mutex);
if (n_hell >= hell_size)
{
hell_size *= 2;
hell = scm_realloc (hell, hell_size * sizeof(*hell));
}
hell[n_hell++] = SCM_STRUCT_DATA (obj);
scm_unlock_mutex (hell_mutex);
}
static void
go_to_heaven (void *o)
{
SCM obj = *(SCM*)o;
scm_lock_mutex (hell_mutex);
hell[burnin (obj)] = hell[--n_hell];
scm_unlock_mutex (hell_mutex);
}
static SCM
purgatory (SCM obj, SCM new_class)
{
return scm_call_2 (SCM_VARIABLE_REF (var_change_class), obj, new_class);
}
/* This function calls the generic function change-class for all
* instances which aren't currently undergoing class change.
*/
void
scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
{
if (!burnin (obj))
{
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_dynwind_rewind_handler (go_to_hell, &obj, SCM_F_WIND_EXPLICITLY);
scm_dynwind_unwind_handler (go_to_heaven, &obj, SCM_F_WIND_EXPLICITLY);
purgatory (obj, new_class);
scm_dynwind_end ();
}
}
/* Primitive generics: primitives that can dispatch to generics if their
@ -1052,7 +997,7 @@ 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_change_class = scm_c_lookup ("change-class");
var_migrate_instance = scm_c_lookup ("migrate-instance");
return SCM_UNSPECIFIED;
}
@ -1063,9 +1008,6 @@ scm_init_goops_builtins (void *unused)
{
scm_module_goops = scm_current_module ();
hell = scm_calloc (hell_size * sizeof (*hell));
hell_mutex = scm_make_mutex ();
#include "libguile/goops.x"
scm_c_define ("vtable-flag-vtable",