summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/goops.c108
-rw-r--r--libguile/goops.h3
-rw-r--r--module/oop/goops.scm29
3 files changed, 54 insertions, 86 deletions
diff --git a/libguile/goops.c b/libguile/goops.c
index 1e7639ef1..5b24ee6bc 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -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",
diff --git a/libguile/goops.h b/libguile/goops.h
index 790c0b448..9dd1e1fdd 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -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
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index c78d0bd3c..48370c68b 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -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}
;;;