diff --git a/MANIFEST b/MANIFEST index eafba5ff84e0..4f1adbb51229 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4619,6 +4619,7 @@ dist/threads/t/stress_string.t Test with multiple threads, string cv argument. dist/threads/t/thread.t General ithread tests from thr5005 dist/threads/t/unique.t Test unique attribute with threads dist/threads/t/version.t Test that pod version matches code version. +dist/threads/t/zz_deadlock.t Test that code doesn't deadlock dist/threads/threads.h threads compatibility helper dist/threads/threads.xs ithreads dist/threads-shared/hints/linux.pl thread shared variables @@ -4632,6 +4633,7 @@ dist/threads-shared/t/clone.t Test shared cloning dist/threads-shared/t/cond.t Test condition variables dist/threads-shared/t/disabled.t Test threads::shared when threads are disabled. dist/threads-shared/t/dualvar.t Test dual-valued variables +dist/threads-shared/t/err.t Test warnings and errors dist/threads-shared/t/hv_refs.t Test shared hashes containing references dist/threads-shared/t/hv_simple.t Tests for basic shared hash functionality. dist/threads-shared/t/no_share.t Tests for disabled share on variables. diff --git a/dist/threads-shared/lib/threads/shared.pm b/dist/threads-shared/lib/threads/shared.pm index 2ee092d806aa..974c43d9c796 100644 --- a/dist/threads-shared/lib/threads/shared.pm +++ b/dist/threads-shared/lib/threads/shared.pm @@ -8,7 +8,7 @@ use Config; use Scalar::Util qw(reftype refaddr blessed); -our $VERSION = '1.73'; # Please update the pod, too. +our $VERSION = '1.74'; # Please update the pod, too. my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -85,6 +85,23 @@ sub shared_clone return $make_shared->(shift, {}); } +# helper function for $make_shared + +sub _report_unsupported_clone { + my ($item) = @_; + + my $ref_type = reftype($item); + my $category = defined $ref_type ? 'ref' : 'scalar'; + $ref_type = reftype(\$item) unless defined $ref_type; + + require Carp; + if (! defined($threads::shared::clone_warn)) { + Carp::croak("Unsupported $category type: ", $ref_type); + } elsif ($threads::shared::clone_warn) { + Carp::carp("Unsupported $category type: ", $ref_type); + } +} + ### Internal Functions ### @@ -93,11 +110,27 @@ sub shared_clone $make_shared = sub { my ($item, $cloned) = @_; + # Just return the item if + # - not a ref, + # - and not one of the unsupported types + + my $ref_type = reftype($item); + if (!defined $ref_type) { + $ref_type = reftype(\$item); + # some scalar types are currently uncloneable. + # XXX probably should be more in this list. + if ($ref_type =~ /^ (GLOB|CODE) $/x) { + _report_unsupported_clone($item); + return; + } + return $item; + } + # Just return the item if: - # 1. Not a ref; - # 2. Already shared; or - # 3. Not running 'threads'. - return $item if (! ref($item) || is_shared($item) || ! $threads::threads); + # Already shared; or + # Not running 'threads'. + return $item if (is_shared($item) || ! $threads::threads); + # Check for previously cloned references # (this takes care of circular refs as well) @@ -109,7 +142,6 @@ $make_shared = sub { # Make copies of array, hash and scalar refs and refs of refs my $copy; - my $ref_type = reftype($item); # Copy an array ref if ($ref_type eq 'ARRAY') { @@ -159,13 +191,8 @@ $make_shared = sub { } } else { - require Carp; - if (! defined($threads::shared::clone_warn)) { - Carp::croak("Unsupported ref type: ", $ref_type); - } elsif ($threads::shared::clone_warn) { - Carp::carp("Unsupported ref type: ", $ref_type); - } - return undef; + _report_unsupported_clone($item); + return; } # If input item is an object, then bless the copy into the same class @@ -196,7 +223,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.73 +This document describes threads::shared version 1.74 =head1 SYNOPSIS diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs index 85700fec7989..1091cdd1d041 100644 --- a/dist/threads-shared/shared.xs +++ b/dist/threads-shared/shared.xs @@ -241,8 +241,12 @@ recursive_lock_release(pTHX_ void *ptr) MUTEX_UNLOCK(&lock->mutex); } +/* if defer_unlock is true, push a recursive_lock_release on the save + * stack */ + static void -recursive_lock_acquire(pTHX_ recursive_lock_t *lock, const char *file, int line) +recursive_lock_acquire(pTHX_ recursive_lock_t *lock, int defer_unlock, + const char *file, int line) { PERL_UNUSED_ARG(file); PERL_UNUSED_ARG(line); @@ -278,13 +282,14 @@ recursive_lock_acquire(pTHX_ recursive_lock_t *lock, const char *file, int line) #endif } MUTEX_UNLOCK(&lock->mutex); - SAVEDESTRUCTOR_X(recursive_lock_release,lock); + if (defer_unlock) + SAVEDESTRUCTOR_X(recursive_lock_release,lock); } #define ENTER_LOCK \ STMT_START { \ ENTER; \ - recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);\ + recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, 1, __FILE__, __LINE__);\ } STMT_END /* The unlocking is done automatically at scope exit */ @@ -311,10 +316,15 @@ recursive_lock_acquire(pTHX_ recursive_lock_t *lock, const char *file, int line) is used by user-level locking or condition code */ -typedef struct { - recursive_lock_t lock; /* For user-levl locks */ +typedef struct user_lock_struct user_lock; + +struct user_lock_struct { + recursive_lock_t lock; /* For user-level locks */ perl_cond user_cond; /* For user-level conditions */ -} user_lock; + int waiters; /* how many wait()ers on this cond */ + user_lock *cur_lock; /* lock for current cond_wait() */ +}; + /* Magic used for attaching user_lock structs to shared SVs @@ -508,6 +518,8 @@ S_get_userlock(pTHX_ SV* ssv, bool create) mg->mg_private = UL_MAGIC_SIG; /* Set private signature */ recursive_lock_init(aTHX_ &ul->lock); COND_INIT(&ul->user_cond); + ul->waiters = 0; + ul->cur_lock = NULL; CALLER_CONTEXT; } LEAVE_LOCK; @@ -919,7 +931,11 @@ sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv) } else { allowed = FALSE; } - } else { + } + else if (SvTYPE(sv) == SVt_PVGV) { + allowed = FALSE; + } + else { SvTEMP_off(sv); SHARED_CONTEXT; sv_setsv_nomg(ssv, sv); @@ -948,12 +964,6 @@ sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg) SV *ssv = (SV*)(mg->mg_ptr); assert(ssv); ENTER_LOCK; - 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); @@ -984,7 +994,9 @@ static int sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { PERL_UNUSED_ARG(param); + recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, 0, __FILE__, __LINE__); SvREFCNT_inc_void(mg->mg_ptr); + recursive_lock_release(aTHX_ (void *)&PL_sharedsv_lock); return (0); } @@ -1154,7 +1166,9 @@ static int sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { PERL_UNUSED_ARG(param); + recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, 0, __FILE__, __LINE__); SvREFCNT_inc_void(SHAREDSV_FROM_OBJ(mg->mg_obj)); + recursive_lock_release(aTHX_ (void *)&PL_sharedsv_lock); assert(mg->mg_flags & MGf_DUP); return (0); } @@ -1255,7 +1269,9 @@ static int sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { PERL_UNUSED_ARG(param); + recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, 0, __FILE__, __LINE__); SvREFCNT_inc_void((SV*)mg->mg_ptr); + recursive_lock_release(aTHX_ (void *)&PL_sharedsv_lock); assert(mg->mg_flags & MGf_DUP); return (0); } @@ -1271,7 +1287,7 @@ Perl_sharedsv_lock(pTHX_ SV *ssv) if (! ssv) return; ul = S_get_userlock(aTHX_ ssv, 1); - recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__); + recursive_lock_acquire(aTHX_ &ul->lock, 1, __FILE__, __LINE__); } /* Handles calls from lock() builtin via PL_lockhook */ @@ -1375,6 +1391,127 @@ Perl_sharedsv_init(pTHX) #endif } + +/* common function to implement the cond_wait() and cond_timedwait() + * XS functions. For the latter, timed is true. + */ + +static int +S_do_cond_timedwait(pTHX_ SV *ref_cond, double abs, SV *ref_lock, bool timed) +{ + SV *ssv; + int locks; + user_lock *cl, *ul; /* the cond/lock pair, and the lock, if different */ + int ret; + const char *caller = timed ? "cond_timedwait" : "cond_wait"; + bool multi_lock = 0; /* multiple locks seen with same cond */ + + if (!SvROK(ref_cond)) + Perl_croak(aTHX_ "Argument to %s needs to be passed as ref", caller); + ref_cond = SvRV(ref_cond); + if (SvROK(ref_cond)) + ref_cond = SvRV(ref_cond); + + ssv = Perl_sharedsv_find(aTHX_ ref_cond); + if (!ssv) + Perl_croak(aTHX_ "%s can only be used on shared values", caller); + cl = S_get_userlock(aTHX_ ssv, 1); + ul = cl; /* use same lock by default */ + + if (ref_lock && (ref_cond != ref_lock)) { + if (! SvROK(ref_lock)) + Perl_croak(aTHX_ "%s lock needs to be passed as ref", caller); + ref_lock = SvRV(ref_lock); + if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); + ssv = Perl_sharedsv_find(aTHX_ ref_lock); + if (! ssv) + Perl_croak(aTHX_ "%s lock must be a shared value", caller); + ul = S_get_userlock(aTHX_ ssv, 1); + } + + if (ul->lock.owner != aTHX) + Perl_croak(aTHX_ "You need a lock before you can %s", caller); + + /* ------------------------------------------------------------------ + * The following sections emulate the behaviour of the OS-level + * cond_wait(): + * - unlock the lock, + * - block waiting for a signal, + * - re-acquire the lock; + * with the first two being done atomically. + * + * First, *completely* unlock the perl-level lock (as opposed to + * the usual of just decrementing the lock count by one) + */ + + /* Stealing the members of the lock object worries me - NI-S */ + 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 it is ok to go ahead and use it */ + COND_SIGNAL(&ul->lock.cond); + + /* ------------------------------------------------------------------ + * The perl lock is now unlocked, although we still hold the OS mutex. + * Now do the actual wait. While waiting, that mutex will be unlocked. + * (Note that the two COND_WAIT's below wait on different condition + * variables.) + */ + + /* record what lock is currently being used with the condition var */ + if (cl->waiters && cl->cur_lock != ul) { + if (ckWARN(WARN_THREADS)) + Perl_warner(aTHX_ packWARN(WARN_THREADS), + "%s() called on multiple locks", caller); + multi_lock = 1; + /* can't rely on just locking ul to protect cl fields, as + * different threads are using different ul's */ + MUTEX_LOCK(&cl->lock.mutex); + } + + cl->waiters++; + cl->cur_lock = ul; + if (multi_lock) + MUTEX_UNLOCK(&cl->lock.mutex); + + if (timed) + ret = Perl_sharedsv_cond_timedwait(&cl->user_cond, + &ul->lock.mutex, abs); + else { + ret = 0; + COND_WAIT(&cl->user_cond, &ul->lock.mutex); + } + + /* ------------------------------------------------------------------ + * Now acquire and relock the perl lock, restoring it to its original + * recursion level. + */ + + while (ul->lock.owner != NULL) { + /* OK -- must reacquire the lock... */ + COND_WAIT(&ul->lock.cond, &ul->lock.mutex); + } + + if (multi_lock) + MUTEX_LOCK(&cl->lock.mutex); + + if (! --cl->waiters) + cl->cur_lock = NULL; + + if (multi_lock) + MUTEX_UNLOCK(&cl->lock.mutex); + + ul->lock.owner = aTHX; + ul->lock.locks = locks; + MUTEX_UNLOCK(&ul->lock.mutex); + + return ret; +} + + #endif /* USE_ITHREADS */ MODULE = threads::shared PACKAGE = threads::shared::tie @@ -1592,6 +1729,8 @@ _id(SV *myref) PREINIT: SV *ssv; CODE: + if (! SvROK(myref)) + Perl_croak(aTHX_ "Argument to _id needs to be passed as ref"); myref = SvRV(myref); if (SvMAGICAL(myref)) mg_get(myref); @@ -1610,6 +1749,8 @@ _refcnt(SV *myref) PREINIT: SV *ssv; CODE: + if (! SvROK(myref)) + Perl_croak(aTHX_ "Argument to _refcnt needs to be passed as ref"); myref = SvRV(myref); if (SvROK(myref)) myref = SvRV(myref); @@ -1642,104 +1783,15 @@ share(SV *myref) void cond_wait(SV *ref_cond, SV *ref_lock = 0) PROTOTYPE: \[$@%];\[$@%] - PREINIT: - SV *ssv; - perl_cond* user_condition; - int locks; - user_lock *ul; CODE: - if (!SvROK(ref_cond)) - Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref"); - ref_cond = SvRV(ref_cond); - if (SvROK(ref_cond)) - ref_cond = SvRV(ref_cond); - ssv = Perl_sharedsv_find(aTHX_ ref_cond); - if (! ssv) - Perl_croak(aTHX_ "cond_wait can only be used on shared values"); - ul = S_get_userlock(aTHX_ ssv, 1); - - user_condition = &ul->user_cond; - if (ref_lock && (ref_cond != ref_lock)) { - 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); - ssv = Perl_sharedsv_find(aTHX_ ref_lock); - if (! ssv) - Perl_croak(aTHX_ "cond_wait lock must be a shared value"); - ul = S_get_userlock(aTHX_ ssv, 1); - } - 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(&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 it is ok to go ahead and use it */ - COND_SIGNAL(&ul->lock.cond); - COND_WAIT(user_condition, &ul->lock.mutex); - while (ul->lock.owner != NULL) { - /* OK -- must reacquire the lock */ - COND_WAIT(&ul->lock.cond, &ul->lock.mutex); - } - ul->lock.owner = aTHX; - ul->lock.locks = locks; - MUTEX_UNLOCK(&ul->lock.mutex); + (void)S_do_cond_timedwait(aTHX_ ref_cond, 0.0, ref_lock, 0); int cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0) PROTOTYPE: \[$@%]$;\[$@%] - PREINIT: - SV *ssv; - perl_cond* user_condition; - int locks; - user_lock *ul; CODE: - if (! SvROK(ref_cond)) - Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref"); - ref_cond = SvRV(ref_cond); - if (SvROK(ref_cond)) - ref_cond = SvRV(ref_cond); - ssv = Perl_sharedsv_find(aTHX_ ref_cond); - if (! ssv) - Perl_croak(aTHX_ "cond_timedwait can only be used on shared values"); - ul = S_get_userlock(aTHX_ ssv, 1); - - user_condition = &ul->user_cond; - if (ref_lock && (ref_cond != ref_lock)) { - 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); - ssv = Perl_sharedsv_find(aTHX_ ref_lock); - if (! ssv) - Perl_croak(aTHX_ "cond_timedwait lock must be a shared value"); - ul = S_get_userlock(aTHX_ ssv, 1); - } - if (ul->lock.owner != aTHX) - Perl_croak(aTHX_ "You need a lock before you can cond_wait"); - - 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 it is ok to go ahead and use it */ - 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(&ul->lock.cond, &ul->lock.mutex); - } - ul->lock.owner = aTHX; - ul->lock.locks = locks; - MUTEX_UNLOCK(&ul->lock.mutex); - + RETVAL = S_do_cond_timedwait(aTHX_ ref_cond, abs, ref_lock, 1); if (RETVAL == 0) XSRETURN_UNDEF; OUTPUT: @@ -1748,48 +1800,63 @@ cond_timedwait(SV *ref_cond, double abs, SV *ref_lock = 0) void cond_signal(SV *myref) + ALIAS: + cond_broadcast = 1 + PROTOTYPE: \[$@%] PREINIT: SV *ssv; - user_lock *ul; + user_lock *cl, *ul; + const char *name = ix ? "cond_broadcast" : "cond_signal"; CODE: if (! SvROK(myref)) - Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref"); + Perl_croak(aTHX_ "Argument to %s needs to be passed as ref", + name); myref = SvRV(myref); if (SvROK(myref)) myref = SvRV(myref); ssv = Perl_sharedsv_find(aTHX_ myref); if (! ssv) - Perl_croak(aTHX_ "cond_signal can only be used on shared values"); - 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(&ul->user_cond); + Perl_croak(aTHX_ "%s can only be used on shared values", name); + cl = S_get_userlock(aTHX_ ssv, 1); + ul = cl->cur_lock + ? cl->cur_lock + /* signalling while no active wait */ + : cl; -void -cond_broadcast(SV *myref) - PROTOTYPE: \[$@%] - PREINIT: - SV *ssv; - user_lock *ul; - CODE: - if (! SvROK(myref)) - Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref"); - myref = SvRV(myref); - if (SvROK(myref)) - myref = SvRV(myref); - ssv = Perl_sharedsv_find(aTHX_ myref); - if (! ssv) - Perl_croak(aTHX_ "cond_broadcast can only be used on shared values"); - 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"); + "%s() called on unlocked variable", name); } - COND_BROADCAST(&ul->user_cond); + + /* The purpose of holding the mutex while signalling: + * strictly speaking it isn't necessary, but it stops + * tools like helgrind and drd reporting false positives. + * + * Normally signalling is done in this order: + * lock(mutuex); + * predicate = 1; + * signal(cond) + * unlock(mutuex); + * although it often doesn't matter if the unlock is done before + * the signal(), as long as it's done *after* the predicate + * change. + * In our case however, the predicate is set in perl-land, and + * the lock that protects it is a perl-level lock, which is still + * held (see the "cond_signal() called on unlocked variable" + * check above); but the C-level mutex *isn't* held at this point. + * So setting the mutex below is harmless (apart from being + * infinitesimally slower), but not necessary. + */ + MUTEX_LOCK(&ul->lock.mutex); + + if (ix) + COND_BROADCAST(&cl->user_cond); + else + COND_SIGNAL(&cl->user_cond); + + MUTEX_UNLOCK(&ul->lock.mutex); SV* diff --git a/dist/threads-shared/t/err.t b/dist/threads-shared/t/err.t new file mode 100644 index 000000000000..3bcfc9cebcdd --- /dev/null +++ b/dist/threads-shared/t/err.t @@ -0,0 +1,209 @@ +#!perl +# +# Test for expected error and warning messages +# +# Fairly comprehensive, but doesn't check panics and portability +# issues, which are hard/impossible to portably test for. + +use strict; +use warnings; + +use ExtUtils::testlib; +use Test::More; + +BEGIN { + use Config; + plan(skip_all => "Perl not compiled with 'useithreads'") + unless $Config{'useithreads'}; +} + +use threads; +use threads::shared; + +pass("loaded"); + +# Check warnings + +{ + my $w; + local $SIG{__WARN__} = sub { $w .= $_[0]; }; + + my $lock :shared; + + # shared.xs warnings + + { + undef $w; + my $x :shared; + &threads::shared::bless(\$x, ''); + like($w, qr/\QExplicit blessing to '' (assuming package main)/, + "warn bless main"); + } + + { + my $s; + undef $w; + is threads::shared::_refcnt($s), undef, "warn _refcnt undef retval"; + like($w, qr/SCALAR\(0x[0-9a-f]+\) is not shared/, "warn _refcnt"); + } + + undef $w; + cond_signal($lock); + like($w, qr/\Qcond_signal() called on unlocked variable/, + "warn cond_signal not locked"); + + undef $w; + cond_broadcast($lock); + like($w, qr/\Qcond_broadcast() called on unlocked variable/, + "warn cond_broadcast not locked"); + + { + # Test whether using separate cond and lock vars triggers + # an 'unlocked var' warning. + my $cond :shared; # used for actual test + my $sig :shared; # used to sync threads ready for test + undef $w; + my $t = threads->new( + sub { + lock $lock; + { + # tell parent we have $lock + lock $sig; + $sig = 1; + cond_signal($sig); + } + cond_wait($cond, $lock); + } + ); + + # wait until child has $lock + { + lock $sig; + while (!$sig) { + cond_wait($sig); + } + } + pass("\$lock acquired"); + + { + # the actual test + lock $lock; + cond_signal($cond); + } + is($w, undef, "no warn cond_signal not locked"); + $t->join; + } +} + + +# Check errors + +{ + my $lock :shared; + + # shared.pm errors + + eval q{my @a :shared; splice(@a,1);}; + like($@, qr/Splice not implemented for shared arrays/, "err splice"); + + eval q{shared_clone(1,2)}; + like($@, qr/\QUsage: shared_clone(REF)/, "err shared_clone usage"); + + eval q{shared_clone(\*foo)}; + like($@, qr/Unsupported ref type: GLOB/, "err shared_clone ref GLOB"); + + eval q{shared_clone(*foo)}; + like($@, qr/Unsupported scalar type: GLOB/, "err shared_clone scalar GLOB"); + + # shared.xs errors + + eval q{&share(\*x99)}; + like($@, qr/Cannot share globs yet/, "err glob share"); + + eval q{&share(sub {})}; + like($@, qr/Cannot share subs yet/, "err sub share"); + + eval q{&threads::shared::_id(1)}; + like($@, qr/Argument to _id needs to be passed as ref/, + "err _id not ref"); + + eval q{&threads::shared::_refcnt(1)}; + like($@, qr/Argument to _refcnt needs to be passed as ref/, + "err _refcnt not ref"); + + eval q{&share(1)}; + like($@, qr/Argument to share needs to be passed as ref/, + "err share not ref"); + + eval q{my $x: shared; $x = sub{};}; + like($@, qr/Invalid value for shared scalar/, "err share invalid sub assign"); + + eval q{my $x: shared; $x = *ABC}; + like($@, qr/Invalid value for shared scalar/, "err share invalid glob assign"); + + eval q{my $x; lock($x);}; + like($@, qr/lock can only be used on shared values/, "err unshared lock"); + + eval q{&threads::shared::bless($lock, []);}; + like($@, qr/Attempt to bless into a reference/, "err bless ref"); + + + eval q{&cond_wait(1);}; + like($@, qr/Argument to cond_wait needs to be passed as ref/, + "err cond_wait ref"); + + eval q{&cond_timedwait(1, 0.0);}; + like($@, qr/Argument to cond_timedwait needs to be passed as ref/, + "err cond_timedwait ref"); + + eval q{&cond_wait(\1);}; + like($@, qr/cond_wait can only be used on shared values/, + "err cond_wait shared"); + + eval q{&cond_timedwait(\1, 0.0);}; + like($@, qr/cond_timedwait can only be used on shared values/, + "err cond_timedwait shared"); + + eval q{&cond_wait(\$lock, 1);}; + like($@, qr/cond_wait lock needs to be passed as ref/, + "err cond_wait lock ref"); + + eval q{&cond_timedwait(\$lock, 0.0, 1);}; + like($@, qr/cond_timedwait lock needs to be passed as ref/, + "err cond_timedwait lock ref"); + + eval q{&cond_wait(\$lock, \1);}; + like($@, qr/cond_wait lock must be a shared value/, + "err cond_wait lock shared"); + + eval q{&cond_timedwait(\$lock, 0.0, \1);}; + like($@, qr/cond_timedwait lock must be a shared value/, + "err cond_timedwait lock shared"); + + eval q{&cond_wait(\$lock);}; + like($@, qr/You need a lock before you can cond_wait/, + "err cond_wait not locked"); + + eval q{&cond_timedwait(\$lock, 0.0);}; + like($@, qr/You need a lock before you can cond_timedwait/, + "err cond_timedwait not locked"); + + eval q{&cond_signal(1);}; + like($@, qr/Argument to cond_signal needs to be passed as ref/, + "err cond_signal not ref"); + + eval q{&cond_broadcast(1);}; + like($@, qr/Argument to cond_broadcast needs to be passed as ref/, + "err cond_broadcast not ref"); + + eval q{&cond_signal(\1);}; + like($@, qr/cond_signal can only be used on shared values/, + "err cond_signal not shared"); + + eval q{&cond_broadcast(\1);}; + like($@, qr/cond_broadcast can only be used on shared values/, + "err cond_broadcast not shared"); +} + +done_testing; + diff --git a/dist/threads/lib/threads.pm b/dist/threads/lib/threads.pm index 93db76d15c7d..5f83f68e4461 100644 --- a/dist/threads/lib/threads.pm +++ b/dist/threads/lib/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '2.45'; # remember to update version in POD! +our $VERSION = '2.46'; # remember to update version in POD! my $XS_VERSION = $VERSION; #$VERSION = eval $VERSION; @@ -134,7 +134,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 2.45 +This document describes threads version 2.46 =head1 WARNING diff --git a/dist/threads/t/blocks.t b/dist/threads/t/blocks.t index 921679afae0c..32f2590700f3 100644 --- a/dist/threads/t/blocks.t +++ b/dist/threads/t/blocks.t @@ -1,6 +1,8 @@ use strict; use warnings; +# Test creating / destroying threads within BEGIN blocks + BEGIN { use Config; if (! $Config{'useithreads'}) { diff --git a/dist/threads/t/zz_deadlock.t b/dist/threads/t/zz_deadlock.t new file mode 100644 index 000000000000..c9f94ed3fabd --- /dev/null +++ b/dist/threads/t/zz_deadlock.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +# This test file contains code which sometimes used to deadlock. +# The only test result it gives is that the file ran to completion. +# There aren't any watchdog timers set because once two threads +# own locks 1 and 2 and are waiting on locks 2 and 1, nothing is +# going to cleanly free those locks and allow global cleanup to run to +# completion: such cleanup would try to free objects containing +# threads etc and would try to lock when freeing such objects and itself +# deadlock. + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + + +sub pass { + my ($id, $name) = @_; + print("ok $id - $name\n"); +} + +BEGIN { + $| = 1; + print("1..2\n"); ### Number of tests that will be run ### +}; + +use threads; + +if ($threads::VERSION && ! $ENV{'PERL_CORE'}) { + print(STDERR "# Testing threads $threads::VERSION\n"); +} + +pass(1, 'Loaded'); + +### Start of Testing ### + + +# A child thread, which does nothing except that ensure that on exit, it +# has a global variable which is a threads object which has been joined, +# (so no interpreter) but still needs to be freed. +# +sub child { + # using package variable means child thread object is only freed + # during global destruction of parent + our $t = threads->new(sub {}); + $t->join(); +} + +# start and join a thread few times. We're interested in the freeing +# of the interpreter which happens during the joining of the thread. + +sub joiner { + for (1..10) { + threads->new(\&child)->join(); + 1; + } +} + +# Repeatedly walk the list of pool objects: each iteration involves +# locking the pool, then in turn locking each thread object in the list. + +sub lister { + my $i = 0; + while (1) { + my $c = threads->list(); + $i++; + last if $i > 10000; + } +} + + +{ + my @t; + push @t, threads->new(\&lister, $_); + push @t, threads->new(\&joiner, $_); + $_->join() for @t; +} + +pass(2, 'ran to completion'); diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs index d54ab0b8a392..8c434f3289c6 100644 --- a/dist/threads/threads.xs +++ b/dist/threads/threads.xs @@ -69,23 +69,26 @@ typedef perl_os_thread pthread_t; #define PERL_ITHR_JOINED 2 /* Thread is being / has been joined */ #define PERL_ITHR_FINISHED 4 /* Thread has finished execution */ #define PERL_ITHR_THREAD_EXIT_ONLY 8 /* exit() only exits current thread */ -#define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */ #define PERL_ITHR_DIED 32 /* Thread finished by dying */ -#define PERL_ITHR_UNCALLABLE (PERL_ITHR_DETACHED|PERL_ITHR_JOINED) - typedef struct _ithread { struct _ithread *next; /* Next thread in the list */ struct _ithread *prev; /* Prev thread in the list */ PerlInterpreter *interp; /* The thread's interpreter */ UV tid; /* Thread's module's thread id */ - perl_mutex mutex; /* Mutex for updating things in this struct */ + + perl_mutex mutex; /* Mutex for updating things in this struct. + * When both need to be held, it should + * always be acquired *after* + * create_destruct_mutex. */ + int count; /* Reference count. See S_ithread_create. */ int state; /* Detached, joined, finished, etc. */ int gimme; /* Context of create */ SV *init_function; /* Code to run */ AV *params; /* Args to pass function */ + struct my_pool *pool; /* which thread pool we belong to */ #ifdef WIN32 DWORD thr; /* OS's idea if thread id */ HANDLE handle; /* OS's waitable handle */ @@ -113,12 +116,20 @@ START_MY_CXT #define MY_POOL_KEY "threads::_pool" XS_VERSION -typedef struct { +/* The pool of threads. Typically there is a single copy of this struct + * per process, which maintains information about all the threads created + * via threads.xs. However, when a process (e.g. a web server) maintains + * multiple interpreters, then there will be a pool for each interpreter + * which has done 'use threads' at least once. + */ +typedef struct my_pool { /* Structure for 'main' thread * Also forms the 'base' for the doubly-linked list of threads */ ithread main_thread; - /* Protects the creation and destruction of threads*/ + /* Protects the creation and destruction of threads. + * When both need to be held, it should always be acquired *before* a + * thread mutex. */ perl_mutex create_destruct_mutex; UV tid_counter; @@ -130,11 +141,15 @@ typedef struct { IV page_size; } my_pool_t; +/* get the pool from the current interpreter's PL_modglobal */ #define dMY_POOL \ SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY, \ sizeof(MY_POOL_KEY)-1, TRUE); \ my_pool_t *my_poolp = INT2PTR(my_pool_t*, SvUV(my_pool_sv)) +/* get the pool from a thread structure */ +#define dMY_POOL_thr(thr) my_pool_t *my_poolp = thr->pool + #define MY_POOL (*my_poolp) #if defined(WIN32) || (defined(__amigaos4__) && defined(__NEWLIB__)) @@ -206,6 +221,10 @@ S_ithread_get(pTHX) * must be called with MY_POOL.create_destruct_mutex unlocked as destruction * of the interpreter can lead to recursive destruction calls that could * lead to a deadlock on that mutex. + * + * The thread of this function's caller (and thus the passed pTHX) is + * different than that of the thread being cleared: the caller is + * typically the thread calling join() or similar. */ static void S_ithread_clear(pTHX_ ithread *thread) @@ -214,11 +233,10 @@ S_ithread_clear(pTHX_ ithread *thread) #ifndef WIN32 sigset_t origmask; #endif + bool self_thx; /* the caller's interpreter is the same as the thread's */ - assert(((thread->state & PERL_ITHR_FINISHED) && - (thread->state & PERL_ITHR_UNCALLABLE)) - || - (thread->state & PERL_ITHR_NONVIABLE)); + assert( (thread->state & PERL_ITHR_FINISHED) + && (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))); #ifdef THREAD_SIGNAL_BLOCKING /* We temporarily set the interpreter context to the interpreter being @@ -228,11 +246,12 @@ S_ithread_clear(pTHX_ ithread *thread) S_block_most_signals(&origmask); #endif -#if PERL_VERSION_GE(5, 37, 5) +#if PERL_VERSION_GE(5, 37, 5) && PERL_VERSION_LT(5, 43, 11) int save_veto = PL_veto_switch_non_tTHX_context; #endif interp = thread->interp; + self_thx = (aTHX == interp); if (interp) { dTHXa(interp); @@ -256,13 +275,20 @@ S_ithread_clear(pTHX_ ithread *thread) thread->err = Nullsv; } + thread->interp = NULL; + MUTEX_UNLOCK(&thread->mutex); perl_destruct(interp); + MUTEX_LOCK(&thread->mutex); perl_free(interp); - thread->interp = NULL; } + if (self_thx) + aTHX = NULL; PERL_SET_CONTEXT(aTHX); -#if PERL_VERSION_GE(5, 37, 5) + +#if PERL_VERSION_GE(5, 37, 5) && PERL_VERSION_LT(5, 43, 11) + /* between those releases, this was a global var rather than per + * interpreter */ PL_veto_switch_non_tTHX_context = save_veto; #endif @@ -275,42 +301,57 @@ S_ithread_clear(pTHX_ ithread *thread) /* Decrement the refcount of an ithread, and if it reaches zero, free it. * Must be called with the mutex held. * On return, mutex is released (or destroyed). + * + * The thread of this function's caller (and thus the passed pTHX) is + * often different than that of the thread being freed: the caller is + * typically the thread calling join() or similar. */ static void -S_ithread_free(pTHX_ ithread *thread) +S_ithread_dec_free(pTHX_ ithread *thread) PERL_TSA_RELEASE(thread->mutex) { #ifdef WIN32 HANDLE handle; #endif - dMY_POOL; + dMY_POOL_thr(thread); + bool self_thx; /* the caller's interpreter is the same as the thread's */ - if (! (thread->state & PERL_ITHR_NONVIABLE)) { - assert(thread->count > 0); - if (--thread->count > 0) { - MUTEX_UNLOCK(&thread->mutex); - return; - } - assert((thread->state & PERL_ITHR_FINISHED) && - (thread->state & PERL_ITHR_UNCALLABLE)); + assert(thread->count > 0); + if (--thread->count > 0) { + MUTEX_UNLOCK(&thread->mutex); + return; } + assert((thread->state & PERL_ITHR_FINISHED) && + (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))); + MUTEX_UNLOCK(&thread->mutex); /* Main thread (0) is immortal and should never get here */ assert(thread->tid != 0); /* Remove from circular list of threads */ - MUTEX_LOCK(&MY_POOL.create_destruct_mutex); - assert(thread->prev && thread->next); - thread->next->prev = thread->prev; - thread->prev->next = thread->next; - thread->next = NULL; - thread->prev = NULL; - MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + if (thread->next) { + /* the thread won't yet be in the list if we failed while + * creating the thread and are now just cleaning up */ + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + thread->next->prev = thread->prev; + thread->prev->next = thread->next; + thread->next = NULL; + thread->prev = NULL; + MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + } /* Thread is now disowned */ MUTEX_LOCK(&thread->mutex); + self_thx = (aTHX == thread->interp); S_ithread_clear(aTHX_ thread); + if (self_thx) + aTHX = NULL; /* we just freed the interpreter */ + /* NB: if anything subsequentially SEGVs due to dereferencing a + * NULL my_perl, its likely that the dereferencing code needs a + * non-NULL guard adding, rather than that setting it to NULL here + * was wrong. + */ #ifdef WIN32 handle = thread->handle; @@ -325,7 +366,23 @@ S_ithread_free(pTHX_ ithread *thread) } #endif + +#ifdef PERL_IMPLICIT_SYS + if (!aTHX) { + /* under PERL_IMPLICIT_SYS, PerlMemShared_free() uses + * my_perl->IMemShared to access a function pointer. Since there + * is no interpreter, use the main one instead (which is + * guaranteed to be freed last). This isn't ideal, but is better + * than nothing. + */ + aTHX = MY_POOL.main_thread.interp; + PerlMemShared_free(thread); + aTHX = NULL; + } + else +#else PerlMemShared_free(thread); +#endif /* total_threads >= 1 is used to veto cleanup by the main thread, * should it happen to exit while other threads still exist. @@ -414,7 +471,7 @@ ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) ithread *thread = (ithread *)mg->mg_ptr; PERL_UNUSED_ARG(sv); MUTEX_LOCK(&thread->mutex); - S_ithread_free(aTHX_ thread); /* Releases MUTEX */ + S_ithread_dec_free(aTHX_ thread); /* Releases MUTEX */ return (0); } @@ -558,15 +615,17 @@ S_ithread_run(void * arg) dTHXa(thread->interp); - dMY_POOL; + dMY_POOL_thr(thread); /* The following mutex lock + mutex unlock pair explained. * * parent: - * - calls ithread_create (and S_ithread_create), which: - * - creates the new thread + * - calls ithread_create(), + * which calls pthread_create(..., S_ithread_run,...), which + * - creates the new thread structure + * - clones the interpreter; * - does MUTEX_LOCK(&thread->mutex) - * - calls pthread_create(..., S_ithread_run,...) + * - creates an OS thread to run S_ithread_run() * child: * - starts the S_ithread_run (where we are now), which: * - tries to MUTEX_LOCK(&thread->mutex) @@ -707,14 +766,43 @@ S_ithread_run(void * arg) my_exit(exit_code); } - /* At this point, the interpreter may have been freed, so call - * free in the context of the 'main' interpreter which - * can't have been freed due to the veto_cleanup mechanism. + /* Typically the thread isn't freed at this point: + * the creator of the thread likely still holds a ref to it, + * and the thread has an extra ref count if it hasn't been joined + * or detached yet. + * But a thread which has been detached and whose creator frees the + * threads->new() object early on, could be freed here. */ - aTHX = MY_POOL.main_thread.interp; - MUTEX_LOCK(&thread->mutex); - S_ithread_free(aTHX_ thread); /* Releases MUTEX */ + S_ithread_dec_free(aTHX_ thread); /* Releases MUTEX */ + + /* This a workaround for a 'valgrind --helgind' false positive, due to + * the fact that behind the scenes, the MUTEX_UNLOCK() macro does a + * reset of errno *after* the mutex is unlocked. + * + * When we reach this point in S_ithread_run(), the OS thread is about + * to exit, and so its TLS will be freed by the threads library and + * available to be reallocated to the next thread which is created. + * But helgrind sees the write to errno in TLS just done by the + * MUTEX_UNLOCK() in S_ithread_dec_free() above, and a later write to + * the new thread's errno, as two different threads writing to to same + * memnory address while a lock wasn't held. The harmless workaround + * below does a final write to errno before the thread quits, but while + * holding a lock. The code below following the MUTEX_LOCK() is an + * unrolled MUTEX_UNLOCK() but without the trailing errno restore. + */ +#ifdef perl_pthread_mutex_unlock + { + int err; + MUTEX_LOCK(&MY_POOL.create_destruct_mutex); + errno = 0; + if ((err = perl_pthread_mutex_unlock((&MY_POOL.create_destruct_mutex)))) { + Perl_croak_nocontext( \ + "panic: MUTEX_UNLOCK (%d) [%s:%d]", + err, __FILE__, __LINE__); + } + } +#endif #ifdef WIN32 return ((DWORD)0); @@ -762,8 +850,6 @@ S_SV_to_ithread(pTHX_ SV *sv) /* threads->create() * Called in context of parent thread. - * Called with my_pool->create_destruct_mutex locked. - * (Unlocked both on error and on success.) */ static ithread * S_ithread_create( @@ -775,7 +861,6 @@ S_ithread_create( int exit_opt, int params_start, int num_params) - PERL_TSA_RELEASE(my_pool->create_destruct_mutex) { dTHXa(parent_perl); ithread *thread; @@ -788,20 +873,17 @@ S_ithread_create( IV tmps_ix = PL_tmps_ix; #endif #ifndef WIN32 - int rc_stack_size = 0; - int rc_thread_create = 0; + int setstack_err = 0; + int create_err = 0; #endif + /* Allocate thread structure in context of the main thread's interpreter */ - { - PERL_SET_CONTEXT(my_pool->main_thread.interp); - thread = (ithread *)PerlMemShared_malloc(sizeof(ithread)); - } + PERL_SET_CONTEXT(my_pool->main_thread.interp); + thread = (ithread *)PerlMemShared_malloc(sizeof(ithread)); PERL_SET_CONTEXT(aTHX); + if (!thread) { - /* This lock was acquired in ithread_create() - * prior to calling S_ithread_create(). */ - MUTEX_UNLOCK(&my_pool->create_destruct_mutex); { int fd = PerlIO_fileno(Perl_error_log); if (fd >= 0) { @@ -814,13 +896,6 @@ S_ithread_create( } Zero(thread, 1, ithread); - /* Add to threads list */ - thread->next = &my_pool->main_thread; - thread->prev = my_pool->main_thread.prev; - my_pool->main_thread.prev = thread; - thread->prev->next = thread; - my_pool->total_threads++; - /* 1 ref to be held by the local var 'thread' in S_ithread_run(). * 1 ref to be held by the threads object that we assume we will * be embedded in upon our return. @@ -830,12 +905,14 @@ S_ithread_create( * { threads->create(sub{...}); } threads->object(1)->join; */ thread->count = 3; + thread->pool = my_pool; - /* Block new thread until ->create() call finishes */ MUTEX_INIT(&thread->mutex); - MUTEX_LOCK(&thread->mutex); /* See S_ithread_run() for more detail. */ + MUTEX_LOCK(&my_pool->create_destruct_mutex); thread->tid = my_pool->tid_counter++; + MUTEX_UNLOCK(&my_pool->create_destruct_mutex); + thread->stack_size = S_good_stack_size(aTHX_ stack_size); thread->gimme = gimme; thread->state = exit_opt; @@ -968,6 +1045,22 @@ S_ithread_create( S_ithread_set(aTHX_ current_thread); PERL_SET_CONTEXT(aTHX); + /* Add to threads list */ + + MUTEX_LOCK(&my_pool->create_destruct_mutex); + thread->next = &my_pool->main_thread; + thread->prev = my_pool->main_thread.prev; + my_pool->main_thread.prev = thread; + thread->prev->next = thread; + my_pool->total_threads++; + my_pool->running_threads++; + MUTEX_UNLOCK(&my_pool->create_destruct_mutex); + + + /* Block new thread until ->create() call finishes */ + MUTEX_LOCK(&thread->mutex); /* See S_ithread_run() for more detail. */ + + /* Create/start the thread */ #ifdef WIN32 thread->handle = CreateThread(NULL, @@ -994,14 +1087,14 @@ S_ithread_create( # ifdef _POSIX_THREAD_ATTR_STACKSIZE /* Set thread's stack size */ if (thread->stack_size > 0) { - rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size); + setstack_err = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size); } # endif /* Create the thread */ - if (! rc_stack_size) { + if (!setstack_err) { # ifdef OLD_PTHREADS_API - rc_thread_create = pthread_create(&thread->thr, + create_err = pthread_create(&thread->thr, attr, S_ithread_run, (void *)thread); @@ -1009,7 +1102,7 @@ S_ithread_create( # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM) pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM); # endif - rc_thread_create = pthread_create(&thread->thr, + create_err = pthread_create(&thread->thr, &attr, S_ithread_run, (void *)thread); @@ -1042,30 +1135,30 @@ S_ithread_create( /* Check for errors */ #ifdef WIN32 - if (thread->handle == NULL) { + if (thread->handle == NULL) #else - if (rc_stack_size || rc_thread_create) { + if (setstack_err || create_err) #endif - /* Must unlock mutex for destruct call */ - /* This lock was acquired in ithread_create() - * prior to calling S_ithread_create(). */ - MUTEX_UNLOCK(&my_pool->create_destruct_mutex); - thread->state |= PERL_ITHR_NONVIABLE; - S_ithread_free(aTHX_ thread); /* Releases MUTEX */ + { + /* force the freeing of the otherwise-unused thread and interp */ + thread->count = 1; + thread->state |= (PERL_ITHR_FINISHED | PERL_ITHR_JOINED); + S_ithread_dec_free(aTHX_ thread); /* Releases MUTEX */ #ifndef WIN32 if (ckWARN_d(WARN_THREADS)) { - if (rc_stack_size) { - Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size); + if (setstack_err) { + Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, setstack_err); } else { - Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create); + Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", create_err); } } #endif return NULL; } - my_pool->running_threads++; - MUTEX_UNLOCK(&my_pool->create_destruct_mutex); + /* Let thread run. */ + /* See S_ithread_run() for more detail. */ + MUTEX_UNLOCK(&thread->mutex); return (thread); CLANG_DIAG_IGNORE(-Wthread-safety) @@ -1076,13 +1169,13 @@ CLANG_DIAG_RESTORE #endif /* USE_ITHREADS */ -MODULE = threads PACKAGE = threads PREFIX = ithread_ +MODULE = threads PACKAGE = threads PROTOTYPES: DISABLE #ifdef USE_ITHREADS SV* -ithread_create(...) +create(...) PREINIT: char *classname; ithread *thread; @@ -1112,12 +1205,13 @@ ithread_create(...) if (sv_isobject(ST(0))) { /* $thr->create() */ + ithread *parent_thread; classname = HvNAME(SvSTASH(SvRV(ST(0)))); - thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); - MUTEX_LOCK(&thread->mutex); - stack_size = thread->stack_size; - exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY; - MUTEX_UNLOCK(&thread->mutex); + parent_thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); + MUTEX_LOCK(&parent_thread->mutex); + stack_size = parent_thread->stack_size; + exit_opt = parent_thread->state & PERL_ITHR_THREAD_EXIT_ONLY; + MUTEX_UNLOCK(&parent_thread->mutex); } else { /* threads->create() */ classname = (char *)SvPV_nolen(ST(0)); @@ -1194,7 +1288,6 @@ ithread_create(...) } /* Create thread */ - MUTEX_LOCK(&MY_POOL.create_destruct_mutex); thread = S_ithread_create(aTHX_ &MY_POOL, function_to_call, stack_size, @@ -1208,17 +1301,11 @@ ithread_create(...) PERL_SRAND_OVERRIDE_NEXT_PARENT(); RETVAL = S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE); - /* Let thread run. */ - /* See S_ithread_run() for more detail. */ - CLANG_DIAG_IGNORE_STMT(-Wthread-safety); - /* warning: releasing mutex 'thread->mutex' that was not held [-Wthread-safety-analysis] */ - MUTEX_UNLOCK(&thread->mutex); - CLANG_DIAG_RESTORE_STMT; OUTPUT: RETVAL void -ithread_list(...) +list(...) PREINIT: char *classname; ithread *thread; @@ -1253,7 +1340,7 @@ ithread_list(...) MUTEX_UNLOCK(&thread->mutex); /* Ignore detached or joined threads */ - if (state & PERL_ITHR_UNCALLABLE) { + if (state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) { continue; } @@ -1284,7 +1371,7 @@ ithread_list(...) SV* -ithread_self(...) +self(...) PREINIT: char *classname; ithread *thread; @@ -1302,7 +1389,7 @@ ithread_self(...) UV -ithread_tid(...) +tid(...) PREINIT: ithread *thread; CODE: @@ -1313,7 +1400,7 @@ ithread_tid(...) void -ithread_join(...) +join(...) PREINIT: ithread *thread; ithread *current_thread; @@ -1337,7 +1424,7 @@ ithread_join(...) current_thread = S_ithread_get(aTHX); MUTEX_LOCK(&thread->mutex); - if ((join_err = (thread->state & PERL_ITHR_UNCALLABLE))) { + if ((join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) { MUTEX_UNLOCK(&thread->mutex); Perl_croak(aTHX_ (join_err & PERL_ITHR_DETACHED) ? "Cannot join a detached thread" @@ -1419,11 +1506,18 @@ ithread_join(...) #endif } - /* If thread didn't die, then we can free its interpreter */ + /* Free the interpreter now, unless there was an error and + * $@ needs to be kept for a later $thr->error() call. + */ if (! (thread->state & PERL_ITHR_DIED)) { S_ithread_clear(aTHX_ thread); } - S_ithread_free(aTHX_ thread); /* Releases MUTEX */ + /* Decrement the thread's ref count. The thread will likely live + * on for now and be freed later, when it will do a second call + * to S_ithread_clear() which will notice that the interpreter + * has already been freed, and so not do much further cleanup. + */ + S_ithread_dec_free(aTHX_ thread); /* Releases MUTEX */ /* If no return values, then just return */ if (! params) { @@ -1442,14 +1536,14 @@ ithread_join(...) void -ithread_yield(...) +yield(...) CODE: PERL_UNUSED_VAR(items); YIELD; void -ithread_detach(...) +detach(...) PREINIT: ithread *thread; int detach_err; @@ -1461,7 +1555,8 @@ ithread_detach(...) thread = S_SV_to_ithread(aTHX_ ST(0)); MUTEX_LOCK(&MY_POOL.create_destruct_mutex); MUTEX_LOCK(&thread->mutex); - if (! (detach_err = (thread->state & PERL_ITHR_UNCALLABLE))) { + if (! (detach_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) + { /* Thread is detachable */ thread->state |= PERL_ITHR_DETACHED; #ifdef WIN32 @@ -1485,19 +1580,26 @@ ithread_detach(...) : "Cannot detach a joined thread"); } - /* If thread is finished and didn't die, - * then we can free its interpreter */ + /* If the interpreter is finished with, free it now, unless there + * was an error and $@ needs to be kept for a later $thr->error() + * call. + */ MUTEX_LOCK(&thread->mutex); if ((thread->state & PERL_ITHR_FINISHED) && ! (thread->state & PERL_ITHR_DIED)) { S_ithread_clear(aTHX_ thread); } - S_ithread_free(aTHX_ thread); /* Releases MUTEX */ + /* Decrement the thread's ref count. The thread will likely live + * on for now and be freed later, when it will do a second call + * to S_ithread_clear() which will notice that the interpreter + * has already been freed, and so not do much further cleanup. + */ + S_ithread_dec_free(aTHX_ thread); /* Releases MUTEX */ void -ithread_kill(...) +kill(...) PREINIT: ithread *thread; char *sig_name; @@ -1555,14 +1657,14 @@ ithread_kill(...) void -ithread_DESTROY(...) +DESTROY(...) CODE: PERL_UNUSED_VAR(items); sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar); IV -ithread_equal(...) +equal(...) PREINIT: int are_equal = 0; CODE: @@ -1584,7 +1686,7 @@ ithread_equal(...) SV* -ithread_object(...) +object(...) PREINIT: char *classname; SV *arg; @@ -1635,7 +1737,7 @@ ithread_object(...) MUTEX_LOCK(&thread->mutex); state = thread->state; MUTEX_UNLOCK(&thread->mutex); - if (! (state & PERL_ITHR_UNCALLABLE)) { + if (! (state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) { RETVAL = S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE); have_obj = 1; @@ -1653,7 +1755,7 @@ ithread_object(...) UV -ithread__handle(...); +_handle(...); PREINIT: ithread *thread; CODE: @@ -1668,7 +1770,7 @@ ithread__handle(...); IV -ithread_get_stack_size(...) +get_stack_size(...) PREINIT: IV stack_size; dMY_POOL; @@ -1687,7 +1789,7 @@ ithread_get_stack_size(...) IV -ithread_set_stack_size(...) +set_stack_size(...) PREINIT: IV old_size; dMY_POOL; @@ -1709,7 +1811,7 @@ ithread_set_stack_size(...) SV* -ithread_is_running(...) +is_running(...) PREINIT: ithread *thread; CODE: @@ -1726,7 +1828,7 @@ ithread_is_running(...) SV* -ithread_is_detached(...) +is_detached(...) PREINIT: ithread *thread; CODE: @@ -1739,7 +1841,7 @@ ithread_is_detached(...) SV* -ithread_is_joinable(...) +is_joinable(...) PREINIT: ithread *thread; CODE: @@ -1751,14 +1853,14 @@ ithread_is_joinable(...) thread = INT2PTR(ithread *, SvIV(SvRV(ST(0)))); MUTEX_LOCK(&thread->mutex); RETVAL = ((thread->state & PERL_ITHR_FINISHED) && - ! (thread->state & PERL_ITHR_UNCALLABLE)) + ! (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) ? &PL_sv_yes : &PL_sv_no; MUTEX_UNLOCK(&thread->mutex); OUTPUT: RETVAL SV* -ithread_wantarray(...) +wantarray(...) PREINIT: ithread *thread; CODE: @@ -1771,7 +1873,7 @@ ithread_wantarray(...) void -ithread_set_thread_exit_only(...) +set_thread_exit_only(...) PREINIT: ithread *thread; CODE: @@ -1795,7 +1897,7 @@ ithread_set_thread_exit_only(...) SV* -ithread_error(...) +error(...) PREINIT: ithread *thread; SV *err = NULL; diff --git a/dump.c b/dump.c index 067976a8b1cc..19e1520ac983 100644 --- a/dump.c +++ b/dump.c @@ -2945,14 +2945,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (isREGEXP(sv)) goto dumpregexp; if (!isGV_with_GP(sv)) break; - { + if (GvNAME_HEK(sv)) { SV* tmpsv = newSVpvs_flags("", SVs_TEMP); dump_indent(level, file, " NAME = \"%s\"\n", generic_pv_escape(tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv))); + dump_indent(level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv)); } - dump_indent(level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv)); + dump_indent(level, file, " GvNAME_HEK = 0x%" UVxf "\n", (UV)GvNAME_HEK(sv)); do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); dump_indent(level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv)); dump_indent(level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv))); diff --git a/embed.fnc b/embed.fnc index 77034d34d39c..e4a65e3e4077 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3259,7 +3259,7 @@ EXpx |char * |scan_word |NN char *s \ Cp |U64 |seed : Only used by perl.c/miniperl.c, but defined in caretx.c ep |void |set_caret_X -CTdp |void |set_context |NN void *t +CTdp |void |set_context |NULLOK void *t Adp |void |setdefout |NN GV *gv Tp |void |setfd_cloexec |int fd p |void |setfd_cloexec_for_nonsysfd \ diff --git a/embedvar.h b/embedvar.h index 3784a7e50d44..a316f2f569e3 100644 --- a/embedvar.h +++ b/embedvar.h @@ -357,6 +357,7 @@ # define PL_utf8_xidstart (vTHX->Iutf8_xidstart) # define PL_utf8cache (vTHX->Iutf8cache) # define PL_utf8locale (vTHX->Iutf8locale) +# define PL_veto_switch_non_tTHX_context (vTHX->Iveto_switch_non_tTHX_context) # define PL_warn_locale (vTHX->Iwarn_locale) # define PL_warnhook (vTHX->Iwarnhook) # define PL_watchaddr (vTHX->Iwatchaddr) diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 3343bb842fc8..bfb3d5059d79 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -493,6 +493,7 @@ do_test('typeglob', FLAGS = \\(MULTI(?:,IN_PAD)?\\) NAME = "a" NAMELEN = 1 + GvNAME_HEK = $ADDR GvSTASH = $ADDR\\t"main" FLAGS = $ADDR # $] >=5.021004 GP = $ADDR diff --git a/gv.c b/gv.c index 551794cf6fbd..6248b1b5d2a5 100644 --- a/gv.c +++ b/gv.c @@ -2160,9 +2160,9 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, HV *hv; I32 i; if (!PL_psig_name) { - Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); - Newxz(PL_psig_pend, SIG_SIZE, int); - PL_psig_ptr = PL_psig_name + SIG_SIZE; + Newxz(PL_psig_name, SIG_SIZE, SV*); + Newxz(PL_psig_ptr, SIG_SIZE, PERL_ATOMIC(SV*)); + Newxz(PL_psig_pend, SIG_SIZE, PERL_ATOMIC(int)); } else { /* I think that the only way to get here is to re-use an embedded perl interpreter, where the previous @@ -2173,8 +2173,9 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, interpreter structure that something else will crash before we get here. I suspect that this is one of those "doctor, it hurts when I do this" bugs. */ - Zero(PL_psig_name, 2 * SIG_SIZE, SV*); - Zero(PL_psig_pend, SIG_SIZE, int); + Zero(PL_psig_name, SIG_SIZE, SV*); + Zero(PL_psig_ptr, SIG_SIZE, PERL_ATOMIC(SV*)); + Zero(PL_psig_pend, SIG_SIZE, PERL_ATOMIC(int)); } GvMULTI_on(gv); hv = GvHVn(gv); diff --git a/intrpvar.h b/intrpvar.h index 0e8dbade138c..fec5c94ac07b 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -529,8 +529,9 @@ PERLVAR(I, statusvalue_vms, U32) PERLVAR(I, statusvalue_posix, I32) #endif -PERLVARI(I, sig_pending, int, 0) /* Number if highest signal pending */ -PERLVAR(I, psig_pend, int *) /* per-signal "count" of pending */ +/* Number of signals pending */ +PERLVARI(I, sig_pending, PERL_ATOMIC(int), 0) +PERLVAR(I, psig_pend, PERL_ATOMIC(int) *) /* per-signal "count" of pending */ /* shortcuts to various I/O objects */ PERLVAR(I, stdingv, GV *) /* *STDIN */ @@ -868,10 +869,9 @@ PERLVARI(I, ctype_name, const char *, NULL) /* Name of current ctype locale */ /* Array of signal handlers, indexed by signal number, through which the C signal handler dispatches. */ -PERLVAR(I, psig_ptr, SV **) +PERLVAR(I, psig_ptr, PERL_ATOMIC(SV*) *) /* Array of names of signals, indexed by signal number, for (re)use as the first - argument to a signal handler. Only one block of memory is allocated for - both psig_name and psig_ptr. */ + argument to a signal handler. */ PERLVAR(I, psig_name, SV **) #if defined(PERL_IMPLICIT_SYS) @@ -904,6 +904,13 @@ PERLVAR(I, stashpad, HV **) /* for CopSTASH */ PERLVARI(I, stashpadmax, PADOFFSET, 64) PERLVARI(I, stashpadix, PADOFFSET, 0) PERLVARI(I, env_mutex_depth, int, 0) /* Emulate general semaphore */ + +/* This is set when switching to a thread's context while starting to + * free that thread: don't switch any other stuff too (currently just the + * thread-specific locale) because that stuff is in the middle of being + * freed also, and so may not be viable. + */ +PERLVARI(I, veto_switch_non_tTHX_context, int, FALSE) #endif #ifdef USE_REENTRANT_API diff --git a/mg.c b/mg.c index 6ac3472183f0..c46b50fffa96 100644 --- a/mg.c +++ b/mg.c @@ -1491,15 +1491,19 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) return 0; } + #ifdef HAS_SIGPROCMASK static void restore_sigmask(pTHX_ void *ptr) { SV *save_sv = (SV *)ptr; - const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv ); + const sigset_t * const ossetp = + (const sigset_t *) SvPV_nolen_const( save_sv ); (void)sigprocmask(SIG_SETMASK, ossetp, NULL); } #endif + + int Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) { @@ -1519,25 +1523,31 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) sv_setsv(sv,PL_psig_ptr[i]); else { Sighandler_t sigstate = rsignal_state(i); + #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN; #endif + #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL; #endif + /* cache state so we don't fetch it again */ if(sigstate == (Sighandler_t) SIG_IGN) sv_setpvs(sv,"IGNORE"); else sv_set_undef(sv); + PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); SvTEMP_off(sv); } } return 0; } + + int Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) { @@ -1567,6 +1577,7 @@ Perl_csighandler(int sig) } #endif + Signal_t Perl_csighandler1(int sig) { @@ -1575,6 +1586,7 @@ Perl_csighandler1(int sig) Perl_csighandler3(sig, NULL, NULL); } + /* Handler intended to directly handle signal calls from the kernel. * (Depending on configuration, the kernel may actually call one of the * wrappers csighandler() or csighandler1() instead.) @@ -1606,26 +1618,29 @@ Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSE #endif #ifdef PERL_USE_3ARG_SIGHANDLER -#if defined(__cplusplus) && defined(__GNUC__) +# if defined(__cplusplus) && defined(__GNUC__) /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap * parameters would be warned about. */ PERL_UNUSED_ARG(sip); PERL_UNUSED_ARG(uap); -#endif +# endif #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS (void) rsignal(sig, PL_csighandlerp); - if (PL_sig_ignoring[sig]) return; + if (PL_sig_ignoring[sig]) + return; #endif + #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS if (PL_sig_defaulting[sig]) -#ifdef KILL_BY_SIGPRC +# ifdef KILL_BY_SIGPRC exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG); -#else +# else exit(1); +# endif #endif -#endif + if ( #ifdef SIGILL sig == SIGILL || @@ -1639,27 +1654,31 @@ Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSE #ifdef SIGFPE sig == SIGFPE || #endif - (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) + (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + ) { /* Call the perl level handler now-- * with risk we may be in malloc() or being destructed etc. */ - { + if (PL_sighandlerp == Perl_sighandler) /* default handler, so can call perly_sighandler() directly * rather than via Perl_sighandler, passing the extra * 'safe = false' arg */ Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */); - else + else { #ifdef PERL_USE_3ARG_SIGHANDLER (*PL_sighandlerp)(sig, NULL, NULL); #else (*PL_sighandlerp)(sig); #endif + } } else { - if (!PL_psig_pend) return; - /* Set a flag to say this signal is pending, that is awaiting delivery after - * the current Perl opcode completes */ + if (!PL_psig_pend) + return; + + /* Set a flag to say this signal is pending, that is awaiting + * delivery after the current Perl opcode completes */ PL_psig_pend[sig]++; #ifndef SIG_PENDING_DIE_COUNT @@ -1672,27 +1691,33 @@ Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSE } } + #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) void Perl_csighandler_init(void) { int sig; - if (PL_sig_handlers_initted) return; + if (PL_sig_handlers_initted) + return; for (sig = 1; sig < SIG_SIZE; sig++) { -#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS + +# ifdef FAKE_DEFAULT_SIGNAL_HANDLERS dTHX; PL_sig_defaulting[sig] = 1; (void) rsignal(sig, PL_csighandlerp); -#endif -#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS +# endif + +# ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[sig] = 0; -#endif +# endif + } PL_sig_handlers_initted = 1; } #endif + #if defined HAS_SIGPROCMASK static void unblock_sigmask(pTHX_ void* newset) @@ -1702,6 +1727,7 @@ unblock_sigmask(pTHX_ void* newset) } #endif + void Perl_despatch_signals(pTHX) { @@ -1709,9 +1735,11 @@ Perl_despatch_signals(pTHX) int sig; PL_sig_pending = 0; + for (sig = 1; sig < SIG_SIZE; sig++) { if (PL_psig_pend[sig]) { dSAVE_ERRNO; + #ifdef HAS_SIGPROCMASK /* From sigaction(2) (FreeBSD man page): * | Signal routines normally execute with the signal that @@ -1734,6 +1762,7 @@ Perl_despatch_signals(pTHX) SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv)); } #endif + PL_psig_pend[sig] = 0; if (PL_sighandlerp == Perl_sighandler) /* default handler, so can call perly_sighandler() directly @@ -1757,6 +1786,7 @@ Perl_despatch_signals(pTHX) } } + /* sv of NULL signifies that we're acting as magic_clearsig. */ int Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) @@ -1815,6 +1845,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) } return 0; } + #ifdef HAS_SIGPROCMASK /* Avoid having the signal arrive at a bad time, if possible. */ sigemptyset(&set); @@ -1825,16 +1856,21 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) SAVEFREESV(save_sv); SAVEDESTRUCTOR_X(restore_sigmask, save_sv); #endif + PERL_ASYNC_CHECK(); + #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) if (!PL_sig_handlers_initted) Perl_csighandler_init(); #endif + #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[i] = 0; #endif + #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 0; #endif + to_dec = PL_psig_ptr[i]; if (sv) { PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); @@ -1857,6 +1893,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) PL_psig_ptr[i] = NULL; } } + if (sv && (isGV_with_GP(sv) || SvROK(sv))) { if (i) { (void)rsignal(i, PL_csighandlerp); @@ -1864,12 +1901,15 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) else { *svp = SvREFCNT_inc_simple_NN(sv); } - } else { + } + else { if (sv && SvOK(sv)) { s = SvPV_force(sv, len); - } else { + } + else { sv = NULL; } + if (sv && memEQs(s, len,"IGNORE")) { if (i) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS @@ -1910,10 +1950,12 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if(i) LEAVE; #endif + SvREFCNT_dec(to_dec); return 0; } + int Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg) { @@ -1932,6 +1974,7 @@ Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg) return 0; } + int Perl_magic_clearhook(pTHX_ SV *sv, MAGIC *mg) { diff --git a/op.c b/op.c index a007149ae9d1..e90fde1ca410 100644 --- a/op.c +++ b/op.c @@ -17060,10 +17060,9 @@ Perl_rcpv_free(pTHX_ char *pv) return NULL; RCPV *rcpv = RCPVx(pv); + OP_REFCNT_LOCK; assert(rcpv->refcount); assert(rcpv->len); - - OP_REFCNT_LOCK; if (--rcpv->refcount == 0) { rcpv->len = 0; PerlMemShared_free(rcpv); diff --git a/perl.c b/perl.c index 59dd10fe3a23..6870e7211151 100644 --- a/perl.c +++ b/perl.c @@ -1507,13 +1507,14 @@ perl_destruct(pTHXx) free_tied_hv_pool(); Safefree(PL_op_mask); Safefree(PL_psig_name); - PL_psig_name = (SV**)NULL; - PL_psig_ptr = (SV**)NULL; + PL_psig_name = NULL; + Safefree(PL_psig_ptr); + PL_psig_ptr = NULL; { /* We need to NULL PL_psig_pend first, so that signal handlers know not to use it */ - int *psig_save = PL_psig_pend; - PL_psig_pend = (int*)NULL; + PERL_ATOMIC(int) *psig_save = PL_psig_pend; + PL_psig_pend = NULL; Safefree(psig_save); } nuke_stacks(); @@ -2065,6 +2066,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_RELOCATABLE_INCPUSH " PERL_RELOCATABLE_INCPUSH" # endif +# ifdef PERL_USE_ATOMIC + " PERL_USE_ATOMIC" +# endif # ifdef PERL_USE_DEVEL " PERL_USE_DEVEL" # endif diff --git a/perl.h b/perl.h index 1b5d355d0491..71aa8d312740 100644 --- a/perl.h +++ b/perl.h @@ -1416,6 +1416,33 @@ typedef enum { /* Use all the "standard" definitions */ #include +/* Define PERL_ATOMIC as a type modifier which, on platforms which support + * it, makes the type atomic: e.g. + * + * PERL_ATOMIC(int) i = 0; + * i += 2; // thread-safe + * + * Not ready for production use, so currently only enabled manually rather + * than via a Configure probe. + */ +#ifdef PERL_USE_ATOMIC +# ifdef __cplusplus +# include +# define PERL_ATOMIC(atype) std::atomic +# else +# include + /* 2 indicates guaranteed to be lock-free */ +# if ATOMIC_INT_LOCK_FREE == 2 && ATOMIC_POINTER_LOCK_FREE == 2 +# define PERL_ATOMIC(atype) _Atomic(atype) +# endif +# endif +#endif + +#ifndef PERL_ATOMIC +# define PERL_ATOMIC(atype) atype +#endif + + /* If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD # if defined(__amigaos4__) @@ -6404,7 +6431,7 @@ INIT({ #ifdef USE_PERL_SWITCH_LOCALE_CONTEXT # define PERL_SET_LOCALE_CONTEXT(i) \ STMT_START { \ - if (LIKELY(! PL_veto_switch_non_tTHX_context)) \ + if (LIKELY(! (i)->Iveto_switch_non_tTHX_context)) \ Perl_switch_locale_context(i); \ } STMT_END @@ -6512,6 +6539,7 @@ INIT({ # define PERL_REENTRANT_UNLOCK(name, mutex, counter) \ STMT_START { \ + CLANG_DIAG_IGNORE(-Wthread-safety) \ if (LIKELY(counter == 1)) { \ UNLESS_PERL_MEM_LOG(DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ "%s: %d: unlocking " name "; new lock depth=0\n", \ diff --git a/perlvars.h b/perlvars.h index 7b0c01a43f30..005cd5f5dfd8 100644 --- a/perlvars.h +++ b/perlvars.h @@ -117,6 +117,11 @@ PERLVAR(G, locale_mutex, perl_RnW1_mutex_t) /* Mutex related to locale handlin #endif #ifdef USE_POSIX_2008_LOCALE +/* This variable is is initialised just once, at process start-up time, to + * the value of newlocale(..., "C",...) and is unchanged afterwards. It + * provides an always-present "C" thread locale which any thread can + * switch to. + */ PERLVARI(G, C_locale_obj, locale_t, NULL) #endif @@ -181,7 +186,6 @@ PERLVAR(G, check_mutex, perl_mutex) /* Mutex for PL_check */ #ifdef MULTIPLICITY # ifdef USE_ITHREADS PERLVAR(G, my_ctx_mutex, perl_mutex) -PERLVARI(G, veto_switch_non_tTHX_context, int, FALSE) # endif PERLVARI(G, my_cxt_index, int, 0) #endif diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 1ff14a7b014d..762663f7e58f 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -371,6 +371,9 @@ manager will later use a regex to expand these into links. =item * +Many potential threads-related race conditions have been fixed in the perl +core and the two L and L modules. + XXX =back diff --git a/proto.h b/proto.h index 3becac47aec8..41bc9c724c35 100644 --- a/proto.h +++ b/proto.h @@ -5705,10 +5705,8 @@ Perl_set_caret_X(pTHX) Perl_assert_aTHX PERL_CALLCONV void -Perl_set_context(void *t) - Perl_attribute_nonnull(1); -#define PERL_ARGS_ASSERT_SET_CONTEXT \ - assert(t) +Perl_set_context(void *t); +#define PERL_ARGS_ASSERT_SET_CONTEXT PERL_CALLCONV void Perl_set_numeric_standard(pTHX_ const char *file, const line_t caller_line) diff --git a/sv.c b/sv.c index 6806d90e313c..dc97f8ca04c8 100644 --- a/sv.c +++ b/sv.c @@ -16547,6 +16547,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PERL_ARGS_ASSERT_PERL_CLONE; #endif /* PERL_IMPLICIT_SYS */ + /* Set this very early - it will shortly be overwritten by the + * PoisonNew below and need setting again, but it must be set before + * PERL_SET_THX() is called */ + PL_veto_switch_non_tTHX_context = false; + /* for each stash, determine whether its objects should be cloned */ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); my_perl->Iphase = PERL_PHASE_CONSTRUCT; @@ -16579,6 +16584,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Zero(my_perl, 1, PerlInterpreter); #endif /* DEBUGGING */ + PL_veto_switch_non_tTHX_context = false; + #ifdef PERL_IMPLICIT_SYS /* host pointers */ PL_Mem = ipM; @@ -17137,21 +17144,29 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif if (proto_perl->Ipsig_pend) { - Newxz(PL_psig_pend, SIG_SIZE, int); + Newxz(PL_psig_pend, SIG_SIZE, PERL_ATOMIC(int)); } else { - PL_psig_pend = (int*)NULL; + PL_psig_pend = NULL; } if (proto_perl->Ipsig_name) { - Newx(PL_psig_name, 2 * SIG_SIZE, SV*); - sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE, + Newx(PL_psig_name, SIG_SIZE, SV*); + Newx(PL_psig_ptr, SIG_SIZE, PERL_ATOMIC(SV*)); + sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, SIG_SIZE, param); - PL_psig_ptr = PL_psig_name + SIG_SIZE; + /* Can't use sv_dup_inc_multiple() here as we're dealing with + * atomic pointers, which may not necessarily be the same + * size etc as ordinary pointers */ + PERL_ATOMIC(SV*)* src = proto_perl->Ipsig_ptr; + PERL_ATOMIC(SV*)* dst = PL_psig_ptr; + for (SSize_t i = 0; i< SIG_SIZE; i++) { + *dst++ = sv_dup_inc(*src++, param); + } } else { - PL_psig_ptr = (SV**)NULL; - PL_psig_name = (SV**)NULL; + PL_psig_ptr = NULL; + PL_psig_name = NULL; } if (flags & CLONEf_COPY_STACKS) { diff --git a/t/porting/cpphdrcheck.t b/t/porting/cpphdrcheck.t index 861fe176d5c9..e104a213079c 100644 --- a/t/porting/cpphdrcheck.t +++ b/t/porting/cpphdrcheck.t @@ -1,4 +1,38 @@ #!perl -w +# +# Test perl's headers with C++ compilers. +# +# This searches for a C++ compiler based on the supplied C compiler, and +# checks that compiler for any options controlling the C++ standard +# requested, including simple checks that the compiler supports that +# standard. +# +# If a C++ compiler is found, test compilation of the same simple code +# as above but with the perl headers included after any C++ headers. +# +# Ideally we'd also test runtime, but would require more complex test +# code, which is left to later contributors. +# +# Tested at various times with: +# +# - MSVC +# - gcc +# - clang +# - Oracle/Sun Development Workshop cc (CC is the C++ compiler), on +# Oracle Linux +# - Intel oneAPI compiler (llvm based apparently, and now free to use) +# - Intel classic compiler (discontinued) +# +# Currently this probes the compiler for C++ sanity with the perl +# ccflags, since icc (Intel classic) would successfully build the sample +# without perl's ccflags, but then fail with both the headers and perl's +# ccflags. It turned out to fail with just the ccflags, and since the +# primary intent is to test the headers, I probe *with* ccflags. +# +# The Sun Workshop compiler failed to build the C++11 or 14 sample at +# all in my testing, which may have been due to an installation problem. + + BEGIN { chdir "t" if -d "t"; require './test.pl'; diff --git a/win32/win32thread.c b/win32/win32thread.c index ec1d83f932e8..fee34bec29ec 100644 --- a/win32/win32thread.c +++ b/win32/win32thread.c @@ -17,8 +17,10 @@ Perl_set_context(void *t) TlsSetValue(PL_thr_key,t); SetLastError(err); # endif - dTHXa(t); - PL_sys_intern.cur_tid = GetCurrentThreadId(); + if (t) { + dTHXa(t); + PL_sys_intern.cur_tid = GetCurrentThreadId(); + } #endif }