Clone class registry in new Perl threads Define a CLONE method in Clownfish::Class which gets invoked when a new Perl thread is created.
Project: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/repo Commit: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/commit/b46a4465 Tree: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/tree/b46a4465 Diff: http://git-wip-us.apache.org/repos/asf/lucy-clownfish/diff/b46a4465 Branch: refs/heads/clone_class_registry Commit: b46a4465c8bf630eef7d2bfa4fdb5d3407d0b234 Parents: bfde91c Author: Nick Wellnhofer <[email protected]> Authored: Sun Aug 3 17:31:51 2014 +0200 Committer: Nick Wellnhofer <[email protected]> Committed: Sun Aug 3 17:46:02 2014 +0200 ---------------------------------------------------------------------- runtime/core/Clownfish/Class.c | 26 ++++++++ runtime/core/Clownfish/Class.cfh | 3 + .../perl/buildlib/Clownfish/Build/Binding.pm | 24 +++++++ runtime/perl/lib/Clownfish.pm | 2 + runtime/perl/t/binding/600-threads.t | 70 ++++++++++++++++++++ 5 files changed, 125 insertions(+) ---------------------------------------------------------------------- http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/b46a4465/runtime/core/Clownfish/Class.c ---------------------------------------------------------------------- diff --git a/runtime/core/Clownfish/Class.c b/runtime/core/Clownfish/Class.c index a60aca9..8070fc1 100644 --- a/runtime/core/Clownfish/Class.c +++ b/runtime/core/Clownfish/Class.c @@ -355,6 +355,32 @@ Class_fetch_class(String *class_name) { return (Class*)LFReg_Fetch(registry, (Obj*)class_name); } +LockFreeRegistry* +Class_clone_registry(LockFreeRegistry *registry) { + LockFreeRegistry *twin = LFReg_Clone(registry); + LFRegIterator *iter = LFRegIter_new(twin); + Obj *value = NULL; + + // Fix up parent pointers. + while (LFRegIter_Next(iter, NULL, &value)) { + Class *klass = (Class*)value; + Class *orig_parent = klass->parent; + + if (orig_parent) { + String *parent_name = Class_Get_Name(orig_parent); + Class *twin_parent = (Class*)LFReg_Fetch(twin, (Obj*)parent_name); + if (!twin_parent) { + THROW(ERR, "Class '%o' not found in cloned registry", + parent_name); + } + klass->parent = twin_parent; + } + } + DECREF(iter); + + return twin; +} + void Class_Add_Host_Method_Alias_IMP(Class *self, const char *alias, const char *meth_name) { http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/b46a4465/runtime/core/Clownfish/Class.cfh ---------------------------------------------------------------------- diff --git a/runtime/core/Clownfish/Class.cfh b/runtime/core/Clownfish/Class.cfh index 69dc5a4..4229ff2 100644 --- a/runtime/core/Clownfish/Class.cfh +++ b/runtime/core/Clownfish/Class.cfh @@ -79,6 +79,9 @@ class Clownfish::Class inherits Clownfish::Obj { inert nullable Class* fetch_class(String *class_name); + inert LockFreeRegistry* + clone_registry(LockFreeRegistry *registry); + /** Given a class name, return the name of a parent class which descends * from Clownfish::Obj, or NULL if such a class can't be found. */ http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/b46a4465/runtime/perl/buildlib/Clownfish/Build/Binding.pm ---------------------------------------------------------------------- diff --git a/runtime/perl/buildlib/Clownfish/Build/Binding.pm b/runtime/perl/buildlib/Clownfish/Build/Binding.pm index 1b1d3c5..9b1d12e 100644 --- a/runtime/perl/buildlib/Clownfish/Build/Binding.pm +++ b/runtime/perl/buildlib/Clownfish/Build/Binding.pm @@ -616,6 +616,30 @@ CODE: RETVAL = (SV*)CFISH_Class_To_Host(singleton); } OUTPUT: RETVAL + +void +CLONE(class_sv, ...) + SV *class_sv; +PPCODE: +{ + const char *class_name = SvPV_nolen(class_sv); + + if (strcmp(class_name, "Clownfish::Class") == 0) { + SV *registry_sv = get_sv("Clownfish::Class::_registry", 0); + + if (registry_sv) { + cfish_LockFreeRegistry *registry; + SV *new_sv; + + registry = (cfish_LockFreeRegistry*)XSBind_sv_to_cfish_obj( + registry_sv, CFISH_LOCKFREEREGISTRY, NULL); + registry = cfish_Class_clone_registry(registry); + new_sv = CFISH_Obj_To_Host((cfish_Obj*)registry); + sv_setsv(registry_sv, new_sv); + SvREFCNT_dec(new_sv); + } + } +} END_XS_CODE my $binding = Clownfish::CFC::Binding::Perl::Class->new( http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/b46a4465/runtime/perl/lib/Clownfish.pm ---------------------------------------------------------------------- diff --git a/runtime/perl/lib/Clownfish.pm b/runtime/perl/lib/Clownfish.pm index 5f1bdd1..4109004 100644 --- a/runtime/perl/lib/Clownfish.pm +++ b/runtime/perl/lib/Clownfish.pm @@ -77,6 +77,8 @@ sub error {$Clownfish::Err::error} our $VERSION = '0.003000'; $VERSION = eval $VERSION; no warnings 'redefine'; + # Clone LFReg manually. + sub CLONE_SKIP { 0; } sub DESTROY { } # leak all } http://git-wip-us.apache.org/repos/asf/lucy-clownfish/blob/b46a4465/runtime/perl/t/binding/600-threads.t ---------------------------------------------------------------------- diff --git a/runtime/perl/t/binding/600-threads.t b/runtime/perl/t/binding/600-threads.t new file mode 100644 index 0000000..42e11d7 --- /dev/null +++ b/runtime/perl/t/binding/600-threads.t @@ -0,0 +1,70 @@ +# Licensed to the Apache Software Foundation (ASF) under one or more +# contributor license agreements. See the NOTICE file distributed with +# this work for additional information regarding copyright ownership. +# The ASF licenses this file to You under the Apache License, Version 2.0 +# (the "License"); you may not use this file except in compliance with +# the License. You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +use strict; +use warnings; + +use threads; + +use Clownfish; +use Test::More tests => 7; + +sub cf_addr { + my $obj = shift; + return 0 + $$obj; +} + +my $obj = Clownfish::String->new('A string.'); +my $registry_addr = cf_addr(Clownfish::Class->_get_registry); +my $class = Clownfish::Class->fetch_class('Clownfish::Hash'); +my $class_addr = cf_addr($class); +my $parent = $class->get_parent; +my $parent_addr = cf_addr($parent); + +my ($thread) = threads->create(sub { + my $thr_registry = Clownfish::Class->_get_registry; + my $thr_class = Clownfish::Class->fetch_class('Clownfish::Hash'); + my $thr_parent = $thr_class->get_parent; + my $thr_other_parent + = Clownfish::Class->fetch_class($thr_parent->get_name); + return ( + defined($$obj), + cf_addr($thr_registry), + cf_addr($thr_class), + cf_addr($thr_parent), + cf_addr($thr_other_parent), + ); +}); +my ( + $thr_obj_defined, + $thr_registry_addr, + $thr_class_addr, + $thr_parent_addr, + $thr_other_parent_addr, +) = $thread->join; + +ok( !$thr_obj_defined, "Object is undefined in other thread" ); + +my $other_registry_addr = cf_addr(Clownfish::Class->_get_registry); +my $other_class = Clownfish::Class->fetch_class('Clownfish::Hash'); +my $other_class_addr = cf_addr($class); + +is( $other_registry_addr, $registry_addr, "Same registry in same thread" ); +is( $other_class_addr, $class_addr, "Same class in same thread" ); +isnt( $thr_registry_addr, $registry_addr, "Cloned registry in other thread" ); +isnt( $thr_class_addr, $class_addr, "Cloned class in other thread" ); +isnt( $thr_parent_addr, $parent_addr, "Cloned parent class in other thread" ); +is( $thr_parent_addr, $thr_other_parent_addr, "Parent classes fixed up" ); +
