From: Nicholas Clark Date: Wed, 24 Feb 2010 11:47:08 +0000 (+0000) Subject: Abstract *correct* initialisation of CLONE_PARAMS into Perl_clone_params_new(). X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f7abe70be985cb9179c2e728a593cb8a5c8e049d;p=p5sagit%2Fp5-mst-13.2.git Abstract *correct* initialisation of CLONE_PARAMS into Perl_clone_params_new(). As it allocates memory dynamically, add Perl_clone_params_del(). This will allow CLONE_PARAMS to be expand in future in a source and binary compatible fashion. These implementations of Perl_clone_params_new()/Perl_clone_params_del() jump through hoops to remain source and binary compatible, in particular, by not assuming that the structure member is present and correctly initialised. Hence they should be suitable for inclusion into Devel::PPPort. Convert threads.xs to use them, resolving RT #73046. --- diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs index c97b6ab..f4e6946 100755 --- a/dist/threads/threads.xs +++ b/dist/threads/threads.xs @@ -774,7 +774,7 @@ S_ithread_create( * context for the duration of our work for new interpreter. */ { - CLONE_PARAMS clone_param; + CLONE_PARAMS *clone_param = Perl_clone_params_new(aTHX, thread->interp); dTHXa(thread->interp); @@ -786,13 +786,11 @@ S_ithread_create( SvREFCNT_dec(PL_endav); PL_endav = NULL; - clone_param.flags = 0; if (SvPOK(init_function)) { thread->init_function = newSV(0); sv_copypv(thread->init_function, init_function); } else { - thread->init_function = - sv_dup_inc(init_function, &clone_param); + thread->init_function = sv_dup_inc(init_function, clone_param); } thread->params = params = newAV(); @@ -800,8 +798,9 @@ S_ithread_create( AvFILLp(params) = params_end - params_start - 1; array = AvARRAY(params); while (params_start < params_end) { - *array++ = SvREFCNT_inc(sv_dup(*params_start++, &clone_param)); + *array++ = SvREFCNT_inc(sv_dup(*params_start++, clone_param)); } + Perl_clone_params_del(clone_param); #if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7 /* The code below checks that anything living on the tmps stack and @@ -1241,22 +1240,20 @@ ithread_join(...) /* Objects do not survive this process - FIXME */ if ((thread->gimme & G_WANT) != G_VOID) { AV *params_copy; - PerlInterpreter *other_perl; - CLONE_PARAMS clone_params; + PerlInterpreter *other_perl = thread->interp; + CLONE_PARAMS *clone_params = Perl_clone_params_new(other_perl, aTHX); params_copy = thread->params; - other_perl = thread->interp; - clone_params.stashes = newAV(); - clone_params.flags = CLONEf_JOIN_IN; + clone_params->flags |= CLONEf_JOIN_IN; PL_ptr_table = ptr_table_new(); S_ithread_set(aTHX_ thread); /* Ensure 'meaningful' addresses retain their meaning */ ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); - params = (AV *)sv_dup((SV*)params_copy, &clone_params); + params = (AV *)sv_dup((SV*)params_copy, clone_params); S_ithread_set(aTHX_ current_thread); - SvREFCNT_dec(clone_params.stashes); + Perl_clone_params_del(clone_params); SvREFCNT_inc_void(params); ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; @@ -1630,13 +1627,11 @@ ithread_error(...) /* If thread died, then clone the error into the calling thread */ if (thread->state & PERL_ITHR_DIED) { - PerlInterpreter *other_perl; - CLONE_PARAMS clone_params; + PerlInterpreter *other_perl = thread->interp; + CLONE_PARAMS *clone_params = Perl_clone_params_new(other_perl, aTHX); ithread *current_thread; - other_perl = thread->interp; - clone_params.stashes = newAV(); - clone_params.flags = CLONEf_JOIN_IN; + clone_params->flags |= CLONEf_JOIN_IN; PL_ptr_table = ptr_table_new(); current_thread = S_ithread_get(aTHX); S_ithread_set(aTHX_ thread); @@ -1644,9 +1639,9 @@ ithread_error(...) ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef); ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no); ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes); - err = sv_dup(thread->err, &clone_params); + err = sv_dup(thread->err, clone_params); S_ithread_set(aTHX_ current_thread); - SvREFCNT_dec(clone_params.stashes); + Perl_clone_params_del(clone_params); SvREFCNT_inc_void(err); /* If error was an object, bless it into the correct class */ if (thread->err_class) { diff --git a/embed.fnc b/embed.fnc index 6b3fd8f..b35ad7e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2355,6 +2355,11 @@ xpoM |struct refcounted_he *|store_cop_label \ xpo |int |keyword_plugin_standard|NN char* keyword_ptr|STRLEN keyword_len|NN OP** op_ptr +#if defined(USE_ITHREADS) +Aanop |CLONE_PARAMS *|clone_params_new|NN PerlInterpreter *const from \ + |NN PerlInterpreter *const to +Anop |void |clone_params_del|NN CLONE_PARAMS *param +#endif END_EXTERN_C /* * ex: set ts=8 sts=4 sw=4 noet: diff --git a/embed.h b/embed.h index 02871f2..819f76a 100644 --- a/embed.h +++ b/embed.h @@ -2043,6 +2043,8 @@ #ifdef PERL_CORE #define boot_core_mro Perl_boot_core_mro #endif +#if defined(USE_ITHREADS) +#endif #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_chdir Perl_ck_chdir @@ -4478,6 +4480,8 @@ #endif #ifdef PERL_CORE #endif +#if defined(USE_ITHREADS) +#endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_chdir(a) Perl_ck_chdir(aTHX_ a) diff --git a/global.sym b/global.sym index 25e43c9..8861fca 100644 --- a/global.sym +++ b/global.sym @@ -823,4 +823,6 @@ Perl_sys_init Perl_sys_init3 Perl_sys_term Perl_fetch_cop_label +Perl_clone_params_new +Perl_clone_params_del # ex: set ro: diff --git a/proto.h b/proto.h index fe487af..4efc502 100644 --- a/proto.h +++ b/proto.h @@ -6878,6 +6878,21 @@ PERL_CALLCONV int Perl_keyword_plugin_standard(pTHX_ char* keyword_ptr, STRLEN k assert(keyword_ptr); assert(op_ptr) +#if defined(USE_ITHREADS) +PERL_CALLCONV CLONE_PARAMS * Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) + __attribute__malloc__ + __attribute__warn_unused_result__ + __attribute__nonnull__(1) + __attribute__nonnull__(2); +#define PERL_ARGS_ASSERT_CLONE_PARAMS_NEW \ + assert(from); assert(to) + +PERL_CALLCONV void Perl_clone_params_del(CLONE_PARAMS *param) + __attribute__nonnull__(1); +#define PERL_ARGS_ASSERT_CLONE_PARAMS_DEL \ + assert(param) + +#endif END_EXTERN_C /* * ex: set ts=8 sts=4 sw=4 noet: diff --git a/sv.c b/sv.c index d0013ed..a1f7970 100644 --- a/sv.c +++ b/sv.c @@ -12012,7 +12012,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif /* PERL_IMPLICIT_SYS */ param->flags = flags; + /* Nothing in the core code uses this, but we make it available to + extensions (using mg_dup). */ param->proto_perl = proto_perl; + /* Likely nothing will use this, but it is initialised to be consistent + with Perl_clone_params_new(). */ + param->proto_perl = my_perl; INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl); @@ -12639,6 +12644,82 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, return my_perl; } +/* An initial implementation suitable for ppport.h, which doesn't make any + assumptions about a new structure member existing, and not being garbage. */ +#define CLONE_PARAMS_PRIVATE 0xFE60 + +void +Perl_clone_params_del(CLONE_PARAMS *param) +{ + PerlInterpreter *const was = PERL_GET_THX; + /* mg_find starts PERL_UNUSED_CONTEXT, so this first argument doesn't + actually matter. */ + MAGIC *mg = Perl_mg_find(param->proto_perl, MUTABLE_SV(param->stashes), + PERL_MAGIC_ext); + PerlInterpreter *const to = mg && mg->mg_private == CLONE_PARAMS_PRIVATE + ? (PerlInterpreter *) mg->mg_ptr : NULL; + + PERL_ARGS_ASSERT_CLONE_PARAMS_DEL; + + if (to) { + dTHXa(to); + + if (was != to) { + PERL_SET_THX(to); + } + + SvREFCNT_dec(param->stashes); + Safefree(param); + + if (was != to) { + PERL_SET_THX(was); + } + } else { + /* Have to assume/hope that this is going to work with whatever + interpreter we currently have set. Should never get here anyway. */ + dTHXa(PERL_GET_CONTEXT); + + SvREFCNT_dec(param->stashes); + Safefree(param); + } +} + +CLONE_PARAMS * +Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) +{ + /* Need to play this game, as newAV() can call safesysmalloc(), and that + does a dTHX; to get the context from thread local storage. + FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to + a version that passes in my_perl. */ + PerlInterpreter *const was = PERL_GET_THX; + CLONE_PARAMS *param; + MAGIC *mg; + + PERL_ARGS_ASSERT_CLONE_PARAMS_NEW; + + if (was != to) { + PERL_SET_THX(to); + } + + /* Given that we've set the context, we can do this unshared. */ + Newx(param, 1, CLONE_PARAMS); + + param->flags = 0; + param->proto_perl = from; + param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV); + AvREAL_off(param->stashes); + + mg = Perl_sv_magicext(to, MUTABLE_SV(param->stashes), 0, PERL_MAGIC_ext, + NULL, (char *)to, 0); + if (mg) + mg->mg_private = CLONE_PARAMS_PRIVATE; + + if (was != to) { + PERL_SET_THX(was); + } + return param; +} + #endif /* USE_ITHREADS */ /* diff --git a/t/op/threads.t b/t/op/threads.t index 956102a..d9fed9b 100644 --- a/t/op/threads.t +++ b/t/op/threads.t @@ -16,7 +16,7 @@ BEGIN { exit 0; } - plan(18); + plan(19); } use strict; @@ -237,4 +237,20 @@ fresh_perl_is(<<'EOI', 'ok', { }, 'Test for 34394ecd06e704e9'); print 'ok'; EOI +# This will fail in "interesting" ways if stashes in clone_params is not +# initialised correctly. +fresh_perl_like(<<'EOI', qr/\AThread 1 terminated abnormally: Not a CODE reference/, { }, 'RT #73046'); + use strict; + use threads; + + sub foo::bar; + + my %h = (1, *{$::{'foo::'}}{HASH}); + *{$::{'foo::'}} = {}; + + threads->create({}, delete $h{1})->join(); + + print "end"; +EOI + # EOF