From: Vincent Pit Date: Mon, 20 Apr 2015 16:21:08 +0000 (-0300) Subject: Revamp cloned thread cleanup X-Git-Tag: rt104312~3 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=42991cca70b2f98cbfc9e7cd1470df0e40842a8d;p=perl%2Fmodules%2Findirect.git Revamp cloned thread cleanup And fix the third test in t/41-threads-teardown.t to actually test something. As a result, we see that the module actually catches indirect constructs inside eval STRING at global destruction time. --- diff --git a/indirect.xs b/indirect.xs index 45bb40e..ffb8a22 100644 --- a/indirect.xs +++ b/indirect.xs @@ -421,49 +421,10 @@ static void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { ptable_hints_store(ud->tbl, ent->key, h2); } -static void indirect_thread_cleanup(pTHX_ void *ud) { - int global_teardown; - dMY_CXT; - - global_teardown = indirect_clear_loaded_locked(&MY_CXT); - assert(!global_teardown); - - SvREFCNT_dec(MY_CXT.global_code); - MY_CXT.global_code = NULL; - - ptable_free(MY_CXT.map); - MY_CXT.map = NULL; - - ptable_hints_free(MY_CXT.tbl); - MY_CXT.tbl = NULL; -} - -static int indirect_endav_free(pTHX_ SV *sv, MAGIC *mg) { - SAVEDESTRUCTOR_X(indirect_thread_cleanup, NULL); - - return 0; -} - -static MGVTBL indirect_endav_vtbl = { - 0, - 0, - 0, - 0, - indirect_endav_free -#if MGf_COPY - , 0 -#endif -#if MGf_DUP - , 0 -#endif -#if MGf_LOCAL - , 0 -#endif -}; - #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION + static IV indirect_require_tag(pTHX) { #define indirect_require_tag() indirect_require_tag(aTHX) const CV *cv, *outside; @@ -507,6 +468,7 @@ get_enclosing_cv: return PTR2IV(cv); } + #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ static SV *indirect_tag(pTHX_ SV *value) { @@ -1046,11 +1008,6 @@ done: static void indirect_teardown(pTHX_ void *interp) { dMY_CXT; -#if I_MULTIPLICITY - if (aTHX != interp) - return; -#endif - I_LOADED_LOCK; if (indirect_clear_loaded_locked(&MY_CXT)) { @@ -1122,11 +1079,7 @@ static void indirect_setup(pTHX) { MY_CXT.global_code = NULL; } -#if I_MULTIPLICITY - call_atexit(indirect_teardown, aTHX); -#else call_atexit(indirect_teardown, NULL); -#endif return; } @@ -1150,7 +1103,6 @@ PROTOTYPE: DISABLE PREINIT: ptable *t; SV *global_code_dup; - GV *gv; PPCODE: { indirect_ptable_clone_ud ud; @@ -1175,26 +1127,9 @@ PPCODE: I_LOADED_UNLOCK; } } - gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV); - if (gv) { - CV *cv = GvCV(gv); - if (!PL_endav) - PL_endav = newAV(); - SvREFCNT_inc(cv); - if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv)) - SvREFCNT_dec(cv); - sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &indirect_endav_vtbl, NULL, 0); - } XSRETURN(0); -void -_THREAD_CLEANUP(...) -PROTOTYPE: DISABLE -PPCODE: - indirect_thread_cleanup(aTHX_ NULL); - XSRETURN(0); - -#endif +#endif /* I_THREADSAFE */ SV * _tag(SV *value) diff --git a/lib/indirect.pm b/lib/indirect.pm index d0f1068..ebdc061 100644 --- a/lib/indirect.pm +++ b/lib/indirect.pm @@ -250,8 +250,6 @@ If you use C 5.12 or greater, those constructs are correctly reported. With 5.8 perls, the pragma does not propagate into C. This is due to a shortcoming in the way perl handles the hints hash, which is addressed in perl 5.10. -Indirect constructs that appear in code C'd during the global destruction phase of a spawned thread or pseudo-fork (the processes used internally for the C emulation on Windows) are not reported. - The search for indirect method calls happens before constant folding. Hence C will be caught. diff --git a/t/41-threads-teardown.t b/t/41-threads-teardown.t index a5d45f6..8003fad 100644 --- a/t/41-threads-teardown.t +++ b/t/41-threads-teardown.t @@ -57,7 +57,7 @@ SKIP: { use threads::shared; my $code : shared; $code = 0; - no indirect cb => sub { lock $code; ++$code }; + no indirect hook => sub { lock $code; ++$code }; sub X3::DESTROY { eval $_[0]->{code} } threads->create(sub { my $x = bless { code => 'new Z3' }, 'X3'; @@ -67,5 +67,6 @@ SKIP: { exit $code; RUN skip RUN_PERL_FAILED() => 1 unless defined $status; - is $status, 0, 'indirect does not check eval STRING during global destruction at the end of a thread'; + my $code = $status >> 8; + is $code, 1, 'indirect checks eval STRING during global destruction at the end of a cloned thread'; }