#ifdef HAS_PPPORT_H
# define NEED_PL_signals
# define NEED_newRV_noinc
-# define NEED_sv_2pv_nolen
+# define NEED_sv_2pv_flags
# include "ppport.h"
# include "threads.h"
#endif
IV stack_size;
SV *err; /* Error from abnormally terminated thread */
char *err_class; /* Error object's classname if applicable */
+#ifndef WIN32
+ sigset_t initial_sigmask; /* Thread wakes up with signals blocked */
+#endif
} ithread;
#define MY_POOL (*my_poolp)
+#ifndef WIN32
+/* Block most signals for calling thread, setting the old signal mask to
+ * oldmask, if it is not NULL */
+STATIC int
+S_block_most_signals(sigset_t *oldmask)
+{
+ sigset_t newmask;
+
+ sigfillset(&newmask);
+ /* Don't block certain "important" signals (stolen from mg.c) */
+#ifdef SIGILL
+ sigdelset(&newmask, SIGILL);
+#endif
+#ifdef SIGBUS
+ sigdelset(&newmask, SIGBUS);
+#endif
+#ifdef SIGSEGV
+ sigdelset(&newmask, SIGSEGV);
+#endif
+
+#if defined(VMS)
+ /* no per-thread blocking available */
+ return sigprocmask(SIG_BLOCK, &newmask, oldmask);
+#else
+ return pthread_sigmask(SIG_BLOCK, &newmask, oldmask);
+#endif /* WIN32 */
+}
+
+/* Set the signal mask for this thread to newmask */
+STATIC int
+S_set_sigmask(sigset_t *newmask)
+{
+#if defined(VMS)
+ return sigprocmask(SIG_SETMASK, newmask, NULL);
+#else
+ return pthread_sigmask(SIG_SETMASK, newmask, NULL);
+#endif /* WIN32 */
+}
+#endif
/* Used by Perl interpreter for thread context switching */
STATIC void
S_ithread_clear(pTHX_ ithread *thread)
{
PerlInterpreter *interp;
+ sigset_t origmask;
assert(((thread->state & PERL_ITHR_FINISHED) &&
(thread->state & PERL_ITHR_UNCALLABLE))
||
(thread->state & PERL_ITHR_NONVIABLE));
+#ifndef WIN32
+ /* We temporarily set the interpreter context to the interpreter being
+ * destroyed. It's in no condition to handle signals while it's being
+ * taken apart.
+ */
+ S_block_most_signals(&origmask);
+#endif
+
interp = thread->interp;
if (interp) {
dTHXa(interp);
}
PERL_SET_CONTEXT(aTHX);
+#ifndef WIN32
+ S_set_sigmask(&origmask);
+#endif
}
# endif
if ((long)MY_POOL.page_size < 0) {
if (errno) {
- SV * const error = get_sv("@", FALSE);
+ SV * const error = get_sv("@", 0);
(void)SvUPGRADE(error, SVt_PV);
Perl_croak(aTHX_ "PANIC: sysconf: %s", SvPV_nolen(error));
} else {
PERL_SET_CONTEXT(thread->interp);
S_ithread_set(aTHX_ thread);
+#ifndef WIN32
+ /* Thread starts with most signals blocked - restore the signal mask from
+ * the ithread struct.
+ */
+ S_set_sigmask(&thread->initial_sigmask);
+#endif
+
PL_perl_destruct_level = 2;
{
}
JMPENV_POP;
+#ifndef WIN32
+ /* The interpreter is finished, so this thread can stop receiving
+ * signals. This way, our signal handler doesn't get called in the
+ * middle of our parent thread calling perl_destruct()...
+ */
+ S_block_most_signals(NULL);
+#endif
+
/* Remove args from stack and put back in params array */
SPAGAIN;
for (ii=len-1; ii >= 0; ii--) {
SV *sv = POPs;
- if (jmp_rc == 0) {
+ if (jmp_rc == 0 && (thread->gimme & G_WANT) != G_VOID) {
av_store(params, ii, SvREFCNT_inc(sv));
}
}
PL_srand_called = FALSE; /* Set it to false so we can detect if it gets
set during the clone */
+#ifndef WIN32
+ /* perl_clone() will leave us the new interpreter's context. This poses
+ * two problems for our signal handler. First, it sets the new context
+ * before the new interpreter struct is fully initialized, so our signal
+ * handler might find bogus data in the interpreter struct it gets.
+ * Second, even if the interpreter is initialized before a signal comes in,
+ * we would like to avoid that interpreter receiving notifications for
+ * signals (especially when they ought to be for the one running in this
+ * thread), until it is running in its own thread. Another problem is that
+ * the new thread will not have set the context until some time after it
+ * has started, so it won't be safe for our signal handler to run until
+ * that time.
+ *
+ * So we block most signals here, so the new thread will inherit the signal
+ * mask, and unblock them right after the thread creation. The original
+ * mask is saved in the thread struct so that the new thread can restore
+ * the original mask.
+ */
+ S_block_most_signals(&thread->initial_sigmask);
+#endif
+
#ifdef WIN32
thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
#else
thread->init_function = newSV(0);
sv_copypv(thread->init_function, init_function);
} else {
- thread->init_function = sv_dup(init_function, &clone_param);
- if (SvREFCNT(thread->init_function) == 0) {
- SvREFCNT_inc_void(thread->init_function);
- }
+ thread->init_function =
+ SvREFCNT_inc(sv_dup(init_function, &clone_param));
}
thread->params = sv_dup(params, &clone_param);
# endif
}
+#ifndef WIN32
+ /* Now it's safe to accept signals, since we're in our own interpreter's
+ * context and we have created the thread.
+ */
+ S_set_sigmask(&thread->initial_sigmask);
+#endif
+
# ifdef _POSIX_THREAD_ATTR_STACKSIZE
/* Try to get thread's actual stack size */
{
/* threads->create() */
classname = (char *)SvPV_nolen(ST(0));
stack_size = MY_POOL.default_stack_size;
- thread_exit_only = get_sv("threads::thread_exit_only", TRUE);
+ thread_exit_only = get_sv("threads::thread_exit_only", GV_ADD);
exit_opt = (SvTRUE(thread_exit_only))
? PERL_ITHR_THREAD_EXIT_ONLY : 0;
}
MUTEX_LOCK(&thread->mutex);
/* Get the return value from the call_sv */
/* Objects do not survive this process - FIXME */
- if (! (thread->gimme & G_VOID)) {
+ if ((thread->gimme & G_WANT) != G_VOID) {
AV *params_copy;
PerlInterpreter *other_perl;
CLONE_PARAMS clone_params;
CODE:
PERL_UNUSED_VAR(items);
thread = S_SV_to_ithread(aTHX_ ST(0));
- ST(0) = (thread->gimme & G_ARRAY) ? &PL_sv_yes :
- (thread->gimme & G_VOID) ? &PL_sv_undef
- /* G_SCALAR */ : &PL_sv_no;
+ ST(0) = ((thread->gimme & G_WANT) == G_ARRAY) ? &PL_sv_yes :
+ ((thread->gimme & G_WANT) == G_VOID) ? &PL_sv_undef
+ /* G_SCALAR */ : &PL_sv_no;
/* XSRETURN(1); - implied */
https://perl5.git.perl.org / perl5.git / blobdiff