From: Artur Bergman Date: Sun, 21 Oct 2001 15:25:16 +0000 (+0000) Subject: First support of threads::shared, support shared svs and references. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b050c948e7b63d3513ca9c148115d3ea439bf57f;p=p5sagit%2Fp5-mst-13.2.git First support of threads::shared, support shared svs and references. p4raw-id: //depot/perl@12545 --- diff --git a/MANIFEST b/MANIFEST index f38b378..486a2b3 100644 --- a/MANIFEST +++ b/MANIFEST @@ -580,6 +580,12 @@ ext/threads/t/stress_string.t Test with multiple threads, string cv argument. ext/threads/threads.h ithreads ext/threads/threads.pm ithreads ext/threads/threads.xs ithreads +ext/threads/shared/Makefile.PL thread shared variables +ext/threads/shared/README thread shared variables +ext/threads/shared/shared.pm thread shared variables +ext/threads/shared/shared.xs thread shared variables +ext/threads/shared/t/sv_simple.t thread shared variables +ext/threads/shared/t/sv_refs.t thread shared variables ext/Time/HiRes/Changes Time::HiRes extension ext/Time/HiRes/hints/dynixptx.pl Hint for Time::HiRes for named architecture ext/Time/HiRes/hints/sco.pl Hints for Time::HiRes for named architecture diff --git a/ext/threads/shared/Makefile.PL b/ext/threads/shared/Makefile.PL new file mode 100755 index 0000000..8587906 --- /dev/null +++ b/ext/threads/shared/Makefile.PL @@ -0,0 +1,26 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. + +use Config; + + +unless($Config{'useithreads'} eq 'define') { + die "We need a perl that is built with USEITHREAD!\n"; +} + +WriteMakefile( + 'NAME' => 'threads::shared', + 'VERSION_FROM' => 'shared.pm', # finds $VERSION + 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 + ($] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => 'shared.pm', # retrieve abstract from module + AUTHOR => 'Arthur Bergman ') : ()), + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + # Insert -I. if you add *.h files later: + 'INC' => '', # e.g., '-I/usr/include/other' + # Un-comment this if you add C files to link with later: + # 'OBJECT' => '$(O_FILES)', # link all the C files too + +); diff --git a/ext/threads/shared/README b/ext/threads/shared/README new file mode 100644 index 0000000..0690835 --- /dev/null +++ b/ext/threads/shared/README @@ -0,0 +1,26 @@ +threads/shared version 0.02 +=========================== + +This module needs perl 5.7.2 or later compiled with USEITHREADS, +It lets you share simple data structures between threads. + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + +threads 0.03; + +COPYRIGHT AND LICENCE + +Copyright (C) 2001 Arthur Bergman artur at contiller.se +Same licence as perl. + diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm new file mode 100644 index 0000000..2aae9f1 --- /dev/null +++ b/ext/threads/shared/shared.pm @@ -0,0 +1,125 @@ + +package threads::shared; + +use strict; +use warnings; +use Config; +use Scalar::Util qw(weaken); +use attributes qw(reftype); + +BEGIN { + if($Config{'useithreads'} && $Config::threads) { + *share = \&share_enabled; + *cond_wait = \&cond_wait_disabled; + *cond_signal = \&cond_signal_disabled; + *cond_broadcast = \&cond_broadcast_disabled; + *unlock = \&unlock_disabled; + *lock = \&lock_disabled; + } else { + *share = \&share_enabled; + } +} + +require Exporter; +require DynaLoader; +our @ISA = qw(Exporter DynaLoader); + +our @EXPORT = qw(share cond_wait cond_broadcast cond_signal unlock lock); +our $VERSION = '0.01'; + +our %shared; + + +sub cond_wait_disabled { return @_ }; +sub cond_signal_disabled { return @_}; +sub cond_broadcast_disabled { return @_}; +sub unlock_disabled { 1 }; +sub lock_disabled { 1 } +sub share_disabled { return @_} + +sub share_enabled (\[$@%]) { # \] + my $value = $_[0]; + my $ref = reftype($value); + if($ref eq 'SCALAR') { + my $obj = \threads::shared::sv->new($$value); + bless $obj, 'threads::shared::sv'; + $shared{$$obj} = $value; + weaken($shared{$$obj}); + } else { + die "You cannot share ref of type $_[0]\n"; + } +} + +sub CLONE { + return unless($_[0] eq "threads::shared"); + foreach my $ptr (keys %shared) { + if($ptr) { + thrcnt_inc($shared{$ptr}); + } + } +} + + +package threads::shared::sv; +use base 'threads::shared'; + +package threads::shared::av; +use base 'threads::shared'; + +package threads::shared::hv; +use base 'threads::shared'; + + +bootstrap threads::shared $VERSION; + +__END__ + +=head1 NAME + +threads::shared - Perl extension for sharing data structures between threads + +=head1 SYNOPSIS + + use threads::shared; + + my($foo, @foo, %foo); + share(\$foo); + share(\@foo); + share(\%hash); + my $bar = share([]); + $hash{bar} = share({}); + + lock(\%hash); + unlock(\%hash); + cond_wait($scalar); + cond_broadcast(\@array); + cond_signal($scalar); + +=head1 DESCRIPTION + + This modules allows you to share() variables. These variables will then be shared across different threads (and pseudoforks on win32). They are used together with the threads module. + +=head2 EXPORT + +share(), lock(), unlock(), cond_wait, cond_signal, cond_broadcast + +=head1 BUGS + +Not stress tested! +Does not support references +Does not support splice on arrays! +The exported functions need a reference due to unsufficent prototyping! + +=head1 AUTHOR + +Artur Bergman artur at contiller.se + +threads is released under the same license as Perl + +=head1 SEE ALSO + +L L + +=cut + + diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs new file mode 100644 index 0000000..90049e2 --- /dev/null +++ b/ext/threads/shared/shared.xs @@ -0,0 +1,144 @@ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + + +void shared_sv_attach_sv (SV* sv, shared_sv* shared) { + HV* shared_hv = get_hv("threads::shared::shared", FALSE); + SV* id = newSViv((IV)shared); + STRLEN length = sv_len(id); + SV* tiedobject; + SV** tiedobject_ = hv_fetch(shared_hv, SvPV(id,length), length, 0); + if(tiedobject_) { + tiedobject = (*tiedobject_); + SvROK_on(sv); + SvRV(sv) = SvRV(tiedobject); + + } else { + croak("die\n"); + } +} + + +int shared_sv_fetch_mg (pTHX_ SV* sv, MAGIC *mg) { + shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj); + SHAREDSvLOCK(shared); + if(SvROK(SHAREDSvGET(shared))) { + shared_sv* target = (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared))); + shared_sv_attach_sv(sv, target); + } else { + sv_setsv(sv, SHAREDSvGET(shared)); + } + SHAREDSvUNLOCK(shared); + + return 0; +} + +int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) { + shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj); + SHAREDSvLOCK(shared); + if(SvROK(SHAREDSvGET(shared))) + Perl_sharedsv_thrcnt_dec(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared)))); + SHAREDSvEDIT(shared); + if(SvROK(sv)) { + shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv)); + if(!target) { + SHAREDSvRELEASE(shared); + sv_setsv(sv,SHAREDSvGET(shared)); + SHAREDSvUNLOCK(shared); + Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar"); + } + Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared)); + SHAREDSvGET(shared) = newRV_noinc(newSViv((IV)target)); + SvROK_off(sv); + } else { + sv_setsv(SHAREDSvGET(shared), sv); + } + SHAREDSvRELEASE(shared); + if(SvROK(SHAREDSvGET(shared))) + Perl_sharedsv_thrcnt_inc(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared)))); + SHAREDSvUNLOCK(shared); + return 0; +} + +int shared_sv_destroy_mg (pTHX_ SV* sv, MAGIC *mg) { + shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj); + if(!shared) + return 0; + Perl_sharedsv_thrcnt_dec(aTHX_ shared); +} + +MGVTBL svtable = {MEMBER_TO_FPTR(shared_sv_fetch_mg), + MEMBER_TO_FPTR(shared_sv_store_mg), + 0, + 0, + MEMBER_TO_FPTR(shared_sv_destroy_mg) +}; + +MODULE = threads::shared PACKAGE = threads::shared + + +PROTOTYPES: DISABLE + + +SV* +ptr(ref) + SV* ref + CODE: + RETVAL = newSViv(SvIV(SvRV(ref))); + OUTPUT: + RETVAL + + +SV* +_thrcnt(ref) + SV* ref + CODE: + shared_sv* shared = Perl_sharedsv_find(aTHX, ref); + if(!shared) + croak("thrcnt can only be used on shared values"); + SHAREDSvLOCK(shared); + RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared))); + SHAREDSvUNLOCK(shared); + OUTPUT: + RETVAL + + +void +thrcnt_inc(ref) + SV* ref + CODE: + shared_sv* shared; + if(SvROK(ref)) + ref = SvRV(ref); + shared = Perl_sharedsv_find(aTHX, ref); + if(!shared) + croak("thrcnt can only be used on shared values"); + Perl_sharedsv_thrcnt_inc(aTHX_ shared); + + +MODULE = threads::shared PACKAGE = threads::shared::sv + +SV* +new(class, value) + SV* class + SV* value + CODE: + shared_sv* shared = Perl_sharedsv_new(aTHX); + MAGIC* shared_magic; + SV* obj = newSViv((IV)shared); + SHAREDSvEDIT(shared); + SHAREDSvGET(shared) = newSVsv(value); + SHAREDSvRELEASE(shared); + sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16); + shared_magic = mg_find(value, PERL_MAGIC_ext); + shared_magic->mg_virtual = &svtable; + shared_magic->mg_obj = newSViv((IV)shared); + shared_magic->mg_flags |= MGf_REFCOUNTED; + SvMAGICAL_on(value); + RETVAL = obj; + OUTPUT: + RETVAL + + diff --git a/ext/threads/shared/t/sv_refs.t b/ext/threads/shared/t/sv_refs.t new file mode 100644 index 0000000..36977e7 --- /dev/null +++ b/ext/threads/shared/t/sv_refs.t @@ -0,0 +1,56 @@ +BEGIN { +# chdir 't' if -d 't'; +# push @INC ,'../lib'; + require Config; import Config; + unless ($Config{'useithreads'}) { + print "1..0 # Skip: no useithreads\n"; + exit 0; + } +} + + +sub ok { + my ($id, $ok, $name) = @_; + + # You have to do it this way or VMS will get confused. + print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; + + printf "# Failed test at line %d\n", (caller)[2] unless $ok; + + return $ok; +} + +use Devel::Peek; +use ExtUtils::testlib; +use strict; +BEGIN { print "1..9\n" }; +use threads; +use threads::shared; +ok(1,1,"loaded"); + +my $foo; +my $bar = "foo"; +share($foo); +eval { +$foo = \$bar; +}; +ok(2,my $temp1 = $@ =~/You cannot assign a non shared reference to a shared scalar/, "Check that the warning message is correct"); +share($bar); +$foo = \$bar; +ok(3, $temp1 = $foo =~/SCALAR/, "Check that is a ref"); +ok(4, $$foo eq "foo", "Check that it points to the correct value"); +$bar = "yeah"; +ok(5, $$foo eq "yeah", "Check that assignment works"); +$$foo = "yeah2"; +ok(6, $$foo eq "yeah2", "Check that deref assignment works"); +threads->create(sub {$bar = "yeah3"})->join(); +ok(7, $$foo eq "yeah3", "Check that other thread assignemtn works"); +threads->create(sub {$foo = "artur"})->join(); +ok(8, $foo eq "artur", "Check that uncopupling the ref works"); +my $baz; +share($baz); +$baz = "original"; +$bar = \$baz; +$foo = \$bar; +ok(9,$$$foo eq 'original', "Check reference chain"); + diff --git a/ext/threads/shared/t/sv_simple.t b/ext/threads/shared/t/sv_simple.t new file mode 100644 index 0000000..2a0d297 --- /dev/null +++ b/ext/threads/shared/t/sv_simple.t @@ -0,0 +1,59 @@ + + + + +BEGIN { +# chdir 't' if -d 't'; +# push @INC ,'../lib'; + require Config; import Config; + unless ($Config{'useithreads'}) { + print "1..0 # Skip: no useithreads\n"; + exit 0; + } +} + + +sub ok { + my ($id, $ok, $name) = @_; + + # You have to do it this way or VMS will get confused. + print $ok ? "ok $id - $name\n" : "not ok $id - $name\n"; + + printf "# Failed test at line %d\n", (caller)[2] unless $ok; + + return $ok; +} + + +use ExtUtils::testlib; +use strict; +BEGIN { print "1..10\n" }; +use threads; +use threads::shared; +ok(1,1,"loaded"); +my $test = "bar"; +share($test); +ok(2,$test eq "bar","Test magic share fetch"); +$test = "foo"; +ok(3,$test eq "foo","Test magic share assign"); +threads->create( + sub { + ok(4, $test eq "foo","Test mage share fetch after thread"); + $test = "baz"; + ok(5,threads::shared::_thrcnt($test) == 2, "Check that threadcount is correct"); + })->join(); +ok(6,$test eq "baz","Test that value has changed in another thread"); +ok(7,threads::shared::_thrcnt($test) == 1,"Check thrcnt is down properly"); +$test = "barbar"; +ok(8, length($test) == 6, "Check length code"); +threads->create(sub { $test = "barbarbar" })->join; +ok(9, length($test) == 9, "Check length code after different thread modified it"); +threads->create(sub { undef($test)})->join(); +ok(10, !defined($test), "Check undef value"); + + + + + + + diff --git a/sharedsv.c b/sharedsv.c index 2d347b8..0deabb2 100644 --- a/sharedsv.c +++ b/sharedsv.c @@ -84,8 +84,17 @@ looking at magic, or by checking if it is tied again threads::shared. shared_sv * Perl_sharedsv_find(pTHX_ SV* sv) { - /* does all it can to find a shared_sv struct, returns NULL otherwise */ - shared_sv* ssv = NULL; + /* does all it can to find a shared_sv struct, returns NULL otherwise */ + shared_sv* ssv = NULL; + switch (SvTYPE(sv)) { + case SVt_PVMG: + {MAGIC* mg = mg_find(sv, PERL_MAGIC_ext); + + if(strcmp(mg->mg_ptr,"threads::shared")) + break; + ssv = (shared_sv*) SvIV(mg->mg_obj); + } + } return ssv; } @@ -164,9 +173,9 @@ Increments the threadcount of a sharedsv. void Perl_sharedsv_thrcnt_inc(pTHX_ shared_sv* ssv) { - SHAREDSvEDIT(ssv); + SHAREDSvLOCK(ssv); SvREFCNT_inc(ssv->sv); - SHAREDSvRELEASE(ssv); + SHAREDSvUNLOCK(ssv); } /* @@ -182,7 +191,7 @@ void Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv) { SV* sv; - SHAREDSvEDIT(ssv); + SHAREDSvLOCK(ssv); sv = SHAREDSvGET(ssv); if (SvREFCNT(sv) == 1) { switch (SvTYPE(sv)) { @@ -211,8 +220,8 @@ Perl_sharedsv_thrcnt_dec(pTHX_ shared_sv* ssv) } } } - SvREFCNT_dec(sv); - SHAREDSvRELEASE(ssv); + Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(ssv)); + SHAREDSvUNLOCK(ssv); } #endif /* USE_ITHREADS */