# if defined(USE_NO_MINGW_SETJMP_TWO_ARGS) || (!defined(__BORLANDC__) && !defined(__MINGW64__))
# define setjmp(x) _setjmp(x)
# endif
+# if defined(__MINGW64__)
+# define setjmp(x) _setjmpex((x), mingw_getsp())
+# endif
#endif
#ifdef HAS_PPPORT_H
# define NEED_PL_signals
# include "ppport.h"
# include "threads.h"
#endif
+#ifndef sv_dup_inc
+# define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
+#endif
#ifdef USE_ITHREADS
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 */
return (0);
int
ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
{
+ PERL_UNUSED_ARG(param);
S_ithread_count_inc(aTHX_ (ithread *)mg->mg_ptr);
return (0);
}
*/
STATIC ithread *
S_ithread_create(
- pTHX_ SV *init_function,
+ PerlInterpreter *parent_perl,
+ SV *init_function,
IV stack_size,
int gimme,
int exit_opt,
- SV **params_start,
- SV **params_end)
+ int params_start,
+ int num_params)
{
+ dTHXa(parent_perl);
ithread *thread;
ithread *current_thread = S_ithread_get(aTHX);
AV *params;
* context for the duration of our work for new interpreter.
*/
{
- CLONE_PARAMS clone_param;
-
+#if (PERL_VERSION > 13) || (PERL_VERSION == 13 && PERL_SUBVERSION > 1)
+ CLONE_PARAMS *clone_param = Perl_clone_params_new(aTHX, thread->interp);
+#else
+ CLONE_PARAMS clone_param_s;
+ CLONE_PARAMS *clone_param = &clone_param_s;
+#endif
dTHXa(thread->interp);
MY_CXT_CLONE;
+#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1)
+ clone_param->flags = 0;
+#endif
+
/* Here we remove END blocks since they should only run in the thread
* they are created
*/
SvREFCNT_dec(PL_endav);
- PL_endav = newAV();
+ 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 =
- SvREFCNT_inc(sv_dup(init_function, &clone_param));
+ thread->init_function = sv_dup_inc(init_function, clone_param);
}
thread->params = params = newAV();
- av_extend(params, params_end - params_start - 1);
- AvFILLp(params) = params_end - params_start - 1;
+ av_extend(params, num_params - 1);
+ AvFILLp(params) = num_params - 1;
array = AvARRAY(params);
- while (params_start < params_end) {
- *array++ = SvREFCNT_inc(sv_dup(*params_start++, &clone_param));
+
+ /* params_start is an offset onto the Perl stack. This can be
+ reallocated (and hence move) as a side effect of calls to
+ perl_clone() and sv_dup_inc(). Hence copy the parameters
+ somewhere under our control first, before duplicating. */
+#if (PERL_VERSION > 8)
+ Copy(parent_perl->Istack_base + params_start, array, num_params, SV *);
+#else
+ Copy(parent_perl->Tstack_base + params_start, array, num_params, SV *);
+#endif
+ while (num_params--) {
+ *array = sv_dup_inc(*array, clone_param);
+ ++array;
}
+#if (PERL_VERSION > 13) || (PERL_VERSION == 13 && PERL_SUBVERSION > 1)
+ Perl_clone_params_del(clone_param);
+#endif
#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7
/* The code below checks that anything living on the tmps stack and
SV *thread_exit_only;
char *str;
int idx;
- SV **args_start;
- SV **args_end;
dMY_POOL;
CODE:
if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID)));
}
- /* Function args */
- args_start = &ST(idx + 2);
- if (items > 2) {
- args_end = &ST(idx + items);
- } else {
- args_end = args_start;
- }
-
/* Create thread */
MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
thread = S_ithread_create(aTHX_ function_to_call,
stack_size,
context,
exit_opt,
- args_start,
- args_end);
+ ax + idx + 2,
+ items > 2 ? items - 2 : 0);
if (! thread) {
XSRETURN_UNDEF; /* Mutex already unlocked */
}
/* Get the return value from the call_sv */
/* Objects do not survive this process - FIXME */
if ((thread->gimme & G_WANT) != G_VOID) {
+#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1)
AV *params_copy;
PerlInterpreter *other_perl;
CLONE_PARAMS clone_params;
SvREFCNT_inc_void(params);
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
+#else
+ AV *params_copy;
+ PerlInterpreter *other_perl = thread->interp;
+ CLONE_PARAMS *clone_params = Perl_clone_params_new(other_perl, aTHX);
+
+ params_copy = thread->params;
+ 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);
+ S_ithread_set(aTHX_ current_thread);
+ Perl_clone_params_del(clone_params);
+ SvREFCNT_inc_void(params);
+ ptr_table_free(PL_ptr_table);
+ PL_ptr_table = NULL;
+#endif
}
/* If thread didn't die, then we can free its interpreter */
ithread *thread;
char *sig_name;
IV signal;
+ int no_handler = 1;
CODE:
/* Must have safe signals */
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
MUTEX_LOCK(&thread->mutex);
if (thread->interp) {
dTHXa(thread->interp);
- PL_psig_pend[signal]++;
- PL_sig_pending = 1;
+ if (PL_psig_pend && PL_psig_ptr[signal]) {
+ PL_psig_pend[signal]++;
+ PL_sig_pending = 1;
+ no_handler = 0;
+ }
+ } else {
+ /* Ignore signal to terminated thread */
+ no_handler = 0;
}
MUTEX_UNLOCK(&thread->mutex);
+ if (no_handler) {
+ Perl_croak(aTHX_ "Signal %s received in thread %"UVuf", but no signal handler set.", sig_name, thread->tid);
+ }
+
/* Return the thread to allow for method chaining */
ST(0) = ST(0);
/* XSRETURN(1); - implied */
/* If thread died, then clone the error into the calling thread */
if (thread->state & PERL_ITHR_DIED) {
+#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1)
PerlInterpreter *other_perl;
CLONE_PARAMS clone_params;
ithread *current_thread;
}
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
+#else
+ PerlInterpreter *other_perl = thread->interp;
+ CLONE_PARAMS *clone_params = Perl_clone_params_new(other_perl, aTHX);
+ ithread *current_thread;
+
+ clone_params->flags |= CLONEf_JOIN_IN;
+ PL_ptr_table = ptr_table_new();
+ current_thread = S_ithread_get(aTHX);
+ 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);
+ err = sv_dup(thread->err, clone_params);
+ S_ithread_set(aTHX_ current_thread);
+ 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) {
+ sv_bless(err, gv_stashpv(thread->err_class, 1));
+ }
+ ptr_table_free(PL_ptr_table);
+ PL_ptr_table = NULL;
+#endif
}
MUTEX_UNLOCK(&thread->mutex);
https://perl5.git.perl.org / perl5.git / blobdiff