This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
First support of threads::shared, support shared svs and references.
authorArtur Bergman <sky@nanisky.com>
Sun, 21 Oct 2001 15:25:16 +0000 (15:25 +0000)
committerArtur Bergman <sky@nanisky.com>
Sun, 21 Oct 2001 15:25:16 +0000 (15:25 +0000)
p4raw-id: //depot/perl@12545

MANIFEST
ext/threads/shared/Makefile.PL [new file with mode: 0755]
ext/threads/shared/README [new file with mode: 0644]
ext/threads/shared/shared.pm [new file with mode: 0644]
ext/threads/shared/shared.xs [new file with mode: 0644]
ext/threads/shared/t/sv_refs.t [new file with mode: 0644]
ext/threads/shared/t/sv_simple.t [new file with mode: 0644]
sharedsv.c

index f38b378..486a2b3 100644 (file)
--- 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 (executable)
index 0000000..8587906
--- /dev/null
@@ -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 <arthur@contiller.se>') : ()),
+    '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 (file)
index 0000000..0690835
--- /dev/null
@@ -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 (file)
index 0000000..2aae9f1
--- /dev/null
@@ -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 <lt>artur at contiller.se<gt>
+
+threads is released under the same license as Perl
+
+=head1 SEE ALSO
+
+L<perl> L<threads>
+
+=cut
+
+
diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs
new file mode 100644 (file)
index 0000000..90049e2
--- /dev/null
@@ -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 (file)
index 0000000..36977e7
--- /dev/null
@@ -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 (file)
index 0000000..2a0d297
--- /dev/null
@@ -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");
+
+
+
+
+
+
+
index 2d347b8..0deabb2 100644 (file)
@@ -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 */