* 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);
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();
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
/* 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;
/* 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);
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) {
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:
#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
#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)
Perl_sys_init3
Perl_sys_term
Perl_fetch_cop_label
+Perl_clone_params_new
+Perl_clone_params_del
# ex: set ro:
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:
#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);
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 */
/*
exit 0;
}
- plan(18);
+ plan(19);
}
use strict;
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
projects / p5sagit/p5-mst-13.2.git / commitdiff