--- /dev/null
+Some old globals (e.g. stack_sp, op) and some old per-interpreter
+variables (e.g. tmps_stack, cxstack) move into struct thread.
+All fields of struct thread (apart from a few only applicable to
+FAKE_THREADS) are of the form Tfoo. For example, stack_sp becomes
+the field Tstack_sp of struct thread. For those fields which moved
+from original perl, thread.h does
+ #define foo (thr->Tfoo)
+This means that all functions in perl which need to use one of these
+fields need an (automatic) variable thr which points at the current
+thread's struct thread. For pp_foo functions, it is passed around as
+an argument, for other functions they do
+ dTHR;
+which declares and initialises thr from thread-specific data
+via pthread_getspecific. If a function fails to compile with an
+error about "no such variable thr", it probably just needs a dTHR
+at the top.
+
+For FAKE_THREADS, thr is a global variable and perl schedules threads
+by altering thr in between appropriate ops. The next and prev fields
+of struct thread keep all fake threads on a doubly linked list and
+the next_run and prev_run fields keep all runnable threads on a
+doubly linked list. Mutexes are stubs for FAKE_THREADS. Condition
+variables are implemented as a list of waiting threads.
+
+
+Mutexes and condition variables
+
+The API is via macros MUTEX_{INIT,LOCK,UNLOCK,DESTROY} and
+COND_{INIT,WAIT,SIGNAL,BROADCAST,DESTROY}. For POSIX threads,
+perl mutexes and condition variables correspond to POSIX ones.
+For FAKE_THREADS, mutexes are stubs and condition variables are
+implmented as lists of waiting threads. For FAKE_THREADS, a thread
+waits on a condition variable by removing itself from the runnable
+list, calling SCHEDULE to change thr to the next appropriate
+runnable thread and returning op (i.e. the new threads next op).
+This means that fake threads can only block while in PP code.
+A PP function which contains a COND_WAIT must be prepared to
+handle such restarts and can use the field "private" of struct
+thread to record its state. For fake threads, COND_SIGNAL and
+COND_BROADCAST work by putting back all the threads on the
+condition variables list into the run queue. Note that a mutex
+must *not* be held while returning from a PP function.
+
+Perl locks are a condpair_t structure (a triple of a mutex, a
+condtion variable and an owner thread field) attached by 'm'
+magic to any SV. pp_lock locks such an object by waiting on the
+condition variable until the owner field is zero and then setting
+the owner field to its own thread pointer. The lock is recursive
+so if the owner field already matches the current thread then
+pp_lock returns straight away. If the owner field has to be filled
+in then unlock_condpair is queued as an end-of-block destructor and
+that function zeroes out the owner field, releasing the lock.
STRLEN len;
int multi;
{
+ dTHR;
register GP *gp;
sv_upgrade((SV*)gv, SVt_PVGV);
char* name;
I32 autoload;
{
+ dTHR;
register char *nend;
char *nsplit = 0;
GV* gv;
case '/':
break;
case '[':
- sv_setiv(sv, (IV)curcop->cop_arybase);
+ WITH_THR(sv_setiv(sv, (IV)curcop->cop_arybase));
break;
case '|':
sv_setiv(sv, (IV)(IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
SV* sv;
MAGIC* mg;
{
+ dTHR;
sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
return 0;
}
SV* sv;
MAGIC* mg;
{
+ dTHR;
av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
return 0;
}
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
mg = mg_find(lsv, 'g');
if (mg && mg->mg_len >= 0) {
+ dTHR;
sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
return 0;
}
}
len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
- pos = SvIV(sv) - curcop->cop_arybase;
+ WITH_THR(pos = SvIV(sv) - curcop->cop_arybase);
if (pos < 0) {
pos += len;
if (pos < 0)
{
if (dowarn &&
o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
+ dTHR;
line_t oldline = curcop->cop_line;
if (copline != NOLINE)
else
scalar(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
case OP_SCOPE:
case OP_LINESEQ:
else
scalar(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
}
return o;
case OP_NEXTSTATE:
case OP_DBSTATE:
- curcop = ((COP*)o); /* for warning below */
+ WITH_THR(curcop = ((COP*)o)); /* for warning below */
break;
case OP_CONST:
case OP_NULL:
if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
- curcop = ((COP*)o); /* for warning below */
+ WITH_THR(curcop = ((COP*)o)); /* for warning below */
if (o->op_flags & OPf_STACKED)
break;
/* FALL THROUGH */
else
list(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
case OP_SCOPE:
case OP_LINESEQ:
else
list(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
case OP_REQUIRE:
/* all requires must return a boolean value */
o->op_type == OP_LEAVE ||
o->op_type == OP_LEAVETRY)
{
+ dTHR;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling) {
scalarvoid(kid);
perl_construct( sv_interp )
register PerlInterpreter *sv_interp;
{
-#ifdef USE_THREADS
+#if defined(USE_THREADS) && !defined(FAKE_THREADS)
struct thread *thr;
-#endif /* USE_THREADS */
+#endif
if (!(curinterp = sv_interp))
return;
pthread_init();
#endif /* NEED_PTHREAD_INIT */
New(53, thr, 1, struct thread);
+#ifdef FAKE_THREADS
+ self = thr;
+ thr->next = thr->prev = thr->next_run = thr->prev_run = thr;
+ thr->wait_queue = 0;
+ thr->private = 0;
+#else
self = pthread_self();
if (pthread_key_create(&thr_key, thread_destruct))
croak("panic: pthread_key_create");
if (pthread_setspecific(thr_key, (void *) thr))
croak("panic: pthread_setspecific");
+#endif /* !FAKE_THREADS */
nthreads = 1;
cvcache = newHV();
thrflags = 0;
+ curcop = &compiling;
#endif /* USE_THREADS */
/* Init the real globals? */
return;
#ifdef USE_THREADS
+#ifndef FAKE_THREADS
/* Wait until all user-created threads go away */
MUTEX_LOCK(&nthreads_mutex);
while (nthreads > 1)
DEBUG_L(fprintf(stderr, "perl_destruct: armageddon has arrived\n"));
MUTEX_DESTROY(&nthreads_mutex);
COND_DESTROY(&nthreads_cond);
+#endif /* !defined(FAKE_THREADS) */
#endif /* USE_THREADS */
destruct_level = perl_destruct_level;
SV *sv;
#endif
{
+ dTHR;
char *xfound = Nullch;
char *xfailed = Nullch;
register char *s;
#define NOOP (void)0
+#define WITH_THR(s) do { dTHR; s; } while (0)
#ifdef USE_THREADS
#ifdef FAKE_THREADS
#include "fakethr.h"
#include <pthread.h>
typedef pthread_mutex_t perl_mutex;
typedef pthread_cond_t perl_cond;
+typedef pthread_key_t perl_key;
#endif /* FAKE_THREADS */
#endif /* USE_THREADS */
/* global state */
EXT PerlInterpreter * curinterp; /* currently running interpreter */
#ifdef USE_THREADS
-EXT pthread_key_t thr_key; /* For per-thread struct thread ptr */
+EXT perl_key thr_key; /* For per-thread struct thread ptr */
EXT perl_mutex sv_mutex; /* Mutex for allocating SVs in sv.c */
EXT perl_mutex malloc_mutex; /* Mutex for malloc */
EXT perl_mutex eval_mutex; /* Mutex for doeval */
EXT int nthreads; /* Number of threads currently */
EXT perl_mutex nthreads_mutex; /* Mutex for nthreads */
EXT perl_cond nthreads_cond; /* Condition variable for nthreads */
+#ifdef FAKE_THREADS
+EXT struct thread * thr; /* Currently executing (fake) thread */
+#endif
#endif /* USE_THREADS */
/* VMS doesn't use environ array and NeXT has problems with crt0.o globals */
/* stack stuff */
IEXT AV * Icurstack; /* THE STACK */
IEXT AV * Imainstack; /* the stack when nothing funny is happening */
+#if 0
IEXT SV ** Imystack_base; /* stack->array_ary */
IEXT SV ** Imystack_sp; /* stack pointer now */
IEXT SV ** Imystack_max; /* stack->array_ary + stack->array_max */
+#endif
/* format accumulators */
IEXT SV * Iformtarget;
return Nullop;
}
+/* With USE_THREADS, eval_owner must be held on entry to doeval */
static OP *
doeval(gimme)
int gimme;
CV *caller;
AV* comppadlist;
-#ifdef USE_THREADS
- MUTEX_LOCK(&eval_mutex);
- if (eval_owner && eval_owner != thr)
- while (eval_owner)
- COND_WAIT(&eval_cond, &eval_mutex);
- eval_owner = thr;
- MUTEX_UNLOCK(&eval_mutex);
-#endif /* USE_THREADS */
in_eval = 1;
PUSHMARK(SP);
compiling.cop_line = 0;
PUTBACK;
+#ifdef USE_THREADS
+ MUTEX_LOCK(&eval_mutex);
+ if (eval_owner && eval_owner != thr)
+ while (eval_owner)
+ COND_WAIT(&eval_cond, &eval_mutex);
+ eval_owner = thr;
+ MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
return DOCATCH(doeval(G_SCALAR));
}
if (perldb && curstash != debstash)
save_lines(GvAV(compiling.cop_filegv), linestr);
PUTBACK;
+#ifdef USE_THREADS
+ MUTEX_LOCK(&eval_mutex);
+ if (eval_owner && eval_owner != thr)
+ while (eval_owner)
+ COND_WAIT(&eval_cond, &eval_mutex);
+ eval_owner = thr;
+ MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
ret = doeval(gimme);
if (perldb && was != sub_generation) { /* Some subs defined here. */
strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
AV* av;
SV** ary;
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "%p entersub preparing @_\n", thr));
av = (AV*)curpad[0];
if (AvREAL(av)) {
av_clear(av);
MARK++;
}
}
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "%p entersub returning %p\n", thr, CvSTART(cv)));
RETURNOP(CvSTART(cv));
}
}
static void del_xrv _((XRV* p));
static void sv_mortalgrow _((void));
static void sv_unglob _((SV* sv));
+static void sv_check_thinkfirst _((SV *sv));
typedef void (*SVFUNC) _((SV*));
register SV *sv;
IV i;
{
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
sv_upgrade(sv, SVt_IV);
register SV *sv;
double num;
{
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
case SVt_IV:
if (sstr == dstr)
return;
- if (SvTHINKFIRST(dstr)) {
- if (SvREADONLY(dstr) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(dstr))
- sv_unref(dstr);
- }
+ sv_check_thinkfirst(dstr);
if (!sstr)
sstr = &sv_undef;
stype = SvTYPE(sstr);
{
assert(len >= 0); /* STRLEN is probably unsigned, so this may
elicit a warning, but it won't hurt. */
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
{
register STRLEN len;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
register char *ptr;
register STRLEN len;
{
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!SvUPGRADE(sv, SVt_PV))
return;
if (!ptr) {
SvTAINT(sv);
}
+static void
+sv_check_thinkfirst(sv)
+register SV *sv;
+{
+ if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
+ if (SvROK(sv))
+ sv_unref(sv);
+ }
+}
+
void
sv_chop(sv,ptr) /* like set but assuming ptr is in sv */
register SV *sv;
if (!ptr || !SvPOKp(sv))
return;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv,SVt_PVIV);
{
MAGIC* mg;
- if (SvREADONLY(sv) && curcop != &compiling && !strchr("gBf", how))
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling && !strchr("gBf", how))
+ croak(no_modify);
+ }
if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
if (how == 't')
register SV *nsv;
{
U32 refcnt = SvREFCNT(sv);
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (SvREFCNT(nsv) != 1)
warn("Reference miscount in sv_replace()");
if (SvMAGICAL(sv)) {
return;
#ifdef DEBUGGING
if (SvTEMP(sv)) {
- warn("Attempt to free temp prematurely");
+ warn("Attempt to free temp prematurely: %s", SvPEEK(sv));
return;
}
#endif
register I32 cnt;
I32 i;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!SvUPGRADE(sv, SVt_PV))
return 0;
SvSCREAM_off(sv);
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
if (SvROK(sv)) {
#ifdef OVERLOAD
if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return;
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
if (SvROK(sv)) {
#ifdef OVERLOAD
if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return;
{
char *s;
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
if (SvPOK(sv)) {
*lp = SvCUR(sv);
int Tdelaymagic;
bool Tdirty;
U8 Tlocalizing;
+ COP * Tcurcop;
CONTEXT * Tcxstack;
I32 Tcxstack_ix;
I32 Tcxstack_max;
- AV * Tstack;
+ AV * Tcurstack;
AV * Tmainstack;
JMPENV * Ttop_env;
I32 Trunlevel;
perl_thread next_run, prev_run; /* Linked list of runnable threads */
perl_cond wait_queue; /* Wait queue that we are waiting on */
IV private; /* Holds data across time slices */
+ I32 savemark; /* Holds MARK for thread join values */
#endif /* FAKE_THREADS */
};
#undef stack_base
#undef stack_sp
#undef stack_max
-#undef stack
+#undef curstack
#undef mainstack
#undef markstack
#undef markstack_ptr
#undef retstack
#undef retstack_ix
#undef retstack_max
+#undef curcop
#undef cxstack
#undef cxstack_ix
#undef cxstack_max
#undef op
#define op (thr->Top)
#endif
+#define curcop (thr->Tcurcop)
#define stack (thr->Tstack)
#define mainstack (thr->Tmainstack)
#define markstack (thr->Tmarkstack)
lex_start(line)
SV *line;
{
+ dTHR;
char *s;
STRLEN len;
incline(s)
char *s;
{
+ dTHR;
char *t;
char *n;
char ch;
char *s;
#endif /* CAN_PROTOTYPE */
{
+ dTHR;
yylval.ival = f;
CLINE;
expect = x;
static I32
sublex_push()
{
+ dTHR;
push_scope();
lex_state = sublex_info.super_state;
GV *gv;
CV *cv;
+ DEBUG_L(fprintf(stderr, "die: curstack = %p, mainstack= %p\n",
+ curstack, mainstack));/*debug*/
/* We have to switch back to mainstack or die_where may try to pop
* the eval block from the wrong stack if die is being called from a
* signal handler. - dkindred@cs.cmu.edu */
message = mess(pat, &args);
va_end(args);
+ DEBUG_L(fprintf(stderr, "die: message = %s\ndiehook = %p\n",
+ message, diehook));/*debug*/
if (diehook) {
/* sv_2cv might call croak() */
SV *olddiehook = diehook;
}
restartop = die_where(message);
+ DEBUG_L(fprintf(stderr,
+ "die: restartop = %p, was_in_eval = %d, oldrunlevel = %d\n",
+ restartop, was_in_eval, oldrunlevel));/*debug*/
if ((!restartop && was_in_eval) || oldrunlevel > 1)
JMPENV_JUMP(3);
return restartop;
if (thr->next_run == thr)
croak("panic: perl_cond_wait called by last runnable thread");
- New(666, cond, 1, perl_wait_queue);
+ New(666, cond, 1, struct perl_wait_queue);
cond->thread = thr;
cond->next = *cp;
*cp = cond;
projects / p5sagit/p5-mst-13.2.git / commitdiff