# 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);
}
0, /* clear */
ithread_mg_free, /* free */
0, /* copy */
- ithread_mg_dup /* dup */
+ ithread_mg_dup, /* dup */
+#if (PERL_VERSION > 8) || (PERL_VERSION == 8 && PERL_SUBVERSION > 8)
+ 0 /* local */
+#endif
};
ithread *thread = (ithread *)arg;
int jmp_rc = 0;
I32 oldscope;
- int exit_app = 0; /* Thread terminated using 'exit' */
- int exit_code = 0;
+ volatile int exit_app = 0; /* Thread terminated using 'exit' */
+ volatile int exit_code = 0;
int died = 0; /* Thread terminated abnormally */
dJMPENV;
{
AV *params = thread->params;
- int len = (int)av_len(params)+1;
+ volatile int len = (int)av_len(params)+1;
int ii;
dSP;
*/
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;
PERL_SET_CONTEXT(aTHX);
if (!thread) {
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
- PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
+ int fd = PerlIO_fileno(Perl_error_log);
+ if (fd >= 0) {
+ /* If there's no error_log, we cannot scream about it missing. */
+ PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, strlen(PL_no_mem)));
+ }
my_exit(1);
}
Zero(thread, 1, ithread);
* context for the duration of our work for new interpreter.
*/
{
+#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
*/
}
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;
}
- Perl_clone_params_del(clone_param);
+#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;
+
+ params_copy = thread->params;
+ other_perl = thread->interp;
+ clone_params.stashes = newAV();
+ 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);
+ SvREFCNT_dec(clone_params.stashes);
+ 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);
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);
+ 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 */
/* Set the signal for the thread */
thread = S_SV_to_ithread(aTHX_ ST(0));
MUTEX_LOCK(&thread->mutex);
- if (thread->interp) {
+ if (thread->interp && ! (thread->state & PERL_ITHR_FINISHED)) {
dTHXa(thread->interp);
if (PL_psig_pend && PL_psig_ptr[signal]) {
PL_psig_pend[signal]++;
no_handler = 0;
}
} else {
- /* Ignore signal to terminated thread */
+ /* Ignore signal to terminated/finished thread */
no_handler = 0;
}
MUTEX_UNLOCK(&thread->mutex);
/* 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;
+
+ other_perl = thread->interp;
+ clone_params.stashes = newAV();
+ 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);
+ SvREFCNT_dec(clone_params.stashes);
+ 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;
+#else
PerlInterpreter *other_perl = thread->interp;
CLONE_PARAMS *clone_params = Perl_clone_params_new(other_perl, aTHX);
ithread *current_thread;
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);
+ 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) {
}
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
+#endif
}
MUTEX_UNLOCK(&thread->mutex);
https://perl5.git.perl.org / perl5.git / blobdiff