diff options
| -rw-r--r-- | README.threads | 52 | ||||
| -rw-r--r-- | gv.c | 2 | ||||
| -rw-r--r-- | mg.c | 7 | ||||
| -rw-r--r-- | op.c | 14 | ||||
| -rw-r--r-- | perl.c | 15 | ||||
| -rw-r--r-- | perl.h | 9 | ||||
| -rw-r--r-- | pp_ctl.c | 25 | ||||
| -rw-r--r-- | pp_hot.c | 4 | ||||
| -rw-r--r-- | sv.c | 109 | ||||
| -rw-r--r-- | thread.h | 8 | ||||
| -rw-r--r-- | toke.c | 4 | ||||
| -rw-r--r-- | util.c | 9 |
12 files changed, 173 insertions, 85 deletions
diff --git a/README.threads b/README.threads new file mode 100644 index 0000000000..7dae3efbcb --- /dev/null +++ b/README.threads @@ -0,0 +1,52 @@ +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. @@ -93,6 +93,7 @@ char *name; STRLEN len; int multi; { + dTHR; register GP *gp; sv_upgrade((SV*)gv, SVt_PVGV); @@ -261,6 +262,7 @@ HV* stash; char* name; I32 autoload; { + dTHR; register char *nend; char *nsplit = 0; GV* gv; @@ -491,7 +491,7 @@ MAGIC *mg; 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 ); @@ -967,6 +967,7 @@ magic_getarylen(sv,mg) SV* sv; MAGIC* mg; { + dTHR; sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase); return 0; } @@ -976,6 +977,7 @@ magic_setarylen(sv,mg) SV* sv; MAGIC* mg; { + dTHR; av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase); return 0; } @@ -990,6 +992,7 @@ MAGIC* mg; 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; } @@ -1023,7 +1026,7 @@ MAGIC* mg; } 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) @@ -637,6 +637,7 @@ OP *o; { if (dowarn && o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { + dTHR; line_t oldline = curcop->cop_line; if (copline != NOLINE) @@ -697,7 +698,7 @@ OP *o; else scalar(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; case OP_SCOPE: case OP_LINESEQ: @@ -708,7 +709,7 @@ OP *o; else scalar(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; } return o; @@ -821,7 +822,7 @@ OP *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: @@ -860,7 +861,7 @@ OP *o; 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 */ @@ -957,7 +958,7 @@ OP *o; else list(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; case OP_SCOPE: case OP_LINESEQ: @@ -967,7 +968,7 @@ OP *o; else list(kid); } - curcop = &compiling; + WITH_THR(curcop = &compiling); break; case OP_REQUIRE: /* all requires must return a boolean value */ @@ -989,6 +990,7 @@ OP *o; 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); @@ -97,9 +97,9 @@ void 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; @@ -113,14 +113,22 @@ register PerlInterpreter *sv_interp; 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? */ @@ -240,6 +248,7 @@ register PerlInterpreter *sv_interp; return; #ifdef USE_THREADS +#ifndef FAKE_THREADS /* Wait until all user-created threads go away */ MUTEX_LOCK(&nthreads_mutex); while (nthreads > 1) @@ -253,6 +262,7 @@ register PerlInterpreter *sv_interp; 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; @@ -1715,6 +1725,7 @@ bool dosearch; SV *sv; #endif { + dTHR; char *xfound = Nullch; char *xfailed = Nullch; register char *s; @@ -62,6 +62,7 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); #define NOOP (void)0 +#define WITH_THR(s) do { dTHR; s; } while (0) #ifdef USE_THREADS #ifdef FAKE_THREADS #include "fakethr.h" @@ -69,6 +70,7 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); #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 */ @@ -1323,7 +1325,7 @@ typedef Sighandler_t Sigsave_t; /* 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 */ @@ -1332,6 +1334,9 @@ EXT struct thread * eval_owner; /* Owner thread 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 */ @@ -1904,9 +1909,11 @@ IEXT I32 Irunlevel; /* 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; @@ -2123,6 +2123,7 @@ OP *o; return Nullop; } +/* With USE_THREADS, eval_owner must be held on entry to doeval */ static OP * doeval(gimme) int gimme; @@ -2134,14 +2135,6 @@ 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); @@ -2406,6 +2399,14 @@ PP(pp_require) 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)); } @@ -2458,6 +2459,14 @@ PP(pp_entereval) 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. */ @@ -2125,6 +2125,8 @@ PP(pp_entersub) 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); @@ -2159,6 +2161,8 @@ PP(pp_entersub) MARK++; } } + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "%p entersub returning %p\n", thr, CvSTART(cv))); RETURNOP(CvSTART(cv)); } } @@ -57,6 +57,7 @@ static void del_xpv _((XPV* p)); 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*)); @@ -1093,12 +1094,7 @@ sv_setiv(sv,i) 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); @@ -1149,12 +1145,7 @@ sv_setnv(sv,num) 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: @@ -1845,12 +1836,7 @@ register SV *sstr; 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); @@ -2183,12 +2169,7 @@ register STRLEN len; { 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; @@ -2214,12 +2195,7 @@ register const 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 (!ptr) { (void)SvOK_off(sv); return; @@ -2244,12 +2220,7 @@ register SV *sv; 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) { @@ -2267,6 +2238,21 @@ register STRLEN len; 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; @@ -2276,12 +2262,7 @@ register char *ptr; 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); @@ -2386,8 +2367,11 @@ I32 namlen; { 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') @@ -2653,12 +2637,7 @@ register SV *sv; 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)) { @@ -2880,7 +2859,7 @@ SV *sv; return; #ifdef DEBUGGING if (SvTEMP(sv)) { - warn("Attempt to free temp prematurely"); + warn("Attempt to free temp prematurely: %s", SvPEEK(sv)); return; } #endif @@ -3080,12 +3059,7 @@ I32 append; 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); @@ -3323,8 +3297,11 @@ register SV *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; @@ -3398,8 +3375,11 @@ register SV *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,dec)) return; @@ -3883,8 +3863,11 @@ STRLEN *lp; { 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); @@ -139,12 +139,13 @@ struct thread { 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; @@ -160,6 +161,7 @@ struct thread { 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 */ }; @@ -195,7 +197,7 @@ typedef struct condpair { #undef stack_base #undef stack_sp #undef stack_max -#undef stack +#undef curstack #undef mainstack #undef markstack #undef markstack_ptr @@ -209,6 +211,7 @@ typedef struct condpair { #undef retstack #undef retstack_ix #undef retstack_max +#undef curcop #undef cxstack #undef cxstack_ix #undef cxstack_max @@ -233,6 +236,7 @@ typedef struct condpair { #undef op #define op (thr->Top) #endif +#define curcop (thr->Tcurcop) #define stack (thr->Tstack) #define mainstack (thr->Tmainstack) #define markstack (thr->Tmarkstack) @@ -226,6 +226,7 @@ void lex_start(line) SV *line; { + dTHR; char *s; STRLEN len; @@ -309,6 +310,7 @@ static void incline(s) char *s; { + dTHR; char *t; char *n; char ch; @@ -459,6 +461,7 @@ expectation x; char *s; #endif /* CAN_PROTOTYPE */ { + dTHR; yylval.ival = f; CLINE; expect = x; @@ -651,6 +654,7 @@ sublex_start() static I32 sublex_push() { + dTHR; push_scope(); lex_state = sublex_info.super_state; @@ -1172,6 +1172,8 @@ die(pat, va_alist) 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 */ @@ -1188,6 +1190,8 @@ die(pat, va_alist) 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; @@ -1215,6 +1219,9 @@ die(pat, va_alist) } 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; @@ -2360,7 +2367,7 @@ perl_cond *cp; 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; |