search

Perl / perl5

🐪 The Perl programming language
https://dev.perl.org/perl5/
Other
1.91k stars 542 forks source link

Bizarre refaddrs with threads::shared #8247

Closed p5pRT closed 18 years ago

p5pRT commented 18 years ago

Migrated from rt.perl.org#37946 (status was 'resolved')

Searchable as RT37946$

p5pRT commented 18 years ago

From jerry@hedden.us

This is a bug report for perl from jerry@​hedden.us\, generated with the help of perlbug 1.35 running under perl v5.8.7.

When a scalar variable is tagged with the :shared attribute and then assigned a shared ref\, the variable's refaddr is not constant.

If the :shared attribute is not used\, the refaddr is constant (as it should be).

The sample code below illustrates the bug​:

===== Begin shared_refaddr_bug.pl =====

use threads; use threads​::shared;

# Variable with '​:shared' attribute my $shared :shared = &share({}); $$shared{'foo'} = 'bar';

print("Print refaddr of :shared var\n"); print("It alternates between two value!\n"); print($shared\, "\n"); print($shared\, "\n"); print($shared\, "\n"); print($shared\, "\n"); print($shared\, "\n"); print($shared\, "\n\n");

# Variable without '​:shared' attribute my $var = &share({});

print("Print refaddr of var without :shared\n"); print("Same address each time\n"); print("However\, it's the same as one of the above!\n"); print($var\, "\n"); print($var\, "\n"); print($var\, "\n"); print($var\, "\n"); print($var\, "\n"); print($var\, "\n\n");

print("Print refaddr of :shared var\, again\n"); print("It alternates again\, but with a new address\n"); print($shared\, "\n"); print($shared\, "\n"); print($shared\, "\n"); print($shared\, "\n"); print($shared\, "\n"); print($shared\, "\n\n");

===== End shared_refaddr_bug.pl =====

===== Output from the above =====

Print refaddr of :shared var It alternates between two value! HASH(0x10010fa8) HASH(0x100110b0) HASH(0x10010fa8) HASH(0x100110b0) HASH(0x10010fa8) HASH(0x100110b0)

Print refaddr of var without :shared Same address each time However\, it's the same as one of the above! HASH(0x10010fa8) HASH(0x10010fa8) HASH(0x10010fa8) HASH(0x10010fa8) HASH(0x10010fa8) HASH(0x10010fa8)

Print refaddr of :shared var\, again It alternates again\, but with a new address HASH(0x1002ee78) HASH(0x100110b0) HASH(0x1002ee78) HASH(0x100110b0) HASH(0x1002ee78) HASH(0x100110b0)

=================================

I tested this on Cygwin 5.8.7 and Solaris 5.8.0\, 5.8.2 and 5.8.7 with the same results for all.

I initially encounted this bug with the following​:

===== Begin bug_oio.pl =====

use threads; use threads​::shared;

package My​::Class; {   use Object​::InsideOut '​:SHARED'; }

package main;

# New object my $obj :shared = My​::Class->new();

print("$obj $$obj\n"); print("$obj $$obj\n"); print("$obj $$obj\n"); print("$obj $$obj\n"); print("$obj $$obj\n"); print("$obj $$obj\n");

===== End bug_oio.pl =====

===== Output from the above =====

My​::Class=SCALAR(0x101466cc) 1 My​::Class=SCALAR(0x101e2544) My​::Class=SCALAR(0x101466cc) My​::Class=SCALAR(0x101e2544) My​::Class=SCALAR(0x101466cc) My​::Class=SCALAR(0x101e2544)

=================================

This not only shows the alternating refaddr\, but also shows that the contents of the scalar ref is getting wiped out. Unfortunately\, I was not able to produce this latter behavior in a sample that doesn't use Object​::InsideOut.

Flags​:   category=core   severity=high

Site configuration information for perl v5.8.7​:

Configured by Jerry at Wed Dec 14 13​:31​:18 EST 2005.

Summary of my perl5 (revision 5 version 8 subversion 7) configuration​:   Platform​:   osname=cygwin\, osvers=1.5.18(0.13242)\, archname=cygwin-thread-multi-64int   uname='cygwin_nt-5.0 pn100-01-1-123s 1.5.18(0.13242) 2005-07-02 20​:30 i686 unknown unknown cygwin '   config_args='-de -Duse64bitint -Dusethreads -Uusemymalloc -A define​:optimize=-O3 -pipe -frename-registers -fomit-frame-pointer -march=pentium4 -mfpmath=sse -mmmx -msse -msse2 -A define​:ld=/usr/local/bin/ld2'   hint=recommended\, useposix=true\, d_sigaction=define   usethreads=define use5005threads=undef useithreads=define usemultiplicity=define   useperlio=define d_sfio=undef uselargefiles=define usesocks=undef   use64bitint=define use64bitall=undef uselongdouble=undef   usemymalloc=n\, bincompat5005=undef   Compiler​:   cc='gcc'\, ccflags ='-DPERL_USE_SAFE_PUTENV -fno-strict-aliasing -pipe -Wdeclaration-after-statement -I/usr/local/include'\,   optimize='-O3 -pipe -frename-registers -fomit-frame-pointer -march=pentium4 -mfpmath=sse -mmmx -msse -msse2'\,   cppflags='-DPERL_USE_SAFE_PUTENV -fno-strict-aliasing -pipe -Wdeclaration-after-statement -I/usr/local/include'   ccversion=''\, gccversion='3.4.4 (cygming special) (gdc 0.12\, using dmd 0.125)'\, gccosandvers=''   intsize=4\, longsize=4\, ptrsize=4\, doublesize=8\, byteorder=12345678   d_longlong=define\, longlongsize=8\, d_longdbl=define\, longdblsize=12   ivtype='long long'\, ivsize=8\, nvtype='double'\, nvsize=8\, Off_t='off_t'\, lseeksize=8   alignbytes=8\, prototype=define   Linker and Libraries​:   ld='/usr/local/bin/ld2'\, ldflags =' -s -L/usr/local/lib'   libpth=/usr/local/lib /usr/lib /lib   libs=-lgdbm -ldb -lcrypt -lgdbm_compat   perllibs=-lcrypt -lgdbm_compat   libc=/usr/lib/libc.a\, so=dll\, useshrplib=true\, libperl=libperl.a   gnulibc_version=''   Dynamic Linking​:   dlsrc=dl_dlopen.xs\, dlext=dll\, d_dlsymun=undef\, ccdlflags=' -s'   cccdlflags=' '\, lddlflags=' -s -L/usr/local/lib'

Locally applied patches​:

@​INC for perl v5.8.7​:   /usr/local/lib/perl5/5.8/cygwin   /usr/local/lib/perl5/5.8   /usr/local/lib/perl5/site_perl/5.8/cygwin   /usr/local/lib/perl5/site_perl/5.8   /usr/local/lib/perl5/vendor_perl/5.8/cygwin   /usr/local/lib/perl5/vendor_perl/5.8   .

Environment for perl v5.8.7​:   CYGWIN=server ntsec forkchunk​:32768   HOME=/home/jhedden   LANG=C   LANGUAGE=C   LC_ALL=C   LD_LIBRARY_PATH (unset)   LOGDIR (unset)  
PATH=/home/jhedden/bin​:/usr/local/bin​:/usr/bin​:/bin​:/usr/X11R6/bin​:/c/MinGW/bin​:/c/Perl/bin/​:/c/djgpp/bin​:/c/Program Files/WiX​:/c/Program Files/nant-0.85-rc3/bin​:/c/Program Files/apache-ant-1.6.3/bin​:/c/j2sdk1.4.2_08/bin​:/c/Program Files/Documentum/Shared​:/c/blp/API​:/c/oracle/ora92/bin​:/c/Program Files/Oracle/jre/1.3.1/bin​:/c/Program Files/Oracle/jre/1.1.8/bin​:/c/WINNT/system32​:/c/WINNT​:/c/WINNT/system32/WBEM​:/c/Program Files/cvsnt​:/usr/local/lib​:.   PERLIO=perlio   PERL_BADLANG (unset)   SHELL (unset)

p5pRT commented 18 years ago

From @nwc10

On Wed\, Dec 14\, 2005 at 12​:09​:12PM -0800\, Jerry D. Hedden wrote​:

Print refaddr of :shared var It alternates between two value! HASH(0x10010fa8) HASH(0x100110b0) HASH(0x10010fa8) HASH(0x100110b0) HASH(0x10010fa8) HASH(0x100110b0)

It seems that it's always a temporary copy\, freshly allocated for each call\, and correctly freed up\, so 2 particular memory locations are being used alternatively for the temporary​:

My limited understanding of the threads​::shared is that there is a master copy of everything in a private perl interpreter (the "shared space") and every shared variable you can access is a local proxy associated with the master. What we have here is a shared scalar referencing a shared (anonymous) hash - 2 SVs\, so what the local perl interpreter is dealing with are the 2 proxies.

Getting data to/from the proxies to the master copy is implemented by the perl "magic" system. The code for the magic get for the scalar (the reference) (get to the proxy)is in ext/threads/shared.xs​:

int sharedsv_scalar_mg_get(pTHX_ SV *sv\, MAGIC *mg) {   shared_sv *shared = (shared_sv *) mg->mg_ptr;   assert(shared);

  ENTER_LOCK;   if (SHAREDSvPTR(shared)) {   if (SvROK(SHAREDSvPTR(shared))) {   SV *obj = Nullsv;   Perl_sharedsv_associate(aTHX_ &obj\, SvRV(SHAREDSvPTR(shared))\, NULL);   sv_setsv_nomg(sv\, &PL_sv_undef);   SvRV_set(sv\, obj);   SvROK_on(sv);  
  }   else {   sv_setsv_nomg(sv\, SHAREDSvPTR(shared));   }   }   LEAVE_LOCK;   return 0; }

It seems that the bug is in the argument &obj to Perl_sharedsv_associate. Nullsv is (SV *)0

(why does the code love to do this? Does it date back to the time before ANSI prototypes?)

which being a pointer to a NULL\, makes the code in Perl_sharedsv_associate create a new thread-local proxy\, rather than re-using the same one.

The second and subsequent time sharedsv_scalar_mg_get is called\, it happens that the variable sv is proxy reference\, pointing to a proxy anonymous hash copy generated last call.

The call to Perl_sharedsv_associate generates a new proxy for the hash. The next line

  sv_setsv_nomg(sv\, &PL_sv_undef);

has the effect of neatly undefining the proxy reference\, so the (previous) proxy hash is no longer referenced by anything\, and freed. This explains the cycling between 2 values - the old proxy is freed just after the new proxy is allocated.

I think that what the code in sharedsv_scalar_mg_get should be doing in the general case is passing in a pointer to the previous value\, so that the same proxy can be re-used\, but I'm not sure how this works for the first call.

I'm not familiar with this code\, and not sure of the best way to fix this.

Nicholas Clark

p5pRT commented 18 years ago

The RT System itself - Status changed from 'new' to 'open'

p5pRT commented 18 years ago

From @iabyn

On Thu\, Dec 15\, 2005 at 10​:55​:24PM +0000\, Nicholas Clark wrote​:

I'm not familiar with this code\, and not sure of the best way to fix this.

At this point I'll add my usual mournful refrain​: "once I get some tuits I'll have a look"

-- Thank God I'm an atheist.....

p5pRT commented 18 years ago

From @nwc10

On Wed\, Dec 14\, 2005 at 12​:09​:12PM -0800\, Jerry D. Hedden wrote​:

I initially encounted this bug with the following​:

This not only shows the alternating refaddr\, but also shows that the contents of the scalar ref is getting wiped out. Unfortunately\, I was not able to produce this latter behavior in a sample that doesn't use Object​::InsideOut.

I should have added to my original message - to me it seems worth seeing if solving the reference address problem turns out to resolve the problem with the contents being wiped out.

Nicholas Clark

p5pRT commented 18 years ago

From @iabyn

On Thu\, Dec 15\, 2005 at 10​:55​:24PM +0000\, Nicholas Clark wrote​:

On Wed\, Dec 14\, 2005 at 12​:09​:12PM -0800\, Jerry D. Hedden wrote​:

Print refaddr of :shared var It alternates between two value! HASH(0x10010fa8) HASH(0x100110b0) HASH(0x10010fa8) HASH(0x100110b0) HASH(0x10010fa8) HASH(0x100110b0)

It seems that it's always a temporary copy\, freshly allocated for each call\, and correctly freed up\, so 2 particular memory locations are being used alternatively for the temporary​:

Essentially fixed by change #26695

Basically\, every time an mg_get() was done on a private SV who's shared twin in shared space was an RV\, a new private-side referent was created for it to point at. The code now preserves the old referent if its suitable​: ie if its magic points to the right shared referent and they're the same type.

This also makes thing go faster​: the following code​:

  our @​a : shared;   for (1..10_000_000) {   $a[$_ % 10_000]++;   }

which I made go 13% faster yesterday with change #26684\, is now a further 7% faster with this new change\, for a cummulative speedup of 20%.

Which is nice.

Dave

-- print+qq&$}$"$/$s$\,$*${d}$g$s$@​$.$q$\,$​:$.$q$^$\,$@​$*$~$;$.$q$m&if+map{m\,^\d{0\\,}\,\,${$​::{$'}}=chr($"+=$&||1)}q&10m22\,42}6​:17*2~2.3@​3;^2dg3q/s"&=~m*\d\*.*g

p5pRT commented 18 years ago

From @ysth

On Sat\, Jan 07\, 2006 at 03​:25​:40AM +0000\, Dave Mitchell wrote​:

This also makes thing go faster​: the following code​:

our @​a : shared;
for \(1\.\.10\_000\_000\) \{
    $a\[$\_ % 10\_000\]\+\+;
\}

which I made go 13% faster yesterday with change #26684\, is now a further 7% faster with this new change\, for a cummulative speedup of 20%.

ObMath​: 13% + 7% = 21%

p5pRT commented 18 years ago

From nospam-abuse@bloodgate.com

-----BEGIN PGP SIGNED MESSAGE-----

Moin\,

Yitzchak Scott-Thoennes \sthoenna@​efn\.org scribbled​:

On Sat\, Jan 07\, 2006 at 03​:25​:40AM +0000\, Dave Mitchell wrote​:

This also makes thing go faster​: the following code​:

our @​a : shared;
for \(1\.\.10\_000\_000\) \{
    $a\[$\_ % 10\_000\]\+\+;
\}

which I made go 13% faster yesterday with change #26684\, is now a further 7% faster with this new change\, for a cummulative speedup of 20%.

You are my hero! (This somehow suggests\, that apart from being buggy\, threads were slow in Perl. I know why I avoid them like the plague :)

Yitzchak wrote​:

ObMath​: 13% + 7% = 21%

It depends on how you round​:

  1.13 * 1.07 = 1.2091

See http​://www.pldesignline.com/howto/showArticle.jhtml;?articleID=175801189 for reference :)

Best wishes\,

Tels

- -- Signed on Sun Jan 8 10​:58​:36 2006 with key 0x93B84C15. Visit my photo gallery at http​://bloodgate.com/photos/ PGP key on http​://bloodgate.com/tels.asc or per email.

"Retsina?" - "Ja\, Papa?" - "Rasenmähen." - "Is gut\, Papa."

-----BEGIN PGP SIGNATURE----- Version​: GnuPG v1.2.4 (GNU/Linux)

iQEVAwUBQ8DjT3cLPEOTuEwVAQGpYQf9ENzQ1B6E/hlUdi1FMsRFUJ1PoemB5YiQ EhNcm03VhsWvXq+3JotZwKC3JhN/NDIfPc3rI25LXwESE2ospfkwr84qWf98Hn3q jpdIvH5lvEXVtkpBr8J685VkzRkNaWeZPRV9uKFYjPI0LNBW9RoW4d3LzRvfvGKd UwO1n5g/F9zzuHFV/M3XFb3URfZ1j40ee8q3W6kIf3tOuWkOyIFTdFs8yeJPiNDY MpUzj5fDX+aHoLqG46Mmk6HpFsaIkN0ck3rqzidvY9d68UtgoQo6DugK3D7Q1w8q QJb8fNgifsyAzcOIh3StGW5qczRx2JvOqqIlM4azZKlYgYF88Kz8PQ== =/sj0 -----END PGP SIGNATURE-----

p5pRT commented 18 years ago

From david@landgren.net

Yitzchak Scott-Thoennes a écrit :

On Sat\, Jan 07\, 2006 at 03​:25​:40AM +0000\, Dave Mitchell wrote​:

This also makes thing go faster​: the following code​:

our @​a : shared;
for \(1\.\.10\_000\_000\) \{
    $a\[$\_ % 10\_000\]\+\+;
\}

which I made go 13% faster yesterday with change #26684\, is now a further 7% faster with this new change\, for a cummulative speedup of 20%.

ObMath​: 13% + 7% = 21%

... when using base 9 arithmetic

David -- "It's overkill of course\, but you can never have too much overkill."

p5pRT commented 18 years ago

From vadim@vkonovalov.ru

On Sun\, 2006-01-08 at 17​:52 +0100\, David Landgren wrote​:

Yitzchak Scott-Thoennes a écrit :

On Sat\, Jan 07\, 2006 at 03​:25​:40AM +0000\, Dave Mitchell wrote​:

This also makes thing go faster​: the following code​:

our @​a : shared;
for \(1\.\.10\_000\_000\) \{
    $a\[$\_ % 10\_000\]\+\+;
\}

which I made go 13% faster yesterday with change #26684\, is now a further 7% faster with this new change\, for a cummulative speedup of 20%.

ObMath​: 13% + 7% = 21%

... when using base 9 arithmetic

1.13 * 1.07 = 1.2091 which is approximately 21%

p5pRT commented 18 years ago

From @jimc

Vadim Konovalov wrote​:

On Sun\, 2006-01-08 at 17​:52 +0100\, David Landgren wrote​:

Yitzchak Scott-Thoennes a écrit :

On Sat\, Jan 07\, 2006 at 03​:25​:40AM +0000\, Dave Mitchell wrote​:

This also makes thing go faster​: the following code​:

our @​a : shared; for (1..10_000_000) { $a[$_ % 10_000]++; }

which I made go 13% faster yesterday with change #26684\, is now a further 7% faster with this new change\, for a cummulative speedup of 20%.

ObMath​: 13% + 7% = 21%

... when using base 9 arithmetic

1.13 * 1.07 = 1.2091 which is approximately 21%

um .. shouldnt we be testing something ?

just a thought...

:-)

p5pRT commented 18 years ago

From nospam-abuse@bloodgate.com

-----BEGIN PGP SIGNED MESSAGE-----

Math\,

Jim Cromie wrote​:

Vadim Konovalov wrote​:

On Sun\, 2006-01-08 at 17​:52 +0100\, David Landgren wrote​:

Yitzchak Scott-Thoennes a écrit :

On Sat\, Jan 07\, 2006 at 03​:25​:40AM +0000\, Dave Mitchell wrote​:

which I made go 13% faster yesterday with change #26684\, is now a 7% faster with this new change\, for a cummulative speedup of 20%. ObMath​: 13% + 7% = 21% ... when using base 9 arithmetic 1.13 * 1.07 = 1.2091 which is approximately 21% um .. shouldnt we be testing something ?

Yeah\, BigFloat's rounding modes​:

# perl -Mbignum -le 'print +(1.13 * 1.07)->round(3\,undef\,"trunc")' 1.20 # perl -Mbignum -le 'print +(1.13 * 1.07)->round(3\,undef\,"zero")' 1.21

Sorry\, sorry\, I go and kill myself now... :o)

Tels

- -- Signed on Sun Jan 8 22​:22​:16 2006 with key 0x93B84C15. Visit my photo gallery at http​://bloodgate.com/photos/ PGP key on http​://bloodgate.com/tels.asc or per email.

"HOT PACKET ON SERVER ACTION! Click here for FREE ACCESS to streaming video of dirty packets penetrating badly-configured firewalls!!!" aanand (705284) on 2004-03-20 on /. about the Adult Bit and the Evil bit

-----BEGIN PGP SIGNATURE----- Version​: GnuPG v1.2.4 (GNU/Linux)

iQEVAwUBQ8GDI3cLPEOTuEwVAQEgWwf/U+lNo+HZrIDBn6rC1gDb91RR3zcBDtIg N5+dU8UcIlGp2sqPKHxT00ObWH9LK2e2Pdn036sdgbDhPASp49RK/P9/6UpUwjbo 72yICIXCmWKu+SUJlIucwIRul7j3AeGz/C5yKXPzeVqTRogWkK27V0sU05c+RGif Ec6bdyLn8qGs/VSpxc94EHStQU0dIrKbknbEQ07NQ1mYagGyEKdtpRxZQVhYRcy4 mS8IeaAKlDUyo9+0cmA+mxjVdHDWatCeH1RX5KwSAkGo22DLM9DrpfcVQmzEeK47 bVCuz7D4jLakhMhUM+HwXvVpfmSRSwv1RmDbAg4YLiUpQhybfkYK0w== =80/N -----END PGP SIGNATURE-----

p5pRT commented 18 years ago

From guest@guest.guest.xxxxxxxx

[davem@​iabyn.com - Fri Jan 06 19​:24​:29 2006]​: Essentially fixed by change #26695

The attached diffs (patch ?) includes changes to shared.xs from patches 26684\, 26693 and 26695. It was made against maint up to patch 26748.

It excludes changes from patch 26569 that deals with localizing shared variables as that patch involves others that have not yet made it into maint.

The following file is to be deleted​:   perl-maint/ext/threads/shared/typemap

The diffs are attached.

My hope is that this will assist Nicholas Clark in getting the above patches into the 5.8.8 release.

Thanks\, Jerry D. Hedden jdhedden AT cpan DOT org

p5pRT commented 18 years ago

From guest@guest.guest.xxxxxxxx

Inline Patch ```diff diff -u -r perl-26748/MANIFEST perl-patched/MANIFEST --- perl-26748/MANIFEST 2006-01-09 15:22:36.627867100 -0500 +++ perl-patched/MANIFEST 2006-01-09 15:19:42.672528100 -0500 @@ -906,7 +906,6 @@ ext/threads/shared/t/sv_refs.t thread shared variables ext/threads/shared/t/sv_simple.t thread shared variables ext/threads/shared/t/wait.t Test cond_wait and cond_timedwait -ext/threads/shared/typemap thread::shared types ext/threads/t/basic.t ithreads ext/threads/t/end.t Test end functions ext/threads/threads.pm ithreads diff -u -r perl-26748/ext/threads/shared/shared.xs perl-patched/ext/threads/shared/shared.xs --- perl-26748/ext/threads/shared/shared.xs 2006-01-09 15:22:12.262102000 -0500 +++ perl-patched/ext/threads/shared/shared.xs 2006-01-09 14:12:39.517170600 -0500 @@ -1,6 +1,6 @@ /* shared.xs * - * Copyright (c) 2001-2002, Larry Wall + * Copyright (c) 2001-2002, 2006 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -13,6 +13,106 @@ * pulled in the (an)other direction by Nick Ing-Simmons nick@ing-simmons.net */ +/* + * Shared variables are implemented by a scheme similar to tieing. + * Each thread has a proxy SV with attached magic -- "private SVs" -- + * which all point to a single SV in a separate shared interpreter + * (PL_sharedsv_space) -- "shared SVs". + * + * The shared SV holds the variable's true values, and its state is + * copied between the shared and private SVs with the usual + * mg_get()/mg_set() arrangement. + * + * Aggregates (AVs and HVs) are implemented using tie magic, except that + * the vtable used is one defined in this file rather than the standard one. + * This means that where a tie function like is FETCH is normally invoked by + * the tie magic's mg_get() function, we completely bypass the calling of a + * perl-level function, and directly call C-level code to handle it. On + * the other hand. calls to functions like PUSH are done directly by code + * in av.c etc, which we can't bypass. So the best we can do is to provide + * XS versions of these functions. We also have to attach a tie object, + * blessed into the class threads::shared::tie, to keep the method-calling + * code happy. + * + * Access to aggregate elements is done the usual tied way by returning a + * proxy PVLV element with attached element magic. + * + * Pointers to the shared SV are squirrelled away in the mg->mg_ptr field + * of magic (with mg_len == 0), and in the IV2PTR(SvIV(sv)) field of tied + * object SVs. These pointers have to be hidden like this because they + * cross interpreter boundaries, and we don't want sv_clear() and friends + * following them. + * + * The three basic shared types look like the following: + * + * ----------------- + * + * Shared scalar (my $s : shared): + * + * SV = PVMG(0x7ba238) at 0x7387a8 + * FLAGS = (PADMY,GMG,SMG) + * MAGIC = 0x824d88 + * MG_TYPE = PERL_MAGIC_shared_scalar(n) + * MG_PTR = 0x810358 <<<< pointer to the shared SV + * + * ----------------- + * + * Shared aggregate (my @a : shared; my %h : shared): + * + * SV = PVAV(0x7175d0) at 0x738708 + * FLAGS = (PADMY,RMG) + * MAGIC = 0x824e48 + * MG_TYPE = PERL_MAGIC_tied(P) + * MG_OBJ = 0x7136e0 <<<< ref to the tied object + * SV = RV(0x7136f0) at 0x7136e0 + * RV = 0x738640 + * SV = PVMG(0x7ba238) at 0x738640 <<<< the tied object + * FLAGS = (OBJECT,IOK,pIOK) + * IV = 8455000 <<<< pointer to the shared AV + * STASH = 0x80abf0 "threads::shared::tie" + * MG_PTR = 0x810358 "" <<<< another pointer to the shared AV + * ARRAY = 0x0 + * + * ----------------- + * + * Aggregate element (my @a : shared; $a[0]) + * + * SV = PVLV(0x77f628) at 0x713550 + * FLAGS = (GMG,SMG,RMG,pIOK) + * MAGIC = 0x72bd58 + * MG_TYPE = PERL_MAGIC_shared_scalar(n) + * MG_PTR = 0x8103c0 "" <<<< pointer to the shared element + * MAGIC = 0x72bd18 + * MG_TYPE = PERL_MAGIC_tiedelem(p) + * MG_OBJ = 0x7136e0 <<<< ref to the tied object + * SV = RV(0x7136f0) at 0x7136e0 + * RV = 0x738660 + * SV = PVMG(0x7ba278) at 0x738660 <<<< the tied object + * FLAGS = (OBJECT,IOK,pIOK) + * IV = 8455064 <<<< pointer to the shared AV + * STASH = 0x80ac30 "threads::shared::tie" + * TYPE = t + * + * Note that PERL_MAGIC_tiedelem(p) magic doesn't have a pointer to a + * shared SV in mg_ptr; instead this is used to store the hash key, + * if any, like normal tied elements. Note also that element SVs may have + * pointers to both the shared aggregate and the shared element + * + * + * Userland locks: + * + * if a shared variable is used as a perl-level lock or condition + * variable, then PERL_MAGIC_ext magic is attached to the associated + * *shared* SV, whose mg_ptr field points to a malloced structure + * containing the necessary mutexes and condition variables. + * + * Nomenclature: + * + * In this file, any variable name prefixed with 's', eg ssv, stmp or sobj, + * usually represents a shared SV which correspondis to a private SV named + * without the prefix, eg sv, tmp or obj. + */ + #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" @@ -20,8 +120,6 @@ #ifdef USE_ITHREADS -#define SHAREDSvPTR(a) ((a)->sv) - /* * The shared things need an intepreter to live in ... */ @@ -132,6 +230,7 @@ recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__); \ } STMT_END +/* the unlocking is done automatically at scope exit */ #define LEAVE_LOCK LEAVE @@ -148,52 +247,42 @@ } STMT_END -/* - - Shared SV - - Shared SV is a structure for keeping the backend storage - of shared svs. - - Shared-ness really only needs the SV * - the rest is for locks. - (Which suggests further space optimization ... ) - +/* user-level locks: + This structure is attached (using ext magic) to any shared SV that + is used by user-level locking or condition code */ typedef struct { - SV *sv; /* The actual SV - in shared space */ - recursive_lock_t lock; + recursive_lock_t lock; /* for user-levl locks */ perl_cond user_cond; /* For user-level conditions */ -} shared_sv; +} user_lock; -/* The SV in shared-space has a back-pointer to the shared_sv - struct associated with it PERL_MAGIC_ext. +/* magic used for attaching user_lock structs to shared SVs The vtable used has just one entry - when the SV goes away we free the memory for the above. - */ int -sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg) +sharedsv_userlock_free(pTHX_ SV *sv, MAGIC *mg) { - shared_sv *shared = (shared_sv *) mg->mg_ptr; - assert( aTHX == PL_sharedsv_space ); - if (shared) { - recursive_lock_destroy(aTHX_ &shared->lock); - COND_DESTROY(&shared->user_cond); - PerlMemShared_free(shared); + user_lock *ul = (user_lock *) mg->mg_ptr; + assert(aTHX == PL_sharedsv_space); + if (ul) { + recursive_lock_destroy(aTHX_ &ul->lock); + COND_DESTROY(&ul->user_cond); + PerlMemShared_free(ul); mg->mg_ptr = NULL; } return 0; } -MGVTBL sharedsv_shared_vtbl = { +MGVTBL sharedsv_uesrlock_vtbl = { 0, /* get */ 0, /* set */ 0, /* len */ 0, /* clear */ - sharedsv_shared_mg_free, /* free */ + sharedsv_userlock_free, /* free */ 0, /* copy */ 0, /* dup */ }; @@ -208,25 +297,54 @@ MGVTBL sharedsv_scalar_vtbl; /* scalars have this vtable */ MGVTBL sharedsv_array_vtbl; /* hashes and arrays have this - like 'tie' */ MGVTBL sharedsv_elem_vtbl; /* elements of hashes and arrays have this - _AS WELL AS_ the scalar magic */ - -/* The sharedsv_elem_vtbl associates the element with the array/hash and + _AS WELL AS_ the scalar magic: + The sharedsv_elem_vtbl associates the element with the array/hash and the sharedsv_scalar_vtbl associates it with the value */ -/* Accessor to convert threads::shared::tie objects back shared_sv * */ -shared_sv * -SV_to_sharedsv(pTHX_ SV *sv) -{ - shared_sv *shared = 0; - if (SvROK(sv)) - { - shared = INT2PTR(shared_sv *, SvIV(SvRV(sv))); - } - return shared; +/* get shared aggregate SV pointed to by threads::shared::tie magic object */ + +STATIC SV * +S_sharedsv_from_obj(pTHX_ SV *sv) +{ + return SvROK(sv) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL; } + +/* Return the user_lock structure (if any) associated with a shared SV. + * If create is true, create one if it doesn't exist */ + +STATIC user_lock * +S_get_userlock(pTHX_ SV* ssv, bool create) +{ + MAGIC *mg; + user_lock *ul = NULL; + + assert(ssv); + /* XXX redsign the storage of user locks so we dont need a global + * lock to access them ???? DAPM */ + ENTER_LOCK; + mg = mg_find(ssv, PERL_MAGIC_ext); + if (mg) + ul = (user_lock*)(mg->mg_ptr); + else if (create) { + dTHXc; + SHARED_CONTEXT; + ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock)); + Zero(ul, 1, user_lock); + /* attach to shared SV using ext magic */ + sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_uesrlock_vtbl, + (char *)ul, 0); + recursive_lock_init(aTHX_ &ul->lock); + COND_INIT(&ul->user_cond); + CALLER_CONTEXT; + } + LEAVE_LOCK; + return ul; +} + + =for apidoc sharedsv_find Given a private side SV tries to find if the SV has a shared backend, @@ -234,7 +352,7 @@ =cut -shared_sv * +SV * Perl_sharedsv_find(pTHX_ SV *sv) { MAGIC *mg; @@ -244,7 +362,7 @@ case SVt_PVHV: if ((mg = mg_find(sv, PERL_MAGIC_tied)) && mg->mg_virtual == &sharedsv_array_vtbl) { - return (shared_sv *) mg->mg_ptr; + return (SV *) mg->mg_ptr; } break; default: @@ -253,157 +371,137 @@ */ if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar)) && mg->mg_virtual == &sharedsv_scalar_vtbl) { - return (shared_sv *) mg->mg_ptr; + return (SV *) mg->mg_ptr; } break; } } /* Just for tidyness of API also handle tie objects */ if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) { - return SV_to_sharedsv(aTHX_ sv); + return S_sharedsv_from_obj(aTHX_ sv); } return NULL; } -/* - * Almost all the pain is in this routine. - * - */ -shared_sv * -Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data) +/* associate a private SV with a shared SV by pointing the appropriate + * magics at it. Assumes lock is held */ + +void +Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv) { dTHXc; MAGIC *mg = 0; - SV *sv = (psv) ? *psv : Nullsv; - /* If we are asked for an private ops we need a thread */ + /* If we are asked for any private ops we need a thread */ assert ( aTHX != PL_sharedsv_space ); /* To avoid need for recursive locks require caller to hold lock */ assert ( PL_sharedsv_lock.owner == aTHX ); - /* First try and get existing global data structure */ + switch(SvTYPE(sv)) { + case SVt_PVAV: + case SVt_PVHV: + if (!(mg = mg_find(sv, PERL_MAGIC_tied)) + || mg->mg_virtual != &sharedsv_array_vtbl + || (SV*) mg->mg_ptr != ssv) + { + SV *obj = newSV(0); + sv_setref_iv(obj, "threads::shared::tie",PTR2IV(ssv)); + if (mg) { + sv_unmagic(sv, PERL_MAGIC_tied); + } + mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl, + (char *) ssv, 0); + mg->mg_flags |= (MGf_COPY|MGf_DUP); + SvREFCNT_inc(ssv); + SvREFCNT_dec(obj); + } + break; - /* Try shared SV as 1st choice */ - if (!data && ssv && SvTYPE(ssv) >= SVt_PVMG) { - if( (mg = mg_find(ssv, PERL_MAGIC_ext)) ){ - data = (shared_sv *) mg->mg_ptr; + default: + if ((SvTYPE(sv) < SVt_PVMG) + || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar)) + || mg->mg_virtual != &sharedsv_scalar_vtbl + || (SV*) mg->mg_ptr != ssv) + { + if (mg) { + sv_unmagic(sv, PERL_MAGIC_shared_scalar); + } + mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, + &sharedsv_scalar_vtbl, (char *)ssv, 0); + mg->mg_flags |= (MGf_DUP); + SvREFCNT_inc(ssv); } + break; } + assert ( Perl_sharedsv_find(aTHX_ sv) == ssv ); +} - /* Next see if private SV is associated with something */ - if (!data && sv) { - data = Perl_sharedsv_find(aTHX_ sv); - } - /* If neither of those then create a new one */ - if (!data) { - SHARED_CONTEXT; - if (!ssv) { - ssv = newSV(0); - SvREFCNT(ssv) = 0; - } - data = (shared_sv *) PerlMemShared_malloc(sizeof(shared_sv)); - Zero(data,1,shared_sv); - SHAREDSvPTR(data) = ssv; - /* Tag shared side SV with data pointer */ - sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl, - (char *)data, 0); - recursive_lock_init(aTHX_ &data->lock); - COND_INIT(&data->user_cond); - CALLER_CONTEXT; - } +/* Given a private SV, create and return an associated shared SV. + * Assumes lock is held */ - if (!ssv) - ssv = SHAREDSvPTR(data); - if (!SHAREDSvPTR(data)) - SHAREDSvPTR(data) = ssv; +STATIC SV * +S_sharedsv_new_shared(pTHX_ SV *sv) +{ + dTHXc; + SV *ssv; - /* If we know type upgrade shared side SV */ - if (sv && SvTYPE(ssv) < SvTYPE(sv)) { - SHARED_CONTEXT; - sv_upgrade(ssv, SvTYPE(*psv)); - if (SvTYPE(ssv) == SVt_PVAV) /* #24061 */ - AvREAL_on(ssv); - CALLER_CONTEXT; - } + assert(PL_sharedsv_lock.owner == aTHX); + assert(aTHX != PL_sharedsv_space); - /* Now if requested allocate private SV */ - if (psv && !sv) { - *psv = sv = newSV(0); - } + SHARED_CONTEXT; + ssv = newSV(0); + SvREFCNT(ssv) = 0; /* will be upped to 1 by Perl_sharedsv_associate */ + sv_upgrade(ssv, SvTYPE(sv)); + CALLER_CONTEXT; + Perl_sharedsv_associate(aTHX_ sv, ssv); + return ssv; +} - /* Finally if private SV exists check and add magic */ - if (sv) { - MAGIC *mg = 0; - if (SvTYPE(sv) < SvTYPE(ssv)) { - sv_upgrade(sv, SvTYPE(ssv)); - } - switch(SvTYPE(sv)) { - case SVt_PVAV: - case SVt_PVHV: - if (!(mg = mg_find(sv, PERL_MAGIC_tied)) - || mg->mg_virtual != &sharedsv_array_vtbl - || (shared_sv *) mg->mg_ptr != data) { - SV *obj = newSV(0); - sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data)); - if (mg) { - sv_unmagic(sv, PERL_MAGIC_tied); - } - mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl, - (char *) data, 0); - mg->mg_flags |= (MGf_COPY|MGf_DUP); - SvREFCNT_inc(ssv); - SvREFCNT_dec(obj); - if(SvOBJECT(ssv)) { - STRLEN len; - char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len); - HV* stash = gv_stashpvn(stash_ptr, len, TRUE); - SvOBJECT_on(sv); - SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash)); - } - } - break; - default: - if ((SvTYPE(sv) < SVt_PVMG) - || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar)) - || mg->mg_virtual != &sharedsv_scalar_vtbl - || (shared_sv *) mg->mg_ptr != data) { - if (mg) { - sv_unmagic(sv, PERL_MAGIC_shared_scalar); - } - mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, - &sharedsv_scalar_vtbl, (char *)data, 0); - mg->mg_flags |= (MGf_COPY|MGf_DUP); - SvREFCNT_inc(ssv); - if(SvOBJECT(ssv)) { - STRLEN len; - char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len); - HV* stash = gv_stashpvn(stash_ptr, len, TRUE); - SvOBJECT_on(sv); - SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash)); - } - } - break; - } - assert ( Perl_sharedsv_find(aTHX_ *psv) == data ); - } - return data; +/* Given a shared SV, create and return an associated private SV. + * Assumes lock is held */ + +STATIC SV * +S_sharedsv_new_private(pTHX_ SV *ssv) +{ + SV *sv; + + assert(PL_sharedsv_lock.owner == aTHX); + assert(aTHX != PL_sharedsv_space); + + sv = newSV(0); + sv_upgrade(sv, SvTYPE(ssv)); + Perl_sharedsv_associate(aTHX_ sv, ssv); + return sv; } -void -Perl_sharedsv_free(pTHX_ shared_sv *shared) + +/* a threadsafe version of SvREFCNT_dec(ssv) */ + +STATIC void +S_sharedsv_dec(pTHX_ SV* ssv) { - if (shared) { + if (!ssv) + return; + ENTER_LOCK; + if (SvREFCNT(ssv) > 1) { + /* no side effects, so can do it lightweight */ + SvREFCNT_dec(ssv); + } + else { dTHXc; - SHARED_EDIT; - SvREFCNT_dec(SHAREDSvPTR(shared)); - SHARED_RELEASE; + SHARED_CONTEXT; + SvREFCNT_dec(ssv); + CALLER_CONTEXT; } + LEAVE_LOCK; } +/* implements Perl-level share() and :shared */ + void Perl_sharedsv_share(pTHX_ SV *sv) { @@ -418,7 +516,7 @@ default: ENTER_LOCK; - Perl_sharedsv_associate(aTHX_ &sv, 0, 0); + (void) S_sharedsv_new_shared(aTHX_ sv); LEAVE_LOCK; SvSETMAGIC(sv); break; @@ -434,6 +532,8 @@ } while (0) #endif /* WIN32 || OS2 */ +/* do OS-specific condition timed wait */ + bool Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) { @@ -496,49 +596,99 @@ #endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */ } -/* MAGIC (in mg.h sense) hooks */ + +/* given a shared RV, copy it's value to a private RV, also coping the + * object status of the referent. + * If the private side is already an appropriate RV->SV combination, keep + * it if possible. + */ + +STATIC void +S_get_RV(pTHX_ SV *sv, SV *ssv) { + SV *sobj = SvRV(ssv); + SV *obj; + if ( ! ( SvROK(sv) + && ((obj = SvRV(sv))) + && (Perl_sharedsv_find(aTHX_ obj) == sobj) + && (SvTYPE(obj) == SvTYPE(sobj)) + ) + ) + { + /* can't reuse obj */ + if (SvROK(sv)) { + SvREFCNT_dec(SvRV(sv)); + } + else { + assert(SvTYPE(sv) >= SVt_RV); + sv_setsv_nomg(sv, &PL_sv_undef); + SvROK_on(sv); + } + obj = S_sharedsv_new_private(aTHX_ SvRV(ssv)); + SvRV_set(sv, obj); + } + + if (SvOBJECT(obj)) { + /* remove any old blessing */ + SvREFCNT_dec(SvSTASH(obj)); + SvOBJECT_off(obj); + } + if (SvOBJECT(sobj)) { + /* add any new old blessing */ + STRLEN len; + char* stash_ptr = SvPV((SV*) SvSTASH(sobj), len); + HV* stash = gv_stashpvn(stash_ptr, len, TRUE); + SvOBJECT_on(obj); + SvSTASH_set(obj, (HV*)SvREFCNT_inc(stash)); + } +} + + +/* ------------ PERL_MAGIC_shared_scalar(n) functions -------------- */ + +/* get magic for PERL_MAGIC_shared_scalar(n) */ int sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg) { - shared_sv *shared = (shared_sv *) mg->mg_ptr; - assert(shared); + SV *ssv = (SV *) mg->mg_ptr; + assert(ssv); ENTER_LOCK; - if (SHAREDSvPTR(shared)) { - if (SvROK(SHAREDSvPTR(shared))) { - SV *obj = Nullsv; - Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL); - sv_setsv_nomg(sv, &PL_sv_undef); - SvRV_set(sv, obj); - SvROK_on(sv); - - } - else { - sv_setsv_nomg(sv, SHAREDSvPTR(shared)); - } + if (SvROK(ssv)) { + S_get_RV(aTHX_ sv, ssv); + } + else { + sv_setsv_nomg(sv, ssv); } LEAVE_LOCK; return 0; } +/* copy the contents of a private SV to a shared SV: + * used by various mg_set()-type functions. + * Assumes lock is held */ + void -sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared) +sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv) { dTHXc; bool allowed = TRUE; + + assert(PL_sharedsv_lock.owner == aTHX); if (SvROK(sv)) { - shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv)); - if (target) { - SV *tmp; + SV *obj = SvRV(sv); + SV *sobj = Perl_sharedsv_find(aTHX_ obj); + if (sobj) { SHARED_CONTEXT; - tmp = newRV(SHAREDSvPTR(target)); - sv_setsv_nomg(SHAREDSvPTR(shared), tmp); - SvREFCNT_dec(tmp); - if(SvOBJECT(SvRV(sv))) { - SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(SvRV(sv))),0); - SvOBJECT_on(SHAREDSvPTR(target)); - SvSTASH_set(SHAREDSvPTR(target), (HV*)fake_stash); + SvUPGRADE(ssv, SVt_RV); + sv_setsv_nomg(ssv, &PL_sv_undef); + + SvRV_set(ssv, SvREFCNT_inc(sobj)); + SvROK_on(ssv); + if(SvOBJECT(obj)) { + SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0); + SvOBJECT_on(sobj); + SvSTASH_set(sobj, (HV*)fake_stash); } CALLER_CONTEXT; } @@ -549,11 +699,11 @@ else { SvTEMP_off(sv); SHARED_CONTEXT; - sv_setsv_nomg(SHAREDSvPTR(shared), sv); + sv_setsv_nomg(ssv, sv); if(SvOBJECT(sv)) { SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0); - SvOBJECT_on(SHAREDSvPTR(shared)); - SvSTASH_set(SHAREDSvPTR(shared), (HV*)fake_stash); + SvOBJECT_on(ssv); + SvSTASH_set(ssv, (HV*)fake_stash); } CALLER_CONTEXT; } @@ -562,46 +712,41 @@ } } +/* set magic for PERL_MAGIC_shared_scalar(n) */ + int sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg) { - shared_sv *shared; + SV *ssv = (SV*)(mg->mg_ptr); + assert(ssv); ENTER_LOCK; - /* We call associate to potentially upgrade shared side SV */ - shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr); - assert(shared); - sharedsv_scalar_store(aTHX_ sv, shared); + if (SvTYPE(ssv) < SvTYPE(sv)) { + dTHXc; + SHARED_CONTEXT; + sv_upgrade(ssv, SvTYPE(sv)); + CALLER_CONTEXT; + } + sharedsv_scalar_store(aTHX_ sv, ssv); LEAVE_LOCK; return 0; } -int -sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg) -{ - shared_sv *shared = (shared_sv *) mg->mg_ptr; -#if 0 - assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000); -#endif - Perl_sharedsv_free(aTHX_ shared); - return 0; -} +/* free magic for PERL_MAGIC_shared_scalar(n) */ int -sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg) +sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg) { + S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); return 0; } /* - * Called during cloning of new threads + * Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread */ int sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { - shared_sv *shared = (shared_sv *) mg->mg_ptr; - if (shared) { - SvREFCNT_inc(SHAREDSvPTR(shared)); - } + SvREFCNT_inc(mg->mg_ptr); return 0; } @@ -609,29 +754,28 @@ sharedsv_scalar_mg_get, /* get */ sharedsv_scalar_mg_set, /* set */ 0, /* len */ - sharedsv_scalar_mg_clear, /* clear */ + 0, /* clear */ sharedsv_scalar_mg_free, /* free */ 0, /* copy */ sharedsv_scalar_mg_dup /* dup */ }; -/* Now the arrays/hashes stuff */ +/* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */ + +/* get magic for PERL_MAGIC_tiedelem(p) */ + int sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) { dTHXc; - shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj); - shared_sv *target = Perl_sharedsv_find(aTHX_ sv); + SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj); SV** svp; - assert ( shared ); - assert ( SHAREDSvPTR(shared) ); - ENTER_LOCK; - if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + if (SvTYPE(saggregate) == SVt_PVAV) { assert ( mg->mg_ptr == 0 ); SHARED_CONTEXT; - svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0); + svp = av_fetch((AV*) saggregate, mg->mg_len, 0); } else { char *key = mg->mg_ptr; @@ -641,21 +785,18 @@ key = SvPV((SV *) mg->mg_ptr, len); } SHARED_CONTEXT; - svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0); + svp = hv_fetch((HV*) saggregate, key, len, 0); } CALLER_CONTEXT; if (svp) { /* Exists in the array */ if (SvROK(*svp)) { - SV *obj = Nullsv; - Perl_sharedsv_associate(aTHX_ &obj, SvRV(*svp), NULL); - sv_setsv_nomg(sv, &PL_sv_undef); - SvRV_set(sv, obj); - SvROK_on(sv); - SvSETMAGIC(sv); + S_get_RV(aTHX_ sv, *svp); } else { - target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target); + /* XXX can this branch ever happen? DAPM */ + /* XXX assert("no such branch"); */ + Perl_sharedsv_associate(aTHX_ sv, *svp); sv_setsv(sv, *svp); } } @@ -667,24 +808,24 @@ return 0; } +/* set magic for PERL_MAGIC_tiedelem(p) */ + int sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg) { dTHXc; - shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj); - shared_sv *target; + SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj); SV **svp; /* Theory - SV itself is magically shared - and we have ordered the magic such that by the time we get here it has been stored to its shared counterpart */ ENTER_LOCK; - assert(shared); - assert(SHAREDSvPTR(shared)); - if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + assert(saggregate); + if (SvTYPE(saggregate) == SVt_PVAV) { assert ( mg->mg_ptr == 0 ); SHARED_CONTEXT; - svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1); + svp = av_fetch((AV*) saggregate, mg->mg_len, 1); } else { char *key = mg->mg_ptr; @@ -693,28 +834,30 @@ if (mg->mg_len == HEf_SVKEY) key = SvPV((SV *) mg->mg_ptr, len); SHARED_CONTEXT; - svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1); + svp = hv_fetch((HV*) saggregate, key, len, 1); } CALLER_CONTEXT; - target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0); - sharedsv_scalar_store(aTHX_ sv, target); + Perl_sharedsv_associate(aTHX_ sv, *svp); + sharedsv_scalar_store(aTHX_ sv, *svp); LEAVE_LOCK; return 0; } +/* clear magic for PERL_MAGIC_tiedelem(p) */ + int sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) { dTHXc; MAGIC *shmg; - shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj); + SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj); ENTER_LOCK; sharedsv_elem_mg_FETCH(aTHX_ sv, mg); if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar))) sharedsv_scalar_mg_get(aTHX_ sv, shmg); - if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + if (SvTYPE(saggregate) == SVt_PVAV) { SHARED_CONTEXT; - av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD); + av_delete((AV*) saggregate, mg->mg_len, G_DISCARD); } else { char *key = mg->mg_ptr; @@ -723,26 +866,21 @@ if (mg->mg_len == HEf_SVKEY) key = SvPV((SV *) mg->mg_ptr, len); SHARED_CONTEXT; - hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD); + hv_delete((HV*) saggregate, key, len, G_DISCARD); } CALLER_CONTEXT; LEAVE_LOCK; return 0; } -int -sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg) -{ - Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj)); - return 0; -} +/* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new + * thread */ int sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { - shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj); - SvREFCNT_inc(SHAREDSvPTR(shared)); - mg->mg_flags |= MGf_DUP; + SvREFCNT_inc(S_sharedsv_from_obj(aTHX_ mg->mg_obj)); + assert(mg->mg_flags & MGf_DUP); return 0; } @@ -751,53 +889,62 @@ sharedsv_elem_mg_STORE, /* set */ 0, /* len */ sharedsv_elem_mg_DELETE, /* clear */ - sharedsv_elem_mg_free, /* free */ + 0, /* free */ 0, /* copy */ sharedsv_elem_mg_dup /* dup */ }; +/* ------------ PERL_MAGIC_tied(P) functions -------------- */ + +/* len magic for PERL_MAGIC_tied(P) */ + U32 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg) { dTHXc; - shared_sv *shared = (shared_sv *) mg->mg_ptr; + SV *ssv = (SV *) mg->mg_ptr; U32 val; SHARED_EDIT; - if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { - val = av_len((AV*) SHAREDSvPTR(shared)); + if (SvTYPE(ssv) == SVt_PVAV) { + val = av_len((AV*) ssv); } else { /* not actually defined by tie API but ... */ - val = HvKEYS((HV*) SHAREDSvPTR(shared)); + val = HvKEYS((HV*) ssv); } SHARED_RELEASE; return val; } +/* clear magic for PERL_MAGIC_tied(P) */ + int sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) { dTHXc; - shared_sv *shared = (shared_sv *) mg->mg_ptr; + SV *ssv = (SV *) mg->mg_ptr; SHARED_EDIT; - if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { - av_clear((AV*) SHAREDSvPTR(shared)); + if (SvTYPE(ssv) == SVt_PVAV) { + av_clear((AV*) ssv); } else { - hv_clear((HV*) SHAREDSvPTR(shared)); + hv_clear((HV*) ssv); } SHARED_RELEASE; return 0; } +/* free magic for PERL_MAGIC_tied(P) */ + int sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg) { - Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr); + S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); return 0; } /* + * copy magic for PERL_MAGIC_tied(P) * This is called when perl is about to access an element of * the array - */ @@ -805,23 +952,20 @@ sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, SV *nsv, const char *name, int namlen) { - shared_sv *shared = (shared_sv *) mg->mg_ptr; MAGIC *nmg = sv_magicext(nsv,mg->mg_obj, toLOWER(mg->mg_type),&sharedsv_elem_vtbl, name, namlen); - ENTER_LOCK; - SvREFCNT_inc(SHAREDSvPTR(shared)); - LEAVE_LOCK; nmg->mg_flags |= MGf_DUP; return 1; } +/* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */ + int sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { - shared_sv *shared = (shared_sv *) mg->mg_ptr; - SvREFCNT_inc(SHAREDSvPTR(shared)); - mg->mg_flags |= MGf_DUP; + SvREFCNT_inc((SV*)mg->mg_ptr); + assert(mg->mg_flags & MGf_DUP); return 0; } @@ -842,9 +986,11 @@ =cut void -Perl_sharedsv_unlock(pTHX_ shared_sv* ssv) +Perl_sharedsv_unlock(pTHX_ SV *ssv) { - recursive_lock_release(aTHX_ &ssv->lock); + user_lock *ul = S_get_userlock(aTHX_ ssv, 0); + assert(ul); + recursive_lock_release(aTHX_ &ul->lock); } =for apidoc sharedsv_lock @@ -855,11 +1001,13 @@ =cut void -Perl_sharedsv_lock(pTHX_ shared_sv* ssv) +Perl_sharedsv_lock(pTHX_ SV *ssv) { + user_lock *ul; if (!ssv) return; - recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__); + ul = S_get_userlock(aTHX_ ssv, 1); + recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__); } /* handles calls from lock() builtin via PL_lockhook */ @@ -867,14 +1015,14 @@ void Perl_sharedsv_locksv(pTHX_ SV *sv) { - shared_sv* shared; + SV *ssv; if(SvROK(sv)) sv = SvRV(sv); - shared = Perl_sharedsv_find(aTHX_ sv); - if(!shared) + ssv = Perl_sharedsv_find(aTHX_ sv); + if(!ssv) croak("lock can only be used on shared values"); - Perl_sharedsv_lock(aTHX_ shared); + Perl_sharedsv_lock(aTHX_ ssv); } =head1 Shared SV Functions @@ -907,107 +1055,114 @@ #ifdef USE_ITHREADS void -PUSH(shared_sv *shared, ...) +PUSH(SV *obj, ...) CODE: dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); int i; for(i = 1; i < items; i++) { SV* tmp = newSVsv(ST(i)); - shared_sv *target; + SV *stmp; ENTER_LOCK; - target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0); - sharedsv_scalar_store(aTHX_ tmp, target); + stmp = S_sharedsv_new_shared(aTHX_ tmp); + sharedsv_scalar_store(aTHX_ tmp, stmp); SHARED_CONTEXT; - av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target)); - SvREFCNT_inc(SHAREDSvPTR(target)); + av_push((AV*) sobj, stmp); + SvREFCNT_inc(stmp); SHARED_RELEASE; SvREFCNT_dec(tmp); } void -UNSHIFT(shared_sv *shared, ...) +UNSHIFT(SV *obj, ...) CODE: dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); int i; ENTER_LOCK; SHARED_CONTEXT; - av_unshift((AV*)SHAREDSvPTR(shared), items - 1); + av_unshift((AV*)sobj, items - 1); CALLER_CONTEXT; for(i = 1; i < items; i++) { - SV* tmp = newSVsv(ST(i)); - shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0); - sharedsv_scalar_store(aTHX_ tmp, target); + SV *tmp = newSVsv(ST(i)); + SV *stmp = S_sharedsv_new_shared(aTHX_ tmp); + sharedsv_scalar_store(aTHX_ tmp, stmp); SHARED_CONTEXT; - av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target)); - SvREFCNT_inc(SHAREDSvPTR(target)); + av_store((AV*) sobj, i - 1, stmp); + SvREFCNT_inc(stmp); CALLER_CONTEXT; SvREFCNT_dec(tmp); } LEAVE_LOCK; void -POP(shared_sv *shared) +POP(SV *obj) CODE: dTHXc; - SV* sv; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + SV* ssv; ENTER_LOCK; SHARED_CONTEXT; - sv = av_pop((AV*)SHAREDSvPTR(shared)); + ssv = av_pop((AV*)sobj); CALLER_CONTEXT; ST(0) = sv_newmortal(); - Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0); - SvREFCNT_dec(sv); + Perl_sharedsv_associate(aTHX_ ST(0), ssv); + SvREFCNT_dec(ssv); LEAVE_LOCK; XSRETURN(1); void -SHIFT(shared_sv *shared) +SHIFT(SV *obj) CODE: dTHXc; - SV* sv; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); + SV* ssv; ENTER_LOCK; SHARED_CONTEXT; - sv = av_shift((AV*)SHAREDSvPTR(shared)); + ssv = av_shift((AV*)sobj); CALLER_CONTEXT; ST(0) = sv_newmortal(); - Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0); - SvREFCNT_dec(sv); + Perl_sharedsv_associate(aTHX_ ST(0), ssv); + SvREFCNT_dec(ssv); LEAVE_LOCK; XSRETURN(1); void -EXTEND(shared_sv *shared, IV count) +EXTEND(SV *obj, IV count) CODE: dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); SHARED_EDIT; - av_extend((AV*)SHAREDSvPTR(shared), count); + av_extend((AV*)sobj, count); SHARED_RELEASE; void -STORESIZE(shared_sv *shared,IV count) +STORESIZE(SV *obj,IV count) CODE: dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); SHARED_EDIT; - av_fill((AV*) SHAREDSvPTR(shared), count); + av_fill((AV*) sobj, count); SHARED_RELEASE; void -EXISTS(shared_sv *shared, SV *index) +EXISTS(SV *obj, SV *index) CODE: dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); bool exists; - if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) { + if (SvTYPE(sobj) == SVt_PVAV) { SHARED_EDIT; - exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index)); + exists = av_exists((AV*) sobj, SvIV(index)); } else { STRLEN len; char *key = SvPV(index,len); SHARED_EDIT; - exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len); + exists = hv_exists((HV*) sobj, key, len); } SHARED_RELEASE; ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no; @@ -1015,16 +1170,17 @@ void -FIRSTKEY(shared_sv *shared) +FIRSTKEY(SV *obj) CODE: dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); char* key = NULL; I32 len = 0; HE* entry; ENTER_LOCK; SHARED_CONTEXT; - hv_iterinit((HV*) SHAREDSvPTR(shared)); - entry = hv_iternext((HV*) SHAREDSvPTR(shared)); + hv_iterinit((HV*) sobj); + entry = hv_iternext((HV*) sobj); if (entry) { key = hv_iterkey(entry,&len); CALLER_CONTEXT; @@ -1037,15 +1193,16 @@ XSRETURN(1); void -NEXTKEY(shared_sv *shared, SV *oldkey) +NEXTKEY(SV *obj, SV *oldkey) CODE: dTHXc; + SV *sobj = S_sharedsv_from_obj(aTHX_ obj); char* key = NULL; I32 len = 0; HE* entry; ENTER_LOCK; SHARED_CONTEXT; - entry = hv_iternext((HV*) SHAREDSvPTR(shared)); + entry = hv_iternext((HV*) sobj); if (entry) { key = hv_iterkey(entry,&len); CALLER_CONTEXT; @@ -1065,12 +1222,12 @@ _id(SV *ref) PROTOTYPE: \[$@%] CODE: - shared_sv *shared; + SV *ssv; ref = SvRV(ref); if(SvROK(ref)) ref = SvRV(ref); - if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){ - ST(0) = sv_2mortal(newSViv(PTR2IV(shared))); + if( (ssv = Perl_sharedsv_find(aTHX_ ref)) ){ + ST(0) = sv_2mortal(newSViv(PTR2IV(ssv))); XSRETURN(1); } XSRETURN_UNDEF; @@ -1080,18 +1237,13 @@ _refcnt(SV *ref) PROTOTYPE: \[$@%] CODE: - shared_sv *shared; + SV *ssv; ref = SvRV(ref); if(SvROK(ref)) ref = SvRV(ref); - if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){ - if (SHAREDSvPTR(shared)) { - ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared)))); + if( (ssv = Perl_sharedsv_find(aTHX_ ref)) ) { + ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv))); XSRETURN(1); - } - else { - Perl_warn(aTHX_ "%" SVf " s=%p has no shared SV",ST(0),shared); - } } else { Perl_warn(aTHX_ "%" SVf " is not shared",ST(0)); @@ -1116,25 +1268,26 @@ lock_enabled(SV *ref) PROTOTYPE: \[$@%] CODE: - shared_sv* shared; + SV *ssv; if(!SvROK(ref)) Perl_croak(aTHX_ "Argument to lock needs to be passed as ref"); ref = SvRV(ref); if(SvROK(ref)) ref = SvRV(ref); - shared = Perl_sharedsv_find(aTHX_ ref); - if(!shared) + ssv = Perl_sharedsv_find(aTHX_ ref); + if(!ssv) croak("lock can only be used on shared values"); - Perl_sharedsv_lock(aTHX_ shared); + Perl_sharedsv_lock(aTHX_ ssv); void cond_wait_enabled(SV *ref_cond, SV *ref_lock = 0) PROTOTYPE: \[$@%];\[$@%] PREINIT: - shared_sv* shared; + SV *ssv; perl_cond* user_condition; int locks; int same = 0; + user_lock *ul; CODE: if (!ref_lock || ref_lock == ref_cond) same = 1; @@ -1144,48 +1297,51 @@ ref_cond = SvRV(ref_cond); if(SvROK(ref_cond)) ref_cond = SvRV(ref_cond); - shared = Perl_sharedsv_find(aTHX_ ref_cond); - if(!shared) + ssv = Perl_sharedsv_find(aTHX_ ref_cond); + if(!ssv) croak("cond_wait can only be used on shared values"); + ul = S_get_userlock(aTHX_ ssv, 1); - user_condition = &shared->user_cond; + user_condition = &ul->user_cond; if (! same) { if (!SvROK(ref_lock)) Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref"); ref_lock = SvRV(ref_lock); if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); - shared = Perl_sharedsv_find(aTHX_ ref_lock); - if (!shared) + ssv = Perl_sharedsv_find(aTHX_ ref_lock); + if (!ssv) croak("cond_wait lock must be a shared value"); + ul = S_get_userlock(aTHX_ ssv, 1); } - if(shared->lock.owner != aTHX) + if(ul->lock.owner != aTHX) croak("You need a lock before you can cond_wait"); /* Stealing the members of the lock object worries me - NI-S */ - MUTEX_LOCK(&shared->lock.mutex); - shared->lock.owner = NULL; - locks = shared->lock.locks; - shared->lock.locks = 0; + MUTEX_LOCK(&ul->lock.mutex); + ul->lock.owner = NULL; + locks = ul->lock.locks; + ul->lock.locks = 0; /* since we are releasing the lock here we need to tell other people that is ok to go ahead and use it */ - COND_SIGNAL(&shared->lock.cond); - COND_WAIT(user_condition, &shared->lock.mutex); - while(shared->lock.owner != NULL) { + COND_SIGNAL(&ul->lock.cond); + COND_WAIT(user_condition, &ul->lock.mutex); + while(ul->lock.owner != NULL) { /* OK -- must reacquire the lock */ - COND_WAIT(&shared->lock.cond, &shared->lock.mutex); + COND_WAIT(&ul->lock.cond, &ul->lock.mutex); } - shared->lock.owner = aTHX; - shared->lock.locks = locks; - MUTEX_UNLOCK(&shared->lock.mutex); + ul->lock.owner = aTHX; + ul->lock.locks = locks; + MUTEX_UNLOCK(&ul->lock.mutex); int cond_timedwait_enabled(SV *ref_cond, double abs, SV *ref_lock = 0) PROTOTYPE: \[$@%]$;\[$@%] PREINIT: - shared_sv* shared; + SV *ssv; perl_cond* user_condition; int locks; int same = 0; + user_lock *ul; CODE: if (!ref_lock || ref_cond == ref_lock) same = 1; @@ -1195,38 +1351,40 @@ ref_cond = SvRV(ref_cond); if(SvROK(ref_cond)) ref_cond = SvRV(ref_cond); - shared = Perl_sharedsv_find(aTHX_ ref_cond); - if(!shared) + ssv = Perl_sharedsv_find(aTHX_ ref_cond); + if(!ssv) croak("cond_timedwait can only be used on shared values"); + ul = S_get_userlock(aTHX_ ssv, 1); - user_condition = &shared->user_cond; + user_condition = &ul->user_cond; if (! same) { if (!SvROK(ref_lock)) Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref"); ref_lock = SvRV(ref_lock); if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); - shared = Perl_sharedsv_find(aTHX_ ref_lock); - if (!shared) + ssv = Perl_sharedsv_find(aTHX_ ref_lock); + if (!ssv) croak("cond_timedwait lock must be a shared value"); + ul = S_get_userlock(aTHX_ ssv, 1); } - if(shared->lock.owner != aTHX) + if(ul->lock.owner != aTHX) croak("You need a lock before you can cond_wait"); - MUTEX_LOCK(&shared->lock.mutex); - shared->lock.owner = NULL; - locks = shared->lock.locks; - shared->lock.locks = 0; + MUTEX_LOCK(&ul->lock.mutex); + ul->lock.owner = NULL; + locks = ul->lock.locks; + ul->lock.locks = 0; /* since we are releasing the lock here we need to tell other people that is ok to go ahead and use it */ - COND_SIGNAL(&shared->lock.cond); - RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &shared->lock.mutex, abs); - while (shared->lock.owner != NULL) { + COND_SIGNAL(&ul->lock.cond); + RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs); + while (ul->lock.owner != NULL) { /* OK -- must reacquire the lock... */ - COND_WAIT(&shared->lock.cond, &shared->lock.mutex); + COND_WAIT(&ul->lock.cond, &ul->lock.mutex); } - shared->lock.owner = aTHX; - shared->lock.locks = locks; - MUTEX_UNLOCK(&shared->lock.mutex); + ul->lock.owner = aTHX; + ul->lock.locks = locks; + MUTEX_UNLOCK(&ul->lock.mutex); if (RETVAL == 0) XSRETURN_UNDEF; @@ -1237,37 +1395,43 @@ cond_signal_enabled(SV *ref) PROTOTYPE: \[$@%] CODE: - shared_sv* shared; + SV *ssv; + user_lock *ul; + if(!SvROK(ref)) Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref"); ref = SvRV(ref); if(SvROK(ref)) ref = SvRV(ref); - shared = Perl_sharedsv_find(aTHX_ ref); - if(!shared) + ssv = Perl_sharedsv_find(aTHX_ ref); + if(!ssv) croak("cond_signal can only be used on shared values"); - if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX) + ul = S_get_userlock(aTHX_ ssv, 1); + if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) Perl_warner(aTHX_ packWARN(WARN_THREADS), "cond_signal() called on unlocked variable"); - COND_SIGNAL(&shared->user_cond); + COND_SIGNAL(&ul->user_cond); void cond_broadcast_enabled(SV *ref) PROTOTYPE: \[$@%] CODE: - shared_sv* shared; + SV *ssv; + user_lock *ul; + if(!SvROK(ref)) Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref"); ref = SvRV(ref); if(SvROK(ref)) ref = SvRV(ref); - shared = Perl_sharedsv_find(aTHX_ ref); - if(!shared) + ssv = Perl_sharedsv_find(aTHX_ ref); + if(!ssv) croak("cond_broadcast can only be used on shared values"); - if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX) + ul = S_get_userlock(aTHX_ ssv, 1); + if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) Perl_warner(aTHX_ packWARN(WARN_THREADS), "cond_broadcast() called on unlocked variable"); - COND_BROADCAST(&shared->user_cond); + COND_BROADCAST(&ul->user_cond); SV* @@ -1276,17 +1440,18 @@ CODE: { HV* stash; - shared_sv* shared; + SV *ssv; if (items == 1) stash = CopSTASH(PL_curcop); else { - SV* ssv = ST(1); + SV* classname = ST(1); STRLEN len; char *ptr; - if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) + if (classname && !SvGMAGICAL(classname) && + !SvAMAGIC(classname) && SvROK(classname)) Perl_croak(aTHX_ "Attempt to bless into a reference"); - ptr = SvPV(ssv,len); + ptr = SvPV(classname,len); if (ckWARN(WARN_MISC) && len == 0) Perl_warner(aTHX_ packWARN(WARN_MISC), "Explicit blessing to '' (assuming package main)"); @@ -1295,14 +1460,14 @@ SvREFCNT_inc(ref); (void)sv_bless(ref, stash); RETVAL = ref; - shared = Perl_sharedsv_find(aTHX_ ref); - if(shared) { + ssv = Perl_sharedsv_find(aTHX_ ref); + if(ssv) { dTHXc; ENTER_LOCK; SHARED_CONTEXT; { SV* fake_stash = newSVpv(HvNAME_get(stash),0); - (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash); + (void)sv_bless(ssv,(HV*)fake_stash); } CALLER_CONTEXT; LEAVE_LOCK; @@ -1319,6 +1484,3 @@ Perl_sharedsv_init(aTHX); #endif /* USE_ITHREADS */ } - - - Only in perl-26748/ext/threads/shared: typemap ```
p5pRT commented 18 years ago

From @nwc10

On Mon\, Jan 09\, 2006 at 01​:01​:42PM -0800\, Guest via RT wrote​:

My hope is that this will assist Nicholas Clark in getting the above patches into the 5.8.8 release.

As it doesn't change anything outside of the ext/threads/shared directory then it seems that an alternative plan would be to make the module dual life and upload this version to CPAN directly.

I'm loathe to put this code in maint\, as it's not yet proven to be stable. Having it on CPAN gives people the option to use it\, rather than forcing it on their existing installations when they upgrade.

Nicholas Clark

p5pRT commented 18 years ago

From @iabyn

On Tue\, Jan 10\, 2006 at 10​:14​:29AM +0000\, Nicholas Clark wrote​:

On Mon\, Jan 09\, 2006 at 01​:01​:42PM -0800\, Guest via RT wrote​:

My hope is that this will assist Nicholas Clark in getting the above patches into the 5.8.8 release. [snip] I'm loathe to put this code in maint\, as it's not yet proven to be stable.

Yes\, since its mainly an efficiency improvemnt rather than bugfix\, and since it involved a fairly major rewrite of shared.xs\, I don't think it's suitable for maint.

-- To collect all the latest movies\, simply place an unprotected ftp server on the Internet\, and wait for the disk to fill....

p5pRT commented 18 years ago

From @nwc10

On Tue\, Jan 10\, 2006 at 12​:36​:00PM +0000\, Dave Mitchell wrote​:

On Tue\, Jan 10\, 2006 at 10​:14​:29AM +0000\, Nicholas Clark wrote​:

On Mon\, Jan 09\, 2006 at 01​:01​:42PM -0800\, Guest via RT wrote​:

My hope is that this will assist Nicholas Clark in getting the above patches into the 5.8.8 release. [snip] I'm loathe to put this code in maint\, as it's not yet proven to be stable.

Yes\, since its mainly an efficiency improvemnt rather than bugfix\, and since it involved a fairly major rewrite of shared.xs\, I don't think it's suitable for maint.

I actually don't mind efficiency improvements.

It's the rewrite part that makes me cautious. If there's a development release (5.9.3) and then no-one reports any bugs or finds any other need to change the code for some months\, then it would appear that it's stable. (Plus I'd look carefully at it to see if I could spot any problems)

But it takes time for "time passes" to have happened.

Nicholas Clark

p5pRT commented 18 years ago

From guest@guest.guest.xxxxxxxx

On Mon\, Jan 09\, 2006 at 01​:01​:42PM -0800\, Guest via RT wrote​:

My hope is that this will assist Nicholas Clark in getting the above patches into the 5.8.8 release.

Nicholas Clark via RT replied​:

As it doesn't change anything outside of the ext/threads/shared directory then it seems that an alternative plan would be to make the module dual life and upload this version to CPAN directly.

If everyone else is too busy with other things\, I could try to do the initial work of creating the module for upload to PAUSE. However\, I'm obviously not familiar enough with the code to be the maintainer\, and thus should not be the one to do the actual upload.

Just let me know. Thanks.

Jerry D. Hedden jdhedden AT cpan DOT org

p5pRT commented 18 years ago

From @demerphq

On 1/10/06\, Nicholas Clark \nick@&#8203;ccl4\.org wrote​:

On Tue\, Jan 10\, 2006 at 12​:36​:00PM +0000\, Dave Mitchell wrote​:

On Tue\, Jan 10\, 2006 at 10​:14​:29AM +0000\, Nicholas Clark wrote​:

On Mon\, Jan 09\, 2006 at 01​:01​:42PM -0800\, Guest via RT wrote​:

My hope is that this will assist Nicholas Clark in getting the above patches into the 5.8.8 release. [snip] I'm loathe to put this code in maint\, as it's not yet proven to be stable.

Yes\, since its mainly an efficiency improvemnt rather than bugfix\, and since it involved a fairly major rewrite of shared.xs\, I don't think it's suitable for maint.

I actually don't mind efficiency improvements.

It's the rewrite part that makes me cautious. If there's a development release (5.9.3) and then no-one reports any bugs or finds any other need to change the code for some months\, then it would appear that it's stable. (Plus I'd look carefully at it to see if I could spot any problems)

But it takes time for "time passes" to have happened.

Does that mean that there is a chance getting the trie optimisation into maint?

I seem to recall that Yitzchak put together patch at one time...

yves

-- perl -Mre=debug -e "/just|another|perl|hacker/"

p5pRT commented 18 years ago

From @iabyn

On Sun\, Jan 08\, 2006 at 11​:02​:55AM +0100\, Tels wrote​:

On Sat\, Jan 07\, 2006 at 03​:25​:40AM +0000\, Dave Mitchell wrote​:

This also makes thing go faster​: the following code​:

our @&#8203;a : shared;
for \(1\.\.10\_000\_000\) \{
    $a\[$\_ % 10\_000\]\+\+;
\}

which I made go 13% faster yesterday with change #26684\, is now a further 7% faster with this new change\, for a cummulative speedup of 20%.

You are my hero! (This somehow suggests\, that apart from being buggy\, threads were slow in Perl. I know why I avoid them like the plague :)

Er\, not really. Threads are slow to start up\, and use lots of memory\, but once they're running\, they're as fast as normal code. The only exception being that access to *shared* variables is slow\, roughly comparable to tied variable access​:

consider the basic loop from above (all timings using -O builds)​:

  for (1..10_000_000) {   $a[$_ % 10_000]++;   }

This takes 3.8/4.0s for a plain array on unthreaded/threaded builds;

make @​a tied and the loop takes 47.9s (12 times slower)​:

  use Tie​::Array;   tie @​a\, 'Tie​::StdArray';

make @​a shared instead and the loop takes 48.2s; or 27.4s(*) after my recent patching​:

  use threads;   use threads​::shared;   our @​a : shared;

But any decent multi-threaded code should be making sparse use of shared variables anyway\, as regardless of their implementation they will become a bottleneck between threads. On my 4 CPU x86_64 system\, running that loop on several threads never saturated more than 2 CPUs\, since most threads were waiting on locks to get at the shared variable.

Dave

(*) yes\, that's a 43% speedup\, not 20/21%. I got my sums wrong :-)

 

-- "I do not resent critisism\, even when\, for the sake of emphasis\, it parts for the time with reality".   -- Winston Churchill\, House of Commons\, 22nd Jan 1941.

p5pRT commented 18 years ago

From guest@guest.guest.xxxxxxxx

All righty then. It think I've got threads​::shared all ready for CPAN!

I've extracted threads​::shared from the Perl distribution. Bumped up the version to 0.94. Created MANIFEST and Changes files. Cleaned up the Makefile.PL. Prettied up the code a tad. Added ppport.h. Got it to compile. Cleaned up the tests. Added some new tests for the bug fixes that started all this. Tested it with the latest 5.8 maint under Cygwin. Tested it with 5.8.0 through 5.9.2 under Solaris. Added some missing macros that compiling under released versions of Perl   turned up. Removed 'bug' about 'bless' on shared refs from the POD. (That works now!)

Now then\, who is going to be the official maintainer of this so I can hand it off for final inspecition and uploading to CPAN? Dave Mitchell?

Jerry D. Hedden jdhedden AT cpan DOT org

p5pRT commented 18 years ago

From @iabyn

On Tue\, Jan 10\, 2006 at 10​:04​:23AM -0800\, Guest via RT wrote​:

Now then\, who is going to be the official maintainer of this so I can hand it off for final inspecition and uploading to CPAN? Dave Mitchell?

Note that I've never uploaded anything to CPAN\, and don't\, at this moment in time\, want to get involved in learning.

-- There's a traditional definition of a shyster​: a lawyer who\, when the law is against him\, pounds on the facts; when the facts are against him\, pounds on the law; and when both the facts and the law are against him\, pounds on the table.   -- Eben Moglen referring to SCO

p5pRT commented 18 years ago

From @nwc10

On Tue\, Jan 10\, 2006 at 08​:30​:29PM +0000\, Dave Mitchell wrote​:

On Tue\, Jan 10\, 2006 at 10​:04​:23AM -0800\, Guest via RT wrote​:

Now then\, who is going to be the official maintainer of this so I can hand it off for final inspecition and uploading to CPAN? Dave Mitchell?

Note that I've never uploaded anything to CPAN\, and don't\, at this moment in time\, want to get involved in learning.

I could\, but the two downsides are

1​: threads don't represent a personal itch to scratch 2​: I'd need to write more Acme​:: module to maintain balance. In fact\, I may   already be out of balance

I'm not actually confident that anyone on perl5-porters actively contributing patches is using threads that much. So I'm having trouble coming up with a shortlist of "volunteers"

Nicholas Clark

p5pRT commented 18 years ago

From @nwc10

On Tue\, Jan 10\, 2006 at 10​:04​:23AM -0800\, Guest via RT wrote​:

Bumped up the version to 0.94.

Tested it with the latest 5.8 maint under Cygwin. Tested it with 5.8.0 through 5.9.2 under Solaris.

Thanks. That's good to know. I'm rebuilding my bank of perls on FreeBSD to test with.

Could the version be (at least) 0.95 please? There are a couple of documentation tweaks in 5.8.8-to-be that mean that 5.8.8 needs a different version from 5.8.7\, and 5.8.7 was 0.93

Having the higher version as the stand alone threads​::shared on CPAN means that it becomes easy for anyone to upgrade using the CPAN shell.

Is your tarball anywhere online to collect?

Nicholas Clark

p5pRT commented 18 years ago

From @ysth

On Tue\, Jan 10\, 2006 at 08​:33​:36PM +0000\, Nicholas Clark wrote​:

On Tue\, Jan 10\, 2006 at 08​:30​:29PM +0000\, Dave Mitchell wrote​:

On Tue\, Jan 10\, 2006 at 10​:04​:23AM -0800\, Guest via RT wrote​:

Now then\, who is going to be the official maintainer of this so I can hand it off for final inspecition and uploading to CPAN? Dave Mitchell?

Note that I've never uploaded anything to CPAN\, and don't\, at this moment in time\, want to get involved in learning.

I could\, but the two downsides are

1​: threads don't represent a personal itch to scratch 2​: I'd need to write more Acme​:: module to maintain balance. In fact\, I may already be out of balance

I'm not actually confident that anyone on perl5-porters actively contributing patches is using threads that much. So I'm having trouble coming up with a shortlist of "volunteers"

I use threads a little and will maintain the CPAN version if no one else volunteers.

p5pRT commented 18 years ago

From @jdhedden

Nicholas Clark via RT wrote​:

Could the version be (at least) 0.95 please?

I'll make it 0.95.

Is your tarball anywhere online to collect?

No. It's only 52K\, so I can email it to whoever wants it. Just email me directly at​: jdhedden AT cpan DOT org

p5pRT commented 18 years ago

From @nwc10

On Tue\, Jan 10\, 2006 at 02​:56​:49PM +0100\, demerphq wrote​:

On 1/10/06\, Nicholas Clark \nick@&#8203;ccl4\.org wrote​:

On Tue\, Jan 10\, 2006 at 12​:36​:00PM +0000\, Dave Mitchell wrote​:

On Tue\, Jan 10\, 2006 at 10​:14​:29AM +0000\, Nicholas Clark wrote​:

On Mon\, Jan 09\, 2006 at 01​:01​:42PM -0800\, Guest via RT wrote​:

My hope is that this will assist Nicholas Clark in getting the above patches into the 5.8.8 release. [snip] I'm loathe to put this code in maint\, as it's not yet proven to be stable.

Yes\, since its mainly an efficiency improvemnt rather than bugfix\, and since it involved a fairly major rewrite of shared.xs\, I don't think it's suitable for maint.

I actually don't mind efficiency improvements.

It's the rewrite part that makes me cautious. If there's a development release (5.9.3) and then no-one reports any bugs or finds any other need to change the code for some months\, then it would appear that it's stable. (Plus I'd look carefully at it to see if I could spot any problems)

But it takes time for "time passes" to have happened.

Does that mean that there is a chance getting the trie optimisation into maint?

Well\, when it was added to blead I'd assumed "no\, this isn't viable for maint" but I've looked at the changes to regcomp.h\, regcomp.c and regexec.c and I can't see any externally visible structures or non-static functions that have changed. So I can't spot any fundamental binary compatibility reason why not. But the idea of putting it in to a maint 5.8 at this stage in 5.8's life makes me nervy. I'd be less nervy if there were a pragma that could disable parts the regexp optimiser\, because that way if code turned out to discover latent bugs in the trie optimisation\, then that code could be modified to disable it\, and still work.

However\, there are quite a few things I still want to think about to try to get in to 5.8.9 which fix bugs\, as well as the code cleanups in the upgrade/ dup routines and those involved with locating mathoms. I'd need to get these bumped off first.

Realistically I think it may be faster to get it in maint by making 5.10 maint. There's not a huge amount left under /Needed for a 5\.9.\d release/

I seem to recall that Yitzchak put together patch at one time...

I don't remember this. But my memory isn't perfect.

Nicholas Clark

p5pRT commented 18 years ago

From @demerphq

On 1/12/06\, Nicholas Clark \nick@&#8203;ccl4\.org wrote​:

On Tue\, Jan 10\, 2006 at 02​:56​:49PM +0100\, demerphq wrote​:

On 1/10/06\, Nicholas Clark \nick@&#8203;ccl4\.org wrote​: ..

I actually don't mind efficiency improvements. ... Does that mean that there is a chance getting the trie optimisation into maint?

Well\, when it was added to blead I'd assumed "no\, this isn't viable for maint" but I've looked at the changes to regcomp.h\, regcomp.c and regexec.c and I can't see any externally visible structures or non-static functions that have changed. So I can't spot any fundamental binary compatibility reason why not. But the idea of putting it in to a maint 5.8 at this stage in 5.8's life makes me nervy. I'd be less nervy if there were a pragma that could disable parts the regexp optimiser\, because that way if code turned out to discover latent bugs in the trie optimisation\, then that code could be modified to disable it\, and still work.

BEGIN { $^REG_TRIE_MAXBUF=0 }

Will disable the trie functionality if its done before the regexp is compiled.

Having said that I've been tinkering with making $^REG_TRIE_MAXBUF and $^REG_DEBUG_FLAGS go away to be replaced by lexically scoped pragmas. I havent got far with it tho\, due to lack of familiarity and an easily distractable mind.

However\, there are quite a few things I still want to think about to try to get in to 5.8.9 which fix bugs\, as well as the code cleanups in the upgrade/ dup routines and those involved with locating mathoms. I'd need to get these bumped off first.

Realistically I think it may be faster to get it in maint by making 5.10 maint. There's not a huge amount left under /Needed for a 5\.9.\d release/

Ok\, thats fair enough. Especially as it would be much nicer with lexically scoped control as you say.

I seem to recall that Yitzchak put together patch at one time...

I don't remember this. But my memory isn't perfect.

Nope\, in this case your memory is fine\, its mine that was confuzzled. Yitzchak suggested to me offline that it would be cool to do as a module\, but thats certainly beyond me right now.

Cheers\, yves -- perl -Mre=debug -e "/just|another|perl|hacker/"

p5pRT commented 18 years ago

From @demerphq

On 1/12/06\, demerphq \demerphq@&#8203;gmail\.com wrote​:

BEGIN { $^REG_TRIE_MAXBUF=0 }

...

Having said that I've been tinkering with making $^REG_TRIE_MAXBUF and $^REG_DEBUG_FLAGS go away to be replaced by lexically scoped pragmas. I havent got far with it tho\, due to lack of familiarity and an easily distractable mind.

Whoops\, i meant $^RE_TRIE_MAXBUF and $^RE_DEBUG_FLAGS.

Yves

-- perl -Mre=debug -e "/just|another|perl|hacker/"

p5pRT commented 18 years ago

From @ysth

On Tue\, Jan 10\, 2006 at 10​:41​:48PM +0000\, Nicholas Clark wrote​:

On Tue\, Jan 10\, 2006 at 10​:04​:23AM -0800\, Guest via RT wrote​:

Bumped up the version to 0.94.

Tested it with the latest 5.8 maint under Cygwin. Tested it with 5.8.0 through 5.9.2 under Solaris.

Thanks. That's good to know. I'm rebuilding my bank of perls on FreeBSD to test with.

Could the version be (at least) 0.95 please? There are a couple of documentation tweaks in 5.8.8-to-be that mean that 5.8.8 needs a different version from 5.8.7\, and 5.8.7 was 0.93

Having the higher version as the stand alone threads​::shared on CPAN means that it becomes easy for anyone to upgrade using the CPAN shell.

Is your tarball anywhere online to collect?

Nicholas\, were you volunteering to maintain it on CPAN?

If not\, I'll start working on it in the next week.

p5pRT commented 18 years ago

From @nwc10

Opps. Forgot to follow this up yesterday.

On Thu\, Jan 12\, 2006 at 12​:28​:58PM -0800\, Yitzchak Scott-Thoennes wrote​:

On Tue\, Jan 10\, 2006 at 10​:41​:48PM +0000\, Nicholas Clark wrote​:

On Tue\, Jan 10\, 2006 at 10​:04​:23AM -0800\, Guest via RT wrote​:

Bumped up the version to 0.94.

Tested it with the latest 5.8 maint under Cygwin. Tested it with 5.8.0 through 5.9.2 under Solaris.

Thanks. That's good to know. I'm rebuilding my bank of perls on FreeBSD to test with.

Could the version be (at least) 0.95 please? There are a couple of documentation tweaks in 5.8.8-to-be that mean that 5.8.8 needs a different version from 5.8.7\, and 5.8.7 was 0.93

Having the higher version as the stand alone threads​::shared on CPAN means that it becomes easy for anyone to upgrade using the CPAN shell.

Is your tarball anywhere online to collect?

Nicholas\, were you volunteering to maintain it on CPAN?

Well\, only in that I'd like the code out and available\, but not yet forced on everyone who upgrades to 5.8.8\, and I wasn't sure that anyone else would.

If not\, I'll start working on it in the next week.

I'd be very happy if you were able to\, as it reduces by 1 the number of things I need to do.

It passed all tests on 5.8.1-5.8.7 on FreeBSD (not got 5.8.0 built yet)

ABERGMAN is the current owner of the module as recorded by PAUSE. You'd need to agree with him to become co-maintainer (or somesuch) otherwise the indexer will not index anything you upload.

Nicholas Clark

p5pRT commented 18 years ago

From guest@guest.guest.xxxxxxxx

[nicholas - Thu Jan 12 12​:37​:42 2006]​: ABERGMAN is the current owner of [threads​::shared] as recorded by PAUSE. You'd need to agree with him to become co-maintainer.

FYI\, I have done this\, and uploaded threads-shared-0.95 to PAUSE a few days ago.

Jerry D. Hedden \<jhedden [at] cpan [dot] org>

p5pRT commented 18 years ago

@iabyn - Status changed from 'open' to 'resolved'