diff options
-rw-r--r-- | libguile/goops.c | 108 | ||||
-rw-r--r-- | libguile/goops.h | 3 | ||||
-rw-r--r-- | module/oop/goops.scm | 29 |
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} ;;; |