#endif
};
+
+/* Support for dual-valued variables */
+#ifdef SVf_IVisUV
+# define DUALVAR_FLAGS(sv) \
+ ((SvPOK(sv)) \
+ ? ((SvNOK(sv) || SvNOKp(sv)) ? SVf_NOK \
+ : ((SvIsUV(sv)) ? (SVf_IOK | SVf_IVisUV) \
+ : ((SvIOK(sv) || SvIOKp(sv)) ? SVf_IOK : 0))) \
+ : 0)
+#else
+# define DUALVAR_FLAGS(sv) \
+ ((SvPOK(sv)) \
+ ? ((SvNOK(sv) || SvNOKp(sv)) ? SVf_NOK \
+ : ((SvIOK(sv) || SvIOKp(sv)) ? SVf_IOK : 0)) \
+ : 0)
+#endif
+
+
/*
* Access to shared things is heavily based on MAGIC
* - in mg.h/mg.c/sv.c sense
/* 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);
-}
+#define SHAREDSV_FROM_OBJ(sv) ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL)
/* Return the user_lock structure (if any) associated with a shared SV.
}
/* Just for tidyness of API also handle tie objects */
if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
- return (S_sharedsv_from_obj(aTHX_ sv));
+ return (SHAREDSV_FROM_OBJ(sv));
}
return (NULL);
}
sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
{
dTHXc;
- SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
+ SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
SV** svp = NULL;
ENTER_LOCK;
sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
{
dTHXc;
- SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
+ SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
SV **svp;
- U32 dualvar_flags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK);
+ U32 dualvar_flags = DUALVAR_FLAGS(sv);
+
/* 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
CALLER_CONTEXT;
Perl_sharedsv_associate(aTHX_ sv, *svp);
sharedsv_scalar_store(aTHX_ sv, *svp);
- /* Propagate dualvar flags */
- if (SvPOK(*svp)) {
- SvFLAGS(*svp) |= dualvar_flags;
- }
+ SvFLAGS(*svp) |= dualvar_flags;
LEAVE_LOCK;
return (0);
}
{
dTHXc;
MAGIC *shmg;
- SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
+ SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj);
/* Object may not exist during global destruction */
if (! saggregate) {
sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
{
PERL_UNUSED_ARG(param);
- SvREFCNT_inc_void(S_sharedsv_from_obj(aTHX_ mg->mg_obj));
+ SvREFCNT_inc_void(SHAREDSV_FROM_OBJ(mg->mg_obj));
assert(mg->mg_flags & MGf_DUP);
return (0);
}
sv = SvRV(sv);
ssv = Perl_sharedsv_find(aTHX_ sv);
if (!ssv)
- croak("lock can only be used on shared values");
+ croak("lock can only be used on shared values");
Perl_sharedsv_lock(aTHX_ ssv);
}
us = (PL_sharedsv_lock.owner == aTHX);
MUTEX_UNLOCK(&PL_sharedsv_lock.mutex);
if (us)
- return; /* try again later */
+ return; /* try again later */
prev_signal_hook(aTHX);
}
#endif
#endif
#ifdef PL_signalhook
if (!prev_signal_hook) {
- prev_signal_hook = PL_signalhook;
- PL_signalhook = &S_shared_signal_hook;
+ prev_signal_hook = PL_signalhook;
+ PL_signalhook = &S_shared_signal_hook;
}
#endif
}
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));
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
+ int ii;
+ for (ii = 1; ii < items; ii++) {
+ SV* tmp = newSVsv(ST(ii));
SV *stmp;
+ U32 dualvar_flags = DUALVAR_FLAGS(tmp);
ENTER_LOCK;
stmp = S_sharedsv_new_shared(aTHX_ tmp);
sharedsv_scalar_store(aTHX_ tmp, stmp);
+ SvFLAGS(stmp) |= dualvar_flags;
SHARED_CONTEXT;
av_push((AV*) sobj, stmp);
SvREFCNT_inc_void(stmp);
UNSHIFT(SV *obj, ...)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
- int i;
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
+ int ii;
ENTER_LOCK;
SHARED_CONTEXT;
av_unshift((AV*)sobj, items - 1);
CALLER_CONTEXT;
- for (i = 1; i < items; i++) {
- SV *tmp = newSVsv(ST(i));
+ for (ii = 1; ii < items; ii++) {
+ SV *tmp = newSVsv(ST(ii));
+ U32 dualvar_flags = DUALVAR_FLAGS(tmp);
SV *stmp = S_sharedsv_new_shared(aTHX_ tmp);
sharedsv_scalar_store(aTHX_ tmp, stmp);
SHARED_CONTEXT;
- av_store((AV*) sobj, i - 1, stmp);
+ SvFLAGS(stmp) |= dualvar_flags;
+ av_store((AV*) sobj, ii - 1, stmp);
SvREFCNT_inc_void(stmp);
CALLER_CONTEXT;
SvREFCNT_dec(tmp);
POP(SV *obj)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
SV* ssv;
ENTER_LOCK;
SHARED_CONTEXT;
SHIFT(SV *obj)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
SV* ssv;
ENTER_LOCK;
SHARED_CONTEXT;
EXTEND(SV *obj, IV count)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
SHARED_EDIT;
av_extend((AV*)sobj, count);
SHARED_RELEASE;
STORESIZE(SV *obj,IV count)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
SHARED_EDIT;
av_fill((AV*) sobj, count);
SHARED_RELEASE;
EXISTS(SV *obj, SV *index)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
bool exists;
if (SvTYPE(sobj) == SVt_PVAV) {
SHARED_EDIT;
FIRSTKEY(SV *obj)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
char* key = NULL;
I32 len = 0;
HE* entry;
NEXTKEY(SV *obj, SV *oldkey)
CODE:
dTHXc;
- SV *sobj = S_sharedsv_from_obj(aTHX_ obj);
+ SV *sobj = SHAREDSV_FROM_OBJ(obj);
char* key = NULL;
I32 len = 0;
HE* entry;
void
-bless(SV* myref, ...);
+bless(SV* myref, ...)
PROTOTYPE: $;$
PREINIT:
HV* stash;
use ExtUtils::testlib;
+BEGIN {
+ $| = 1;
+ print("1..226\n"); ### Number of tests that will be run ###
+}
+
+use threads;
+use threads::shared;
+use Scalar::Util qw(dualvar);
+
+my $TEST = 1;
+
sub ok {
- my ($id, $ok, $name) = @_;
+ my ($ok, $name) = @_;
# You have to do it this way or VMS will get confused.
if ($ok) {
- print("ok $id - $name\n");
- }
- else {
- print("not ok $id - $name\n");
- printf("# Failed test at line %d\n", (caller)[2]);
+ print("ok $TEST - $name\n");
+ } else {
+ print("not ok $TEST - $name\n");
+ printf("# Failed test at line %d\n", (caller(1))[2]);
}
- return ($ok);
+ $TEST++;
}
-BEGIN {
- $| = 1;
- print("1..19\n"); ### Number of tests that will be run ###
+sub ok_iv
+{
+ my ($var, $iv) = @_;
+ ok($var == $iv, 'IV number preserved');
+ ok($var eq $iv, 'String preserved');
}
-use Scalar::Util qw(dualvar);
-
-use threads;
-use threads::shared;
+sub ok_nv
+{
+ my ($var, $nv) = @_;
+ ok($var == $nv, 'NV number preserved');
+ ok($var eq $nv, 'String preserved');
+}
-ok(1, 1, 'Loaded');
+sub ok_uv
+{
+ my ($var, $uv) = @_;
+ ok($var == $uv, 'UV number preserved');
+ ok($var > 0, 'UV number preserved');
+ ok($var eq $uv, 'String preserved');
+}
### Start of Testing ###
-my $dv = dualvar(42, 'Fourty-Two');
-my $pi = dualvar(3.14, 'PI');
+my $iv = dualvar(42, 'Fourty-Two');
+my $nv = dualvar(3.14, 'PI');
+my $bits = ($Config{'use64bitint'}) ? 63 : 31;
+my $uv = dualvar(1<<$bits, 'Large unsigned int');
+
+print("# Shared scalar assignment using shared_clone()\n");
+
+my $siv :shared = shared_clone($iv);
+my $snv :shared = shared_clone($nv);
+my $suv :shared = shared_clone($uv);
+
+ok_iv($siv, $iv);
+ok_nv($snv, $nv);
+ok_uv($suv, $uv);
+
+{
+ print("# Shared array initialization\n");
+
+ my @ary :shared = ($iv, $nv, $uv);
+
+ ok_iv($ary[0], $iv);
+ ok_nv($ary[1], $nv);
+ ok_uv($ary[2], $uv);
+}
+
+{
+ print("# Shared array list assignment\n");
+
+ my @ary :shared;
+ @ary = ($iv, $nv, $uv);
+
+ ok_iv($ary[0], $iv);
+ ok_nv($ary[1], $nv);
+ ok_uv($ary[2], $uv);
+}
+
+{
+ print("# Shared array element assignment\n");
+
+ my @ary :shared;
+ $ary[0] = $iv;
+ $ary[1] = $nv;
+ $ary[2] = $uv;
+
+ ok_iv($ary[0], $iv);
+ ok_nv($ary[1], $nv);
+ ok_uv($ary[2], $uv);
+}
+
+{
+ print("# Shared array initialization - shared scalars\n");
+
+ my @ary :shared = ($siv, $snv, $suv);
+
+ ok_iv($ary[0], $iv);
+ ok_nv($ary[1], $nv);
+ ok_uv($ary[2], $uv);
+}
+
+{
+ print("# Shared array list assignment - shared scalars\n");
+
+ my @ary :shared;
+ @ary = ($siv, $snv, $suv);
+
+ ok_iv($ary[0], $iv);
+ ok_nv($ary[1], $nv);
+ ok_uv($ary[2], $uv);
+}
+
+{
+ print("# Shared array element assignment - shared scalars\n");
+
+ my @ary :shared;
+ $ary[0] = $siv;
+ $ary[1] = $snv;
+ $ary[2] = $suv;
+
+ ok_iv($ary[0], $iv);
+ ok_nv($ary[1], $nv);
+ ok_uv($ary[2], $uv);
+}
+
+{
+ print("# Shared hash initialization\n");
+
+ my %hsh :shared = (
+ 'iv' => $iv,
+ 'nv' => $nv,
+ 'uv' => $uv,
+ );
+
+ ok_iv($hsh{'iv'}, $iv);
+ ok_nv($hsh{'nv'}, $nv);
+ ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+ print("# Shared hash assignment\n");
+
+ my %hsh :shared;
+ %hsh = (
+ 'iv' => $iv,
+ 'nv' => $nv,
+ 'uv' => $uv,
+ );
+
+ ok_iv($hsh{'iv'}, $iv);
+ ok_nv($hsh{'nv'}, $nv);
+ ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+ print("# Shared hash element assignment\n");
+
+ my %hsh :shared;
+ $hsh{'iv'} = $iv;
+ $hsh{'nv'} = $nv;
+ $hsh{'uv'} = $uv;
+
+ ok_iv($hsh{'iv'}, $iv);
+ ok_nv($hsh{'nv'}, $nv);
+ ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+ print("# Shared hash initialization - shared scalars\n");
+
+ my %hsh :shared = (
+ 'iv' => $siv,
+ 'nv' => $snv,
+ 'uv' => $suv,
+ );
+
+ ok_iv($hsh{'iv'}, $iv);
+ ok_nv($hsh{'nv'}, $nv);
+ ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+ print("# Shared hash assignment - shared scalars\n");
+
+ my %hsh :shared;
+ %hsh = (
+ 'iv' => $siv,
+ 'nv' => $snv,
+ 'uv' => $suv,
+ );
+
+ ok_iv($hsh{'iv'}, $iv);
+ ok_nv($hsh{'nv'}, $nv);
+ ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+ print("# Shared hash element assignment - shared scalars\n");
+
+ my %hsh :shared;
+ $hsh{'iv'} = $siv;
+ $hsh{'nv'} = $snv;
+ $hsh{'uv'} = $suv;
+
+ ok_iv($hsh{'iv'}, $iv);
+ ok_nv($hsh{'nv'}, $nv);
+ ok_uv($hsh{'uv'}, $uv);
+}
+
+{
+ print("# Shared array push\n");
+
+ my @ary :shared;
+ push(@ary, $iv, $nv, $uv);
+
+ ok_iv($ary[0], $iv);
+ ok_nv($ary[1], $nv);
+ ok_uv($ary[2], $uv);
+
+ print("# Shared array pop\n");
+
+ my $xuv = pop(@ary);
+ my $xnv = pop(@ary);
+ my $xiv = pop(@ary);
+
+ ok_iv($xiv, $iv);
+ ok_nv($xnv, $nv);
+ ok_uv($xuv, $uv);
+
+ print("# Shared array unshift\n");
+
+ unshift(@ary, $iv, $nv, $uv);
+
+ ok_iv($ary[0], $iv);
+ ok_nv($ary[1], $nv);
+ ok_uv($ary[2], $uv);
+
+ print("# Shared array shift\n");
+
+ $xiv = shift(@ary);
+ $xnv = shift(@ary);
+ $xuv = shift(@ary);
+
+ ok_iv($xiv, $iv);
+ ok_nv($xnv, $nv);
+ ok_uv($xuv, $uv);
+}
+
+{
+ print("# Shared array push - shared scalars\n");
+
+ my @ary :shared;
+ push(@ary, $siv, $snv, $suv);
+
+ ok_iv($ary[0], $iv);
+ ok_nv($ary[1], $nv);
+ ok_uv($ary[2], $uv);
+
+ print("# Shared array pop - shared scalars\n");
+
+ my $xuv = pop(@ary);
+ my $xnv = pop(@ary);
+ my $xiv = pop(@ary);
+
+ ok_iv($xiv, $iv);
+ ok_nv($xnv, $nv);
+ ok_uv($xuv, $uv);
+
+ print("# Shared array unshift - shared scalars\n");
+
+ unshift(@ary, $siv, $snv, $suv);
+
+ ok_iv($ary[0], $iv);
+ ok_nv($ary[1], $nv);
+ ok_uv($ary[2], $uv);
+
+ print("# Shared array shift - shared scalars\n");
+
+ $xiv = shift(@ary);
+ $xnv = shift(@ary);
+ $xuv = shift(@ary);
+
+ ok_iv($xiv, $iv);
+ ok_nv($xnv, $nv);
+ ok_uv($xuv, $uv);
+}
+
+{
+ print("# Shared hash delete\n");
-my @a :shared;
+ my %hsh :shared = (
+ 'iv' => $iv,
+ 'nv' => $nv,
+ 'uv' => $uv,
+ );
-# Individual assignment
-# Verify that dualvar preserved during individual element assignment
-$a[0] = $dv;
-$a[1] = $pi;
+ ok_iv(delete($hsh{'iv'}), $iv);
+ ok_nv(delete($hsh{'nv'}), $nv);
+ ok_uv(delete($hsh{'uv'}), $uv);
+}
+
+{
+ print("# Shared hash delete - shared scalars\n");
+
+ my %hsh :shared = (
+ 'iv' => $siv,
+ 'nv' => $snv,
+ 'uv' => $suv,
+ );
+
+ ok_iv(delete($hsh{'iv'}), $iv);
+ ok_nv(delete($hsh{'nv'}), $nv);
+ ok_uv(delete($hsh{'uv'}), $uv);
+}
+
+{
+ print("# Shared array copy to non-shared array\n");
+
+ my @ary :shared = ($iv, $nv, $uv);
+ my @nsa = @ary;
+
+ ok_iv($nsa[0], $iv);
+ ok_nv($nsa[1], $nv);
+ ok_uv($nsa[2], $uv);
+
+ print("# Shared array copy using shared_clone()\n");
+
+ my $copy :shared = shared_clone(\@nsa);
+
+ ok_iv($$copy[0], $iv);
+ ok_nv($$copy[1], $nv);
+ ok_uv($$copy[2], $uv);
+}
+
+{
+ print("# Shared array copy to non-shared array - shared scalars\n");
+
+ my @ary :shared = ($siv, $snv, $suv);
+ my @nsa = @ary;
+
+ ok_iv($nsa[0], $iv);
+ ok_nv($nsa[1], $nv);
+ ok_uv($nsa[2], $uv);
+
+ print("# Shared array copy using shared_clone()\n");
-ok(2, $a[0] == 42, 'IV number preserved');
-ok(3, $a[0] eq 'Fourty-Two', 'string preserved');
-ok(4, $a[1] == 3.14, 'NV number preserved');
-ok(5, $a[1] eq 'PI', 'string preserved');
+ my $copy :shared = shared_clone(\@nsa);
+
+ ok_iv($$copy[0], $iv);
+ ok_nv($$copy[1], $nv);
+ ok_uv($$copy[2], $uv);
+}
+
+{
+ print("# Shared hash copy to non-shared hash\n");
+
+ my %hsh :shared = (
+ 'iv' => $iv,
+ 'nv' => $nv,
+ 'uv' => $uv,
+ );
+ my %nsh = %hsh;
+
+ ok_iv($nsh{'iv'}, $iv);
+ ok_nv($nsh{'nv'}, $nv);
+ ok_uv($nsh{'uv'}, $uv);
+
+ print("# Shared hash copy using shared_clone()\n");
+
+ my $copy :shared = shared_clone(\%nsh);
+
+ ok_iv($$copy{'iv'}, $iv);
+ ok_nv($$copy{'nv'}, $nv);
+ ok_uv($$copy{'uv'}, $uv);
+}
+
+{
+ print("# Shared hash copy to non-shared hash - shared scalars\n");
+
+ my %hsh :shared = (
+ 'iv' => $siv,
+ 'nv' => $snv,
+ 'uv' => $suv,
+ );
+ my %nsh = %hsh;
+
+ ok_iv($nsh{'iv'}, $iv);
+ ok_nv($nsh{'nv'}, $nv);
+ ok_uv($nsh{'uv'}, $uv);
+
+ print("# Shared hash copy using shared_clone()\n");
+
+ my $copy :shared = shared_clone(\%nsh);
+
+ ok_iv($$copy{'iv'}, $iv);
+ ok_nv($$copy{'nv'}, $nv);
+ ok_uv($$copy{'uv'}, $uv);
+}
-#-- List initializer
-# Verify that dualvar preserved during initialization
-my @a2 :shared = ($dv, $pi);
+print("# Mix it up with a thread\n");
+my @ary :shared;
+my %hsh :shared;
-ok(6, $a2[0] == 42, 'IV number preserved');
-ok(7, $a2[0] eq 'Fourty-Two', 'string preserved');
-ok(8, $a2[1] == 3.14, 'NV number preserved');
-ok(9, $a2[1] eq 'PI', 'string preserved');
+threads->create(sub {
+ @ary = ($siv);
+ push(@ary, $snv);
-#-- List assignment
-# Verify that dualvar preserved during list assignment
-my @a3 :shared = (0, 0);
-@a3 = ($dv, $pi);
+ %hsh = ( 'nv' => $ary[1] );
+ $hsh{'iv'} = $ary[0];
+ $hsh{'uv'} = $suv;
-ok(10, $a3[0] == 42, 'IV number preserved');
-ok(11, $a3[0] eq 'Fourty-Two', 'string preserved');
-ok(12, $a3[1] == 3.14, 'NV number preserved');
-ok(13, $a3[1] eq 'PI', 'string preserved');
+ $ary[2] = $hsh{'uv'};
+ })->join();
-# Back to non-shared
-# Verify that entries are still dualvar when leaving the array
-my @nsa = @a3;
-ok(14, $nsa[0] == 42, 'IV number preserved');
-ok(15, $nsa[0] eq 'Fourty-Two', 'string preserved');
-ok(16, $nsa[1] == 3.14, 'NV number preserved');
-ok(17, $nsa[1] eq 'PI', 'string preserved');
+ok_iv($hsh{'iv'}, $ary[0]);
+ok_nv($hsh{'nv'}, $ary[1]);
+ok_uv($hsh{'uv'}, $ary[2]);
# $! behaves like a dualvar, but is really implemented as a tied SV.
# As a result sharing $! directly only propagates the string value.
# However, we can create a dualvar from it.
+print("# Errno\n");
$! = 1;
my $ss :shared = dualvar($!,$!);
-ok(18, $ss == 1, 'IV number preserved');
-ok(19, $ss eq $!, 'string preserved');
+ok_iv($ss, $!);
exit(0);
projects / platform / upstream / perl.git / commitdiff