#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
#endif
/* Values for 'state' member */
-#define PERL_ITHR_DETACHED 1 /* thread has been detached */
-#define PERL_ITHR_JOINED 2 /* thread has been joined */
-#define PERL_ITHR_FINISHED 4 /* thread has finished execution */
+#define PERL_ITHR_DETACHED 1 /* Thread has been detached */
+#define PERL_ITHR_JOINED 2 /* Thread has been joined */
+#define PERL_ITHR_FINISHED 4 /* Thread has finished execution */
#define PERL_ITHR_THREAD_EXIT_ONLY 8 /* exit() only exits current thread */
-#define PERL_ITHR_NONVIABLE 16 /* thread creation failed */
-#define PERL_ITHR_DIED 32 /* thread finished by dying */
+#define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */
+#define PERL_ITHR_DIED 32 /* Thread finished by dying */
#define PERL_ITHR_UNCALLABLE (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)
PerlInterpreter *interp; /* The threads interpreter */
UV tid; /* Threads module's thread id */
perl_mutex mutex; /* Mutex for updating things in this struct */
- int count; /* reference count. See S_ithread_create */
+ int count; /* Reference count. See S_ithread_create. */
int state; /* Detached, joined, finished, etc. */
int gimme; /* Context of create */
SV *init_function; /* Code to run */
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 /* VMS */
+}
+
+/* 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 /* VMS */
+}
+#endif /* WIN32 */
/* Used by Perl interpreter for thread context switching */
STATIC void
/* Free any data (such as the Perl interpreter) attached to an ithread
* structure. This is a bit like undef on SVs, where the SV isn't freed,
- * but the PVX is. Must be called with thread->mutex already held.
+ * but the PVX is. Must be called with thread->mutex already locked. Also,
+ * must be called with MY_POOL.create_destruct_mutex unlocked as destruction
+ * of the interpreter can lead to recursive destruction calls that could
+ * lead to a deadlock on that mutex.
*/
STATIC void
S_ithread_clear(pTHX_ ithread *thread)
{
PerlInterpreter *interp;
+#ifndef WIN32
+ sigset_t origmask;
+#endif
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
}
/* Decrement the refcount of an ithread, and if it reaches zero, free it.
* Must be called with the mutex held.
- * On return, mutex is released (or destroyed) */
-
+ * On return, mutex is released (or destroyed).
+ */
STATIC void
S_ithread_free(pTHX_ ithread *thread)
{
MUTEX_UNLOCK(&thread->mutex);
return;
}
- assert((thread->state & PERL_ITHR_FINISHED)
- && (thread->state & PERL_ITHR_UNCALLABLE));
+ assert((thread->state & PERL_ITHR_FINISHED) &&
+ (thread->state & PERL_ITHR_UNCALLABLE));
}
MUTEX_UNLOCK(&thread->mutex);
thread->prev->next = thread->next;
thread->next = NULL;
thread->prev = NULL;
-
- /* after decrementing this thread count and unlocking the MUTEX, this
- * thread must not make any further use of MY_POOL, as it may be freed
- */
- MY_POOL.total_threads--;
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
/* Thread is now disowned */
}
#endif
- /* Call PerlMemShared_free() in the context of the "first" interpreter
- * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
- */
- aTHX = MY_POOL.main_thread.interp;
PerlMemShared_free(thread);
-}
+ /* total_threads >= 1 is used to veto cleanup by the main thread,
+ * should it happen to exit while other threads still exist.
+ * Decrement this as the very last thing in the thread's existence.
+ * Otherwise, MY_POOL and global state such as PL_op_mutex may get
+ * freed while we're still using it.
+ */
+ MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
+ MY_POOL.total_threads--;
+ MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
+}
static void
}
-
/* Warn if exiting with any unjoined threads */
STATIC int
S_exit_warning(pTHX)
return (veto_cleanup);
}
-/* Called on exit from main thread */
+
+/* Called from perl_destruct() in each thread. If it's the main thread,
+ * stop it from freeing everything if there are other threads still running.
+ */
int
Perl_ithread_hook(pTHX)
{
{
ithread *thread = (ithread *)mg->mg_ptr;
MUTEX_LOCK(&thread->mutex);
- S_ithread_free(aTHX_ thread); /* releases MUTEX */
+ S_ithread_free(aTHX_ thread); /* Releases MUTEX */
return (0);
}
-
int
ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
{
# 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));
}
}
my_exit(exit_code);
}
+ /* At this point, the interpreter may have been freed, so call
+ * free in the the context of of the 'main' interpreter which
+ * can't have been freed due to the veto_cleanup mechanism.
+ */
+ aTHX = MY_POOL.main_thread.interp;
+
MUTEX_LOCK(&thread->mutex);
- S_ithread_free(aTHX_ thread); /* releases MUTEX */
+ S_ithread_free(aTHX_ thread); /* Releases MUTEX */
#ifdef WIN32
return ((DWORD)0);
thread->prev->next = thread;
MY_POOL.total_threads++;
- /* 1 ref to be held by the local var 'thread' in S_ithread_run()
+ /* 1 ref to be held by the local var 'thread' in S_ithread_run().
* 1 ref to be held by the threads object that we assume we will
- * be embedded in upon our return
- * 1 ref to be the responsibility of join/detach, so we don't get freed
- until join/detach, even if no thread objects remain. This
- allows the following to work:
- { threads->new(sub{...}); } threads->object(1)->join;
+ * be embedded in upon our return.
+ * 1 ref to be the responsibility of join/detach, so we don't get
+ * freed until join/detach, even if no thread objects remain.
+ * This allows the following to work:
+ * { threads->create(sub{...}); } threads->object(1)->join;
*/
thread->count = 3;
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 */
{
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
sv_2mortal(params);
thread->state |= PERL_ITHR_NONVIABLE;
- S_ithread_free(aTHX_ thread); /* releases MUTEX */
+ S_ithread_free(aTHX_ thread); /* Releases MUTEX */
#ifndef WIN32
if (ckWARN_d(WARN_THREADS)) {
if (rc_stack_size) {
CODE:
if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
if (--items < 2) {
- Perl_croak(aTHX_ "Usage: threads->create(\\%specs, function, ...)");
+ Perl_croak(aTHX_ "Usage: threads->create(\\%%specs, function, ...)");
}
specs = (HV*)SvRV(ST(1));
idx = 1;
/* 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;
}
switch (*str) {
case 'a':
case 'A':
+ case 'l':
+ case 'L':
context = G_ARRAY;
break;
case 's':
if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) {
context = G_ARRAY;
}
+ } else if (hv_exists(specs, "list", 4)) {
+ if (SvTRUE(*hv_fetch(specs, "list", 4, 0))) {
+ context = G_ARRAY;
+ }
} else if (hv_exists(specs, "scalar", 6)) {
if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) {
context = G_SCALAR;
ithread *thread;
ithread *current_thread;
int join_err;
- AV *params;
+ AV *params = NULL;
int len;
int ii;
-#ifdef WIN32
- DWORD waitcode;
-#else
+#ifndef WIN32
int rc_join;
void *retval;
#endif
MUTEX_LOCK(&thread->mutex);
/* Get the return value from the call_sv */
/* Objects do not survive this process - FIXME */
- {
+ if ((thread->gimme & G_WANT) != G_VOID) {
AV *params_copy;
PerlInterpreter *other_perl;
CLONE_PARAMS clone_params;
if (! (thread->state & PERL_ITHR_DIED)) {
S_ithread_clear(aTHX_ thread);
}
- S_ithread_free(aTHX_ thread); /* releases MUTEX */
+ S_ithread_free(aTHX_ thread); /* Releases MUTEX */
/* If no return values, then just return */
if (! params) {
{
S_ithread_clear(aTHX_ thread);
}
- S_ithread_free(aTHX_ thread); /* releases MUTEX */
-
+ S_ithread_free(aTHX_ thread); /* Releases MUTEX */
void
if (sv_isobject(ST(0))) {
Perl_croak(aTHX_ "Cannot change stack size of an existing thread");
}
+ if (! looks_like_number(ST(1))) {
+ Perl_croak(aTHX_ "Stack size must be numeric");
+ }
old_size = MY_POOL.default_stack_size;
MY_POOL.default_stack_size = S_good_stack_size(aTHX_ SvIV(ST(1)));
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 */