Skip to content

Commit

Permalink
threads.xs DEBUG_U
Browse files Browse the repository at this point in the history
  • Loading branch information
@khwilliamson
khwilliamson committed Feb 2, 2023
1 parent e627744 commit 3de6ae2
Show file tree
Hide file tree
Showing 2 changed files with 58 additions and 0 deletions.
52 changes: 52 additions & 0 deletions dist/threads/threads.xs
View file
@@ -1,3 +1,17 @@
#define PERL_IN_THREADS_XS
#ifdef USE_POSIX_2008_LOCALE
# undef DEBUG_PRE_STMTS
# define DEBUG_PRE_STMTS dSAVE_ERRNO; dTHX; \
if (PL_cur_locale_obj == uselocale(0)) { \
PerlIO_printf(Perl_debug_log, "%s: %" LINE_Tf ": tid=%ld, state=%d, aTHX=%p, current locale=%p: ", __FILE__, __LINE__, thread->tid, thread->state, aTHX, PL_cur_locale_obj); \
} \
else { \
PerlIO_printf(Perl_debug_log, "%s: %" LINE_Tf ": tid=%ld, state=%d, aTHX=%p, PL_cur_locale_obj=%p, DIFFERS FROM actual=%p: ", __FILE__, __LINE__, thread->tid, thread->state, aTHX, PL_cur_locale_obj, uselocale(0)); \
}
# undef DEBUG_POST_STMTS
# define DEBUG_POST_STMTS RESTORE_ERRNO;
#endif

#define PERL_NO_GET_CONTEXT
/* Workaround for mingw 32-bit compiler by mingw-w64.sf.net - has to come before any #include.
* It also defines USE_NO_MINGW_SETJMP_TWO_ARGS for the mingw.org 32-bit compilers ... but
Expand Down Expand Up @@ -206,9 +220,11 @@ STATIC void
S_ithread_set(pTHX_ ithread *thread)
{
dMY_CXT;
DEBUG_U(PerlIO_printf(Perl_debug_log, "ithread_set about to set MY_CXT context to thread %p; tid=%ld\n", thread, thread->tid));
MY_CXT.context = thread;
#ifdef PERL_SET_NON_tTHX_CONTEXT
PERL_SET_NON_tTHX_CONTEXT(thread->interp);
DEBUG_U(PerlIO_printf(Perl_debug_log, "ithread_set just set MY_CXT context to thread\n"));
#endif
}

Expand All @@ -234,6 +250,7 @@ S_ithread_clear(pTHX_ ithread *thread)
#ifndef WIN32
sigset_t origmask;
#endif
DEBUG_U(PerlIO_printf(Perl_debug_log, "Entering clear\n"));

assert(((thread->state & PERL_ITHR_FINISHED) &&
(thread->state & PERL_ITHR_UNCALLABLE))
Expand All @@ -254,7 +271,9 @@ S_ithread_clear(pTHX_ ithread *thread)

interp = thread->interp;
if (interp) {
DEBUG_U(PerlIO_printf(Perl_debug_log, "clear: About to destroy current thread\n"));
dTHXa(interp);
DEBUG_U(PerlIO_printf(Perl_debug_log, "clear: new aTHX, about to set context\n"));

/* We will pretend to be a thread that we are not by switching tTHX,
* which doesn't work with things that don't rely on tTHX during
Expand All @@ -266,7 +285,9 @@ S_ithread_clear(pTHX_ ithread *thread)

PERL_SET_CONTEXT(interp);

DEBUG_U(PerlIO_printf(Perl_debug_log, "clear: Context set\n"));
S_ithread_set(aTHX_ thread);
DEBUG_U(PerlIO_printf(Perl_debug_log, "clear: thread set\n"));

SvREFCNT_dec(thread->params);
thread->params = NULL;
Expand Down Expand Up @@ -305,16 +326,20 @@ S_ithread_free(pTHX_ ithread *thread)
#endif
dMY_POOL;

DEBUG_U(PerlIO_printf(Perl_debug_log, "Entering ithread_free\n"));

if (! (thread->state & PERL_ITHR_NONVIABLE)) {
assert(thread->count > 0);
if (--thread->count > 0) {
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread Mutex unlocked, returning without doing anything else, thread_count=%d\n", thread->count));
return;
}
assert((thread->state & PERL_ITHR_FINISHED) &&
(thread->state & PERL_ITHR_UNCALLABLE));
}
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread Mutex unlocked\n"));

/* Main thread (0) is immortal and should never get here */
assert(thread->tid != 0);
Expand All @@ -329,14 +354,17 @@ S_ithread_free(pTHX_ ithread *thread)
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);

/* Thread is now disowned */
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread Mutex locking\n"));
MUTEX_LOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "free: thread is disowned: thread=%p\n", thread));
S_ithread_clear(aTHX_ thread);

#ifdef WIN32
handle = thread->handle;
thread->handle = NULL;
#endif
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread Mutex unlocked\n"));
MUTEX_DESTROY(&thread->mutex);

#ifdef WIN32
Expand All @@ -345,6 +373,7 @@ S_ithread_free(pTHX_ ithread *thread)
}
#endif

DEBUG_U(PerlIO_printf(Perl_debug_log, "ithread_free: freeing, then locking/unlocuking mutex, then return\n"));
PerlMemShared_free(thread);

/* total_threads >= 1 is used to veto cleanup by the main thread,
Expand All @@ -363,9 +392,11 @@ static void
S_ithread_count_inc(pTHX_ ithread *thread)
PERL_TSA_EXCLUDES(thread->mutex)
{
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread locking mutex\n"));
MUTEX_LOCK(&thread->mutex);
thread->count++;
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread Mutex unlocked\n"));
}


Expand Down Expand Up @@ -424,6 +455,7 @@ ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
{
ithread *thread = (ithread *)mg->mg_ptr;
PERL_UNUSED_ARG(sv);
DEBUG_U(PerlIO_printf(Perl_debug_log, "mg_free thread locking Mutex\n"));
MUTEX_LOCK(&thread->mutex);
S_ithread_free(aTHX_ thread); /* Releases MUTEX */
return (0);
Expand Down Expand Up @@ -596,6 +628,7 @@ S_ithread_run(void * arg)

PERL_SET_CONTEXT(thread->interp);
S_ithread_set(aTHX_ thread);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread lock then unlock, context set\n"));

#ifdef THREAD_SIGNAL_BLOCKING
/* Thread starts with most signals blocked - restore the signal mask from
Expand Down Expand Up @@ -689,6 +722,7 @@ S_ithread_run(void * arg)
MY_POOL.joinable_threads++;
}
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread Mutex unlocked\n"));
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);

thread_locale_term();
Expand All @@ -705,6 +739,7 @@ S_ithread_run(void * arg)
*/
aTHX = MY_POOL.main_thread.interp;

DEBUG_U(PerlIO_printf(Perl_debug_log, "run: thread is finished, calling free from potentially new aTHX\n"));
MUTEX_LOCK(&thread->mutex);
S_ithread_free(aTHX_ thread); /* Releases MUTEX */

Expand Down Expand Up @@ -1109,6 +1144,7 @@ ithread_create(...)
stack_size = thread->stack_size;
exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY;
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread Mutex unlocked\n"));
} else {
/* threads->create() */
classname = (char *)SvPV_nolen(ST(0));
Expand Down Expand Up @@ -1204,6 +1240,7 @@ ithread_create(...)
CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
/* warning: releasing mutex 'thread->mutex' that was not held [-Wthread-safety-analysis] */
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread Mutex unlocked\n"));
CLANG_DIAG_RESTORE_STMT;
/* XSRETURN(1); - implied */

Expand Down Expand Up @@ -1242,6 +1279,7 @@ ithread_list(...)
MUTEX_LOCK(&thread->mutex);
state = thread->state;
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread Mutex unlocked\n"));

/* Ignore detached or joined threads */
if (state & PERL_ITHR_UNCALLABLE) {
Expand Down Expand Up @@ -1330,17 +1368,20 @@ ithread_join(...)
MUTEX_LOCK(&thread->mutex);
if ((join_err = (thread->state & PERL_ITHR_UNCALLABLE))) {
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "join: thread Mutex unlocked, thread=%ld, current_thread=%ld\n", thread->tid, current_thread->tid));
Perl_croak(aTHX_ (join_err & PERL_ITHR_DETACHED)
? "Cannot join a detached thread"
: "Thread already joined");
} else if (thread->tid == current_thread->tid) {
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "join thread Mutex unlocked thread and current thread are the same\n"));
Perl_croak(aTHX_ "Cannot join self");
}

/* Mark as joined */
thread->state |= PERL_ITHR_JOINED;
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread Mutex unlocked\n"));

MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
MY_POOL.joinable_threads--;
Expand Down Expand Up @@ -1412,6 +1453,7 @@ ithread_join(...)

/* If thread didn't die, then we can free its interpreter */
if (! (thread->state & PERL_ITHR_DIED)) {
DEBUG_U(PerlIO_printf(Perl_debug_log, "join: thread didn't die: call clear\n"));
S_ithread_clear(aTHX_ thread);
}
S_ithread_free(aTHX_ thread); /* Releases MUTEX */
Expand Down Expand Up @@ -1468,6 +1510,7 @@ ithread_detach(...)
}
}
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "detach: thread Mutex unlocked\n"));
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);

if (detach_err) {
Expand All @@ -1478,10 +1521,12 @@ ithread_detach(...)

/* If thread is finished and didn't die,
* then we can free its interpreter */
DEBUG_U(PerlIO_printf(Perl_debug_log, "detach: locking mutex\n"));
MUTEX_LOCK(&thread->mutex);
if ((thread->state & PERL_ITHR_FINISHED) &&
! (thread->state & PERL_ITHR_DIED))
{
DEBUG_U(PerlIO_printf(Perl_debug_log, "detach: thread is finished and didn't die\n"));
S_ithread_clear(aTHX_ thread);
}
S_ithread_free(aTHX_ thread); /* Releases MUTEX */
Expand Down Expand Up @@ -1533,6 +1578,7 @@ ithread_kill(...)
no_handler = 0;
}
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "kill: thread Mutex unlocked\n"));

if (no_handler) {
Perl_croak(aTHX_ "Signal %s received in thread %" UVuf
Expand Down Expand Up @@ -1622,6 +1668,7 @@ ithread_object(...)
MUTEX_LOCK(&thread->mutex);
state = thread->state;
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "thread object: Mutex unlocked\n"));
if (! (state & PERL_ITHR_UNCALLABLE)) {
/* Put object on stack */
ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
Expand Down Expand Up @@ -1709,6 +1756,7 @@ ithread_is_running(...)
MUTEX_LOCK(&thread->mutex);
ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes;
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "is_running thread Mutex unlocked\n"));
/* XSRETURN(1); - implied */


Expand All @@ -1722,6 +1770,7 @@ ithread_is_detached(...)
MUTEX_LOCK(&thread->mutex);
ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no;
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "is_detatched: thread Mutex unlocked\n"));
/* XSRETURN(1); - implied */


Expand All @@ -1741,6 +1790,7 @@ ithread_is_joinable(...)
! (thread->state & PERL_ITHR_UNCALLABLE))
? &PL_sv_yes : &PL_sv_no;
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "is_joinable: thread Mutex unlocked\n"));
/* XSRETURN(1); - implied */


Expand Down Expand Up @@ -1773,6 +1823,7 @@ ithread_set_thread_exit_only(...)
thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY;
}
MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "set_thread_exit_only: thread Mutex unlocked\n"));


void
Expand Down Expand Up @@ -1846,6 +1897,7 @@ ithread_error(...)
}

MUTEX_UNLOCK(&thread->mutex);
DEBUG_U(PerlIO_printf(Perl_debug_log, "ithread_error: thread Mutex unlocked\n"));

if (! err) {
XSRETURN_UNDEF;
Expand Down
6 changes: 6 additions & 0 deletions inline.h
View file
Expand Up @@ -362,20 +362,24 @@ S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
PERL_STATIC_INLINE I32
Perl_TOPMARK(pTHX)
{
#if 0
DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
"MARK top %p %" IVdf "\n",
PL_markstack_ptr,
(IV)*PL_markstack_ptr)));
#endif
return *PL_markstack_ptr;
}

PERL_STATIC_INLINE I32
Perl_POPMARK(pTHX)
{
#if 0
DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
"MARK pop %p %" IVdf "\n",
(PL_markstack_ptr-1),
(IV)*(PL_markstack_ptr-1))));
#endif
assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
return *PL_markstack_ptr--;
}
Expand Down Expand Up @@ -3215,10 +3219,12 @@ Perl_foldEQ_locale(pTHX_ const char *s1, const char *s2, I32 len)

while (len--) {
if (*a != *b && *a != PL_fold_locale[*b]) {
#if 0
DEBUG_Lv(PerlIO_printf(Perl_debug_log,
"%s:%d: Our records indicate %02x is not a fold of %02x"
" or its mate %02x\n",
__FILE__, __LINE__, *a, *b, PL_fold_locale[*b]));
#endif

return 0;
}
Expand Down

0 comments on commit 3de6ae2

Please sign in to comment.