mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +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",

3
libguile/goops.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_GOOPS_H
#define SCM_GOOPS_H
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011, 2015 Free Software Foundation, Inc.
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2011, 2015, 2017 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -126,7 +126,6 @@ SCM_API SCM scm_enable_primitive_generic_x (SCM subrs);
SCM_INTERNAL SCM scm_set_primitive_generic_x (SCM subr, SCM generic);
SCM_API SCM scm_primitive_generic_generic (SCM subr);
SCM_API SCM scm_make (SCM args);
SCM_API void scm_change_object_class (SCM, SCM, SCM);
/* These procedures are for dispatching to a generic when a primitive
fails to apply. They raise a wrong-type-arg error if the primitive's

29
module/oop/goops.scm
View file

@ -1,6 +1,6 @@
;;;; goops.scm -- The Guile Object-Oriented Programming System
;;;;
;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc.
;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017 Free Software Foundation, Inc.
;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; This library is free software; you can redistribute it and/or
@ -27,6 +27,8 @@
(define-module (oop goops)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module ((ice-9 control) #:select (let/ec))
#:use-module (ice-9 threads)
#:use-module ((language tree-il primitives)
:select (add-interesting-primitive!))
#:export-syntax (define-class class standard-define-class
@ -2932,6 +2934,31 @@ var{initargs}."
(define-method (change-class (old-instance <object>) (new-class <class>))
(change-object-class old-instance (class-of old-instance) new-class))
(define migrate-instance
(let ((lock (make-mutex))
(stack '()))
(lambda (instance)
(let ((key (%struct-data instance)))
(let/ec return
(dynamic-wind
(lambda ()
(with-mutex lock
(if (memv key stack)
(return #f)
(set! stack (cons key stack)))))
(lambda ()
(let* ((old-class (struct-vtable instance))
(new-class (slot-ref old-class 'redefined)))
;; Although migrate-indirect-instance-if-needed should
;; only be called if the "valid" flag is not present on
;; the old-class, it's possible that multiple threads can
;; race, so we need to check again here.
(when new-class
(change-class instance new-class))))
(lambda ()
(with-mutex lock
(set! stack (delq! key stack))))))))))
;;;
;;; {make}
;;;