diff options
| -rw-r--r-- | doop.c | 2 | ||||
| -rw-r--r-- | embed.h | 25 | ||||
| -rw-r--r-- | ext/Thread/Thread.xs | 31 | ||||
| -rw-r--r-- | global.sym | 5 | ||||
| -rw-r--r-- | gv.c | 1 | ||||
| -rw-r--r-- | hv.c | 2 | ||||
| -rw-r--r-- | interp.sym | 6 | ||||
| -rw-r--r-- | mg.c | 20 | ||||
| -rw-r--r-- | op.c | 43 | ||||
| -rw-r--r-- | opcode.h | 9 | ||||
| -rwxr-xr-x | opcode.pl | 4 | ||||
| -rw-r--r-- | perl.c | 91 | ||||
| -rw-r--r-- | perl.h | 11 | ||||
| -rw-r--r-- | pp.c | 13 | ||||
| -rw-r--r-- | pp_ctl.c | 24 | ||||
| -rw-r--r-- | pp_sys.c | 18 | ||||
| -rw-r--r-- | proto.h | 5 | ||||
| -rw-r--r-- | sv.c | 10 | ||||
| -rw-r--r-- | sv.h | 45 | ||||
| -rw-r--r-- | taint.c | 5 | ||||
| -rw-r--r-- | thread.h | 42 | ||||
| -rw-r--r-- | toke.c | 46 | ||||
| -rw-r--r-- | util.c | 136 |
23 files changed, 443 insertions, 151 deletions
@@ -257,6 +257,7 @@ I32 do_chomp(sv) register SV *sv; { + dTHR; register I32 count; STRLEN len; char *s; @@ -334,6 +335,7 @@ SV *sv; SV *left; SV *right; { + dTHR; /* just for taint */ #ifdef LIBERAL register long *dl; register long *ll; @@ -282,12 +282,15 @@ #define inc_amg Perl_inc_amg #define ingroup Perl_ingroup #define init_stacks Perl_init_stacks +#define init_thread_intern Perl_init_thread_intern #define instr Perl_instr #define intro_my Perl_intro_my #define intuit_more Perl_intuit_more #define invert Perl_invert #define io_close Perl_io_close #define jmaybe Perl_jmaybe +#define key_create Perl_key_create +#define key_destroy Perl_key_destroy #define keyword Perl_keyword #define know_next Perl_know_next #define last_lop Perl_last_lop @@ -458,6 +461,7 @@ #define newWHILEOP Perl_newWHILEOP #define newXS Perl_newXS #define newXSUB Perl_newXSUB +#define new_struct_thread Perl_new_struct_thread #define nextargv Perl_nextargv #define nexttoke Perl_nexttoke #define nexttype Perl_nexttype @@ -479,6 +483,7 @@ #define nomemok Perl_nomemok #define nomethod_amg Perl_nomethod_amg #define not_amg Perl_not_amg +#define nthreads Perl_nthreads #define numer_amg Perl_numer_amg #define numeric_local Perl_numeric_local #define numeric_name Perl_numeric_name @@ -510,6 +515,7 @@ #define padix Perl_padix #define patleave Perl_patleave #define peep Perl_peep +#define per_thread_magicals Perl_per_thread_magicals #define pidgone Perl_pidgone #define pidstatus Perl_pidstatus #define pmflag Perl_pmflag @@ -1090,6 +1096,7 @@ #define taint_env Perl_taint_env #define taint_proper Perl_taint_proper #define thisexpr Perl_thisexpr +#define thr_key Perl_thr_key #define timesbuf Perl_timesbuf #define tokenbuf Perl_tokenbuf #define too_few_arguments Perl_too_few_arguments @@ -1258,7 +1265,8 @@ #define e_tmpname (curinterp->Ie_tmpname) #define endav (curinterp->Iendav) #define envgv (curinterp->Ienvgv) -#define errgv (curinterp->Ierrgv) +#define errhv (curinterp->Ierrhv) +#define errsv (curinterp->Ierrsv) #define eval_root (curinterp->Ieval_root) #define eval_start (curinterp->Ieval_start) #define fdpid (curinterp->Ifdpid) @@ -1272,6 +1280,8 @@ #define incgv (curinterp->Iincgv) #define initav (curinterp->Iinitav) #define inplace (curinterp->Iinplace) +#define keys (curinterp->Ikeys) +#define keys_mutex (curinterp->Ikeys_mutex) #define last_in_gv (curinterp->Ilast_in_gv) #define lastfd (curinterp->Ilastfd) #define lastretstr (curinterp->Ilastretstr) @@ -1284,6 +1294,7 @@ #define lineary (curinterp->Ilineary) #define localizing (curinterp->Ilocalizing) #define localpatches (curinterp->Ilocalpatches) +#define magical_keys (curinterp->Imagical_keys) #define main_cv (curinterp->Imain_cv) #define main_root (curinterp->Imain_root) #define main_start (curinterp->Imain_start) @@ -1410,7 +1421,8 @@ #define Ie_tmpname e_tmpname #define Iendav endav #define Ienvgv envgv -#define Ierrgv errgv +#define Ierrhv errhv +#define Ierrsv errsv #define Ieval_root eval_root #define Ieval_start eval_start #define Ifdpid fdpid @@ -1424,6 +1436,8 @@ #define Iincgv incgv #define Iinitav initav #define Iinplace inplace +#define Ikeys keys +#define Ikeys_mutex keys_mutex #define Ilast_in_gv last_in_gv #define Ilastfd lastfd #define Ilastretstr lastretstr @@ -1436,6 +1450,7 @@ #define Ilineary lineary #define Ilocalizing localizing #define Ilocalpatches localpatches +#define Imagical_keys magical_keys #define Imain_cv main_cv #define Imain_root main_root #define Imain_start main_start @@ -1571,7 +1586,8 @@ #define e_fp Perl_e_fp #define e_tmpname Perl_e_tmpname #define endav Perl_endav -#define errgv Perl_errgv +#define errhv Perl_errhv +#define errsv Perl_errsv #define eval_root Perl_eval_root #define eval_start Perl_eval_start #define fdpid Perl_fdpid @@ -1585,6 +1601,8 @@ #define incgv Perl_incgv #define initav Perl_initav #define inplace Perl_inplace +#define keys Perl_keys +#define keys_mutex Perl_keys_mutex #define last_in_gv Perl_last_in_gv #define lastfd Perl_lastfd #define lastretstr Perl_lastretstr @@ -1597,6 +1615,7 @@ #define lineary Perl_lineary #define localizing Perl_localizing #define localpatches Perl_localpatches +#define magical_keys Perl_magical_keys #define main_cv Perl_main_cv #define main_root Perl_main_root #define main_start Perl_main_start diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs index 7d309b6a2e..a6386176ff 100644 --- a/ext/Thread/Thread.xs +++ b/ext/Thread/Thread.xs @@ -204,38 +204,9 @@ char *class; #endif savethread = thr; - sv = newSVpv("", 0); - SvGROW(sv, sizeof(struct thread) + 1); - SvCUR_set(sv, sizeof(struct thread)); - thr = (Thread) SvPVX(sv); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: newthread(%s) = %p)\n", - savethread, SvPEEK(startsv), thr)); - oursv = sv; - /* If we don't zero these foostack pointers, init_stacks won't init them */ - markstack = 0; - scopestack = 0; - savestack = 0; - retstack = 0; + thr = new_struct_thread(thr); init_stacks(ARGS); - curcop = savethread->Tcurcop; /* XXX As good a guess as any? */ SPAGAIN; - defstash = savethread->Tdefstash; /* XXX maybe these should */ - curstash = savethread->Tcurstash; /* always be set to main? */ - /* top_env? */ - /* runlevel */ - cvcache = newHV(); - thr->flags = THRf_R_JOINABLE; - MUTEX_INIT(&thr->mutex); - thr->tid = ++threadnum; - /* Insert new thread into the circular linked list and bump nthreads */ - MUTEX_LOCK(&threads_mutex); - thr->next = savethread->next; - thr->prev = savethread; - savethread->next = thr; - thr->next->prev = thr; - nthreads++; - MUTEX_UNLOCK(&threads_mutex); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: newthread, tid is %u, preparing stack\n", savethread, thr->tid)); diff --git a/global.sym b/global.sym index 549a754b59..2ea71b231f 100644 --- a/global.sym +++ b/global.sym @@ -74,6 +74,8 @@ in_my in_my_stash inc_amg io_close +key_create +key_destroy know_next last_lop last_lop_op @@ -118,6 +120,7 @@ na ncmp_amg ne_amg neg_amg +new_struct_thread nexttoke nexttype nextval @@ -160,6 +163,7 @@ pad_reset_pending padix padix_floor patleave +per_thread_magicals pidstatus pow_amg pow_ass_amg @@ -953,6 +957,7 @@ pp_snetent pp_socket pp_sockpair pp_sort +pp_specific pp_splice pp_split pp_sprintf @@ -234,7 +234,6 @@ I32 level; (cv = GvCV(gv)) && (CvROOT(cv) || CvXSUB(cv))) { - dTHR; /* just for SvREFCNT_inc */ if (cv = GvCV(topgv)) SvREFCNT_dec(cv); GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); @@ -316,6 +316,7 @@ register U32 hash; xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { + dTHR; bool save_taint = tainted; if (tainting) tainted = SvTAINTED(keysv); @@ -925,7 +926,6 @@ HV *hv; } magic_nextpack((SV*) hv,mg,key); if (SvOK(key)) { - dTHR; /* just for SvREFCNT_inc */ /* force key to stay around until next time */ HeSVKEY_set(entry, SvREFCNT_inc(key)); return entry; /* beware, hent_val is not set */ diff --git a/interp.sym b/interp.sym index 1583ea217e..d64093eaea 100644 --- a/interp.sym +++ b/interp.sym @@ -47,7 +47,8 @@ e_fp e_tmpname endav envgv -errgv +errhv +errsv eval_root eval_start fdpid @@ -61,6 +62,8 @@ in_eval incgv initav inplace +keys +keys_mutex last_in_gv lastfd lastretstr @@ -73,6 +76,7 @@ leftgv lineary localizing localpatches +magical_keys main_cv main_root main_start @@ -264,6 +264,7 @@ magic_len(sv, mg) SV *sv; MAGIC *mg; { + dTHR; register I32 paren; register char *s; register I32 i; @@ -329,6 +330,7 @@ magic_get(sv, mg) SV *sv; MAGIC *mg; { + dTHR; register I32 paren; register char *s; register I32 i; @@ -415,7 +417,11 @@ MAGIC *mg; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': if (curpm && (rx = curpm->op_pmregexp)) { - paren = atoi(GvENAME((GV*)mg->mg_obj)); + /* + * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj)); + * XXX Does the new way break anything? + */ + paren = atoi(mg->mg_ptr); getparen: if (paren <= rx->nparens && (s = rx->startp[paren]) && @@ -572,6 +578,11 @@ MAGIC *mg; break; case '0': break; +#ifdef USE_THREADS + case '@': + sv_setsv(sv, errsv); + break; +#endif /* USE_THREADS */ } return 0; } @@ -749,7 +760,6 @@ MAGIC* mg; if(psig_ptr[i]) sv_setsv(sv,psig_ptr[i]); else { - dTHR; /* just for SvREFCNT_inc */ Sighandler_t sigstate = rsignal_state(i); /* cache state so we don't fetch it again */ @@ -1177,6 +1187,7 @@ magic_gettaint(sv,mg) SV* sv; MAGIC* mg; { + dTHR; TAINT_IF((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */ return 0; @@ -1706,6 +1717,11 @@ MAGIC* mg; origargv[i] = Nullch; } break; +#ifdef USE_THREADS + case '@': + sv_setsv(errsv, sv); + break; +#endif /* USE_THREADS */ } return 0; } @@ -247,7 +247,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) warn("Variable \"%s\" will not stay shared", name); } } - av_store(comppad, newoff, SvREFCNT_inc(oldsv)); + av_store(comppad, newoff, oldsv ? SvREFCNT_inc(oldsv) : 0); return newoff; } } @@ -511,6 +511,33 @@ pad_reset() pad_reset_pending = FALSE; } +#ifdef USE_THREADS +PADOFFSET +find_thread_magical(name) +char *name; +{ + dTHR; + char *p; + PADOFFSET key; + /* We currently only handle single character magicals */ + p = strchr(per_thread_magicals, *name); + if (!p) + return NOT_IN_PAD; + key = magical_keys[p - per_thread_magicals]; + if (key == NOT_IN_PAD) { + SV *sv; + key = magical_keys[p - per_thread_magicals] = key_create(); + sv = NEWSV(0, 0); + av_store(thr->specific, key, sv); + sv_magic(sv, 0, 0, name, 1); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "find_thread_magical: key %d new SV %p for %d\n", + (int)key, sv, (int)*name)); + } + return key; +} +#endif /* USE_THREADS */ + /* Destructor */ void @@ -1152,6 +1179,7 @@ I32 type; goto nomod; /* FALL THROUGH */ case OP_PADSV: + case OP_SPECIFIC: modcount++; if (!type) croak("Can't localize lexical variable %s", @@ -1314,6 +1342,10 @@ I32 type; } break; + case OP_SPECIFIC: + o->op_flags |= OPf_MOD; /* XXX ??? */ + break; + case OP_RV2AV: case OP_RV2HV: o->op_flags |= OPf_REF; @@ -2150,7 +2182,8 @@ OP *repl; else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || - curop->op_type == OP_PADANY) { + curop->op_type == OP_PADANY || + curop->op_type == OP_SPECIFIC) { /* is okay */ } else @@ -3410,8 +3443,8 @@ OP *block; croak(not_safe); else { /* force display of errors found but not reported */ - sv_catpv(GvSV(errgv), not_safe); - croak("%s", SvPVx(GvSV(errgv), na)); + sv_catpv(errsv, not_safe); + croak("%s", SvPV(errsv, na)); } } } @@ -3814,6 +3847,8 @@ OP *o; o->op_ppaddr = ppaddr[OP_PADSV]; return o; } + else if (o->op_type == OP_SPECIFIC) + return o; return newUNOP(OP_RV2SV, 0, scalar(o)); } @@ -349,10 +349,11 @@ typedef enum { OP_GETLOGIN, /* 342 */ OP_SYSCALL, /* 343 */ OP_LOCK, /* 344 */ + OP_SPECIFIC, /* 345 */ OP_max } opcode; -#define MAXO 345 +#define MAXO 346 #ifndef DOINIT EXT char *op_name[]; @@ -703,6 +704,7 @@ EXT char *op_name[] = { "getlogin", "syscall", "lock", + "specific", }; #endif @@ -1055,6 +1057,7 @@ EXT char *op_desc[] = { "getlogin", "syscall", "lock", + "thread-specific", }; #endif @@ -1436,6 +1439,7 @@ OP * pp_egrent _((ARGSproto)); OP * pp_getlogin _((ARGSproto)); OP * pp_syscall _((ARGSproto)); OP * pp_lock _((ARGSproto)); +OP * pp_specific _((ARGSproto)); #ifndef DOINIT EXT OP * (*ppaddr[])(); @@ -1786,6 +1790,7 @@ EXT OP * (*ppaddr[])() = { pp_getlogin, pp_syscall, pp_lock, + pp_specific, }; #endif @@ -2138,6 +2143,7 @@ EXT OP * (*check[]) _((OP *op)) = { ck_null, /* getlogin */ ck_fun, /* syscall */ ck_rfun, /* lock */ + ck_null, /* specific */ }; #endif @@ -2490,5 +2496,6 @@ EXT U32 opargs[] = { 0x0000000c, /* getlogin */ 0x0002151d, /* syscall */ 0x00001c04, /* lock */ + 0x00000044, /* specific */ }; #endif @@ -180,8 +180,6 @@ for (@ops) { $argsum |= 128 if $flags =~ /u/; # defaults to $_ $flags =~ /([^a-zA-Z])/ or die qq[Opcode "$_" has no class indicator]; - printf STDERR "op $_, class $1 => 0x%x, argsum 0x%x", - $opclass{$1}, $argsum; # debug $argsum |= $opclass{$1} << 8; $mul = 4096; # 2 ^ OASHIFT for $arg (split(' ',$args{$_})) { @@ -190,7 +188,6 @@ for (@ops) { $argsum += $argnum * $mul; $mul <<= 4; } - printf STDERR ", argsum now 0x%x\n", $argsum; # debug $argsum = sprintf("0x%08x", $argsum); print "\t", &tab(3, "$argsum,"), "/* $_ */\n"; } @@ -680,3 +677,4 @@ syscall syscall ck_fun imst@ S L # For multi-threading lock lock ck_rfun s% S +specific thread-specific ck_null ds0 @@ -107,9 +107,12 @@ void perl_construct( sv_interp ) register PerlInterpreter *sv_interp; { -#if defined(USE_THREADS) && !defined(FAKE_THREADS) +#ifdef USE_THREADS + int i; +#ifndef FAKE_THREADS struct thread *thr; -#endif +#endif /* FAKE_THREADS */ +#endif /* USE_THREADS */ if (!(curinterp = sv_interp)) return; @@ -121,45 +124,23 @@ register PerlInterpreter *sv_interp; /* Init the real globals (and main thread)? */ if (!linestr) { #ifdef USE_THREADS - XPV *xpv; INIT_THREADS; - Newz(53, thr, 1, struct thread); + if (pthread_key_create(&thr_key, 0)) + croak("panic: pthread_key_create"); MUTEX_INIT(&malloc_mutex); MUTEX_INIT(&sv_mutex); - /* Safe to use SVs from now on */ + /* + * Safe to use basic SV functions from now on (though + * not things like mortals or tainting yet). + */ MUTEX_INIT(&eval_mutex); COND_INIT(&eval_cond); MUTEX_INIT(&threads_mutex); COND_INIT(&nthreads_cond); - nthreads = 1; - cvcache = newHV(); - curcop = &compiling; - thr->flags = THRf_R_JOINABLE; - MUTEX_INIT(&thr->mutex); - thr->next = thr; - thr->prev = thr; - thr->tid = 0; - - /* Handcraft thrsv similarly to mess_sv */ - New(53, thrsv, 1, SV); - Newz(53, xpv, 1, XPV); - SvFLAGS(thrsv) = SVt_PV; - SvANY(thrsv) = (void*)xpv; - SvREFCNT(thrsv) = 1 << 30; /* practically infinite */ - SvPVX(thrsv) = (char*)thr; - SvCUR_set(thrsv, sizeof(thr)); - SvLEN_set(thrsv, sizeof(thr)); - *SvEND(thrsv) = '\0'; /* in the trailing_nul field */ - oursv = thrsv; -#ifdef HAVE_THREAD_INTERN - init_thread_intern(thr); -#else - thr->self = pthread_self(); - if (pthread_key_create(&thr_key, 0)) - croak("panic: pthread_key_create"); -#endif /* HAVE_THREAD_INTERN */ - SET_THR(thr); + MUTEX_INIT(&keys_mutex); + + thr = new_struct_thread(0); #endif /* USE_THREADS */ linestr = NEWSV(65,80); @@ -229,6 +210,9 @@ register PerlInterpreter *sv_interp; fdpid = newAV(); /* for remembering popen pids by fd */ + for (i = 0; i < N_PER_THREAD_MAGICALS; i++) + magical_keys[i] = NOT_IN_PAD; + keys = newSVpv("", 0); init_stacks(ARGS); DEBUG( { New(51,debname,128,char); @@ -487,7 +471,8 @@ register PerlInterpreter *sv_interp; envgv = Nullgv; siggv = Nullgv; incgv = Nullgv; - errgv = Nullgv; + errhv = Nullhv; + errsv = Nullsv; argvgv = Nullgv; argvoutgv = Nullgv; stdingv = Nullgv; @@ -987,8 +972,11 @@ print \" \\@INC:\\n @INC\\n\";"); /* now that script is parsed, we can modify record separator */ SvREFCNT_dec(rs); rs = SvREFCNT_inc(nrs); +#ifdef USE_THREADS + sv_setsv(*av_fetch(thr->specific, find_thread_magical("/"), TRUE), rs); +#else sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs); - +#endif /* USE_THREADS */ if (do_undump) my_unexec(); @@ -1260,7 +1248,7 @@ I32 flags; /* See G_* flags in cop.h */ if (flags & G_KEEPERR) in_eval |= 4; else - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); } markstack_ptr++; @@ -1305,7 +1293,7 @@ I32 flags; /* See G_* flags in cop.h */ runops(); retval = stack_sp - (stack_base + oldmark); if ((flags & G_EVAL) && !(flags & G_KEEPERR)) - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); cleanup: if (flags & G_EVAL) { @@ -1414,7 +1402,7 @@ I32 flags; /* See G_* flags in cop.h */ runops(); retval = stack_sp - (stack_base + oldmark); if (!(flags & G_KEEPERR)) - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); cleanup: JMPENV_POP; @@ -1445,8 +1433,8 @@ I32 croak_on_error; sv = POPs; PUTBACK; - if (croak_on_error && SvTRUE(GvSV(errgv))) - croak(SvPVx(GvSV(errgv), na)); + if (croak_on_error && SvTRUE(errsv)) + croak(SvPV(errsv, na)); return sv; } @@ -1528,6 +1516,8 @@ char *s; switch (*s) { case '0': + { + dTHR; rschar = scan_oct(s, 4, &numlen); SvREFCNT_dec(nrs); if (rschar & ~((U8)~0)) @@ -1539,6 +1529,7 @@ char *s; nrs = newSVpv(&ch, 1); } return s + numlen; + } case 'F': minus_F = TRUE; splitstr = savepv(s + 1); @@ -1625,6 +1616,7 @@ char *s; s += numlen; } else { + dTHR; if (RsPARA(nrs)) { ors = "\n\n"; orslen = 2; @@ -1813,11 +1805,11 @@ init_main_stash() incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); GvMULTI_on(incgv); defgv = gv_fetchpv("_",TRUE, SVt_PVAV); - errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); - GvMULTI_on(errgv); + errsv = newSVpv("", 0); + errhv = newHV(); (void)form("%240s",""); /* Preallocate temp - for immediate signals. */ - sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */ - sv_setpvn(GvSV(errgv), "", 0); + sv_grow(errsv, 240); /* Preallocate - for immediate signals. */ + sv_setpvn(errsv, "", 0); curstash = defstash; compiling.cop_stash = defstash; debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); @@ -2553,7 +2545,11 @@ init_predump_symbols() GV *tmpgv; GV *othergv; +#ifdef USE_THREADS + sv_setpvn(*av_fetch(thr->specific,find_thread_magical("\""),TRUE), " ", 1); +#else sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); +#endif /* USE_THREADS */ stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(stdingv); @@ -2589,6 +2585,7 @@ register int argc; register char **argv; register char **env; { + dTHR; char *s; SV *sv; GV* tmpgv; @@ -2851,7 +2848,7 @@ AV* list; JMPENV_PUSH(ret); switch (ret) { case 0: { - SV* atsv = GvSV(errgv); + SV* atsv = sv_mortalcopy(errsv); PUSHMARK(stack_sp); perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); (void)SvPV(atsv, len); @@ -2913,8 +2910,8 @@ U32 status; dTHR; #ifdef USE_THREADS - DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n", - (unsigned long) thr, (unsigned long) status)); + DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", + thr, (unsigned long) status)); #endif /* USE_THREADS */ switch (status) { case 0: @@ -1338,6 +1338,9 @@ int runops_standard _((void)); int runops_debug _((void)); #endif +#define PER_THREAD_MAGICALS "123456789&`'+/.,\\\";^-%=|~:\001\005!@" +#define N_PER_THREAD_MAGICALS 30 + /****************/ /* Truly global */ /****************/ @@ -1354,6 +1357,7 @@ EXT struct thread * eval_owner; /* Owner thread for doeval */ EXT int nthreads; /* Number of threads currently */ EXT perl_mutex threads_mutex; /* Mutex for nthreads and thread list */ EXT perl_cond nthreads_cond; /* Condition variable for nthreads */ +EXT char * per_thread_magicals INIT(PER_THREAD_MAGICALS); #ifdef FAKE_THREADS EXT struct thread * thr; /* Currently executing (fake) thread */ #endif @@ -1856,7 +1860,8 @@ IEXT I32 Imaxscream IINIT(-1); IEXT SV * Ilastscream; /* shortcuts to misc objects */ -IEXT GV * Ierrgv; +IEXT HV * Ierrhv; +IEXT SV * Ierrsv; /* shortcuts to debugging objects */ IEXT GV * IDBgv; @@ -1965,6 +1970,10 @@ IEXT SV * Imess_sv; #ifdef USE_THREADS /* threads stuff */ IEXT SV * Ithrsv; /* holds struct thread for main thread */ +IEXT perl_mutex Ikeys_mutex; /* protects keys and magical_keys */ +IEXT SV * Ikeys; /* each char marks a per-thread key in-use */ +IEXT PADOFFSET Imagical_keys[N_PER_THREAD_MAGICALS]; + /* index is position in per_thread_magicals */ #endif /* USE_THREADS */ #undef IEXT @@ -396,7 +396,6 @@ SV* sv; else if (SvPADTMP(sv)) sv = newSVsv(sv); else { - dTHR; /* just for SvREFCNT_inc */ SvTEMP_off(sv); (void)SvREFCNT_inc(sv); } @@ -4296,3 +4295,15 @@ PP(pp_lock) SETs(retsv); RETURN; } + +PP(pp_specific) +{ +#ifdef USE_THREADS + dSP; + SV **svp = av_fetch(thr->specific, op->op_targ, TRUE); + XPUSHs(svp ? *svp : &sv_undef); +#else + DIE("tried to access thread-specific data in non-threaded perl"); +#endif /* USE_THREADS */ + RETURN; +} @@ -1040,21 +1040,21 @@ char *message; SV **svp; STRLEN klen = strlen(message); - svp = hv_fetch(GvHV(errgv), message, klen, TRUE); + svp = hv_fetch(errhv, message, klen, TRUE); if (svp) { if (!SvIOK(*svp)) { static char prefix[] = "\t(in cleanup) "; sv_upgrade(*svp, SVt_IV); (void)SvIOK_only(*svp); - SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen); - sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1); - sv_catpvn(GvSV(errgv), message, klen); + SvGROW(errsv, SvCUR(errsv)+sizeof(prefix)+klen); + sv_catpvn(errsv, prefix, sizeof(prefix)-1); + sv_catpvn(errsv, message, klen); } sv_inc(*svp); } } else - sv_setpv(GvSV(errgv), message); + sv_setpv(errsv, message); cxix = dopoptoeval(cxstack_ix); if (cxix >= 0) { @@ -1077,7 +1077,7 @@ char *message; LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(GvSV(errgv), na); + char* msg = SvPV(errsv, na); DIE("%s", *msg ? msg : "Compilation failed in require"); } return pop_return(); @@ -2186,7 +2186,7 @@ int gimme; CvPADLIST(compcv) = comppadlist; if (saveop->op_type != OP_REQUIRE) - CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller); + CvOUTSIDE(compcv) = caller ? (CV*)SvREFCNT_inc(caller) : 0; SAVEFREESV(compcv); @@ -2212,7 +2212,7 @@ int gimme; if (saveop->op_flags & OPf_SPECIAL) in_eval |= 4; else - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); if (yyparse() || error_count || !eval_root) { SV **newsp; I32 gimme; @@ -2231,7 +2231,7 @@ int gimme; lex_end(); LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(GvSV(errgv), na); + char* msg = SvPV(errsv, na); DIE("%s", *msg ? msg : "Compilation failed in require"); } SvREFCNT_dec(rs); @@ -2585,7 +2585,7 @@ PP(pp_leaveeval) LEAVE; if (!(save_flags & OPf_SPECIAL)) - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); RETURNOP(retop); } @@ -2605,7 +2605,7 @@ PP(pp_entertry) eval_root = op; /* Only needed so that goto works right. */ in_eval = 1; - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); PUTBACK; return DOCATCH(op->op_next); } @@ -2653,7 +2653,7 @@ PP(pp_leavetry) curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); RETURN; } @@ -278,11 +278,10 @@ PP(pp_warn) tmps = SvPV(TOPs, na); } if (!tmps || !*tmps) { - SV *error = GvSV(errgv); - (void)SvUPGRADE(error, SVt_PV); - if (SvPOK(error) && SvCUR(error)) - sv_catpv(error, "\t...caught"); - tmps = SvPV(error, na); + (void)SvUPGRADE(errsv, SVt_PV); + if (SvPOK(errsv) && SvCUR(errsv)) + sv_catpv(errsv, "\t...caught"); + tmps = SvPV(errsv, na); } if (!tmps || !*tmps) tmps = "Warning: something's wrong"; @@ -304,11 +303,10 @@ PP(pp_die) tmps = SvPV(TOPs, na); } if (!tmps || !*tmps) { - SV *error = GvSV(errgv); - (void)SvUPGRADE(error, SVt_PV); - if (SvPOK(error) && SvCUR(error)) - sv_catpv(error, "\t...propagated"); - tmps = SvPV(error, na); + (void)SvUPGRADE(errsv, SVt_PV); + if (SvPOK(errsv) && SvCUR(errsv)) + sv_catpv(errsv, "\t...propagated"); + tmps = SvPV(errsv, na); } if (!tmps || !*tmps) tmps = "Died"; @@ -190,6 +190,8 @@ bool io_close _((IO* io)); OP* invert _((OP* cmd)); OP* jmaybe _((OP* arg)); I32 keyword _((char* d, I32 len)); +PADOFFSET key_create _((void)); +void key_destroy _((PADOFFSET key)); void leave_scope _((I32 base)); void lex_end _((void)); void lex_start _((SV* line)); @@ -338,6 +340,9 @@ SV* newSVsv _((SV* old)); OP* newUNOP _((I32 type, I32 flags, OP* first)); OP* newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop, I32 whileline, OP* expr, OP* block, OP* cont)); +#ifdef USE_THREADS +struct thread * new_struct_thread _((struct thread *t)); +#endif PerlIO* nextargv _((GV* gv)); char* ninstr _((char* big, char* bigend, char* little, char* lend)); OP* oopsCV _((OP* o)); @@ -1105,6 +1105,7 @@ sv_setiv(sv,i) register SV *sv; IV i; { + dTHR; /* just for taint */ sv_check_thinkfirst(sv); switch (SvTYPE(sv)) { case SVt_NULL: @@ -1156,6 +1157,7 @@ sv_setnv(sv,num) register SV *sv; double num; { + dTHR; /* just for taint */ sv_check_thinkfirst(sv); switch (SvTYPE(sv)) { case SVt_NULL: @@ -2186,6 +2188,7 @@ register SV *sv; register const char *ptr; register STRLEN len; { + dTHR; /* just for taint */ assert(len >= 0); /* STRLEN is probably unsigned, so this may elicit a warning, but it won't hurt. */ sv_check_thinkfirst(sv); @@ -2212,6 +2215,7 @@ sv_setpv(sv,ptr) register SV *sv; register const char *ptr; { + dTHR; /* just for taint */ register STRLEN len; sv_check_thinkfirst(sv); @@ -2239,6 +2243,7 @@ register SV *sv; register char *ptr; register STRLEN len; { + dTHR; /* just for taint */ sv_check_thinkfirst(sv); if (!SvUPGRADE(sv, SVt_PV)) return; @@ -2303,6 +2308,7 @@ register SV *sv; register char *ptr; register STRLEN len; { + dTHR; /* just for taint */ STRLEN tlen; char *junk; @@ -2335,6 +2341,7 @@ sv_catpv(sv,ptr) register SV *sv; register char *ptr; { + dTHR; /* just for taint */ register STRLEN len; STRLEN tlen; char *junk; @@ -3060,6 +3067,7 @@ register SV *sv; register PerlIO *fp; I32 append; { + dTHR; char *rsptr; STRLEN rslen; register STDCHAR rslast; @@ -3667,6 +3675,7 @@ HV *stash; sv = GvSV(gv); (void)SvOK_off(sv); if (SvTYPE(sv) >= SVt_PV) { + dTHR; /* just for taint */ SvCUR_set(sv, 0); if (SvPVX(sv) != Nullch) *SvPVX(sv) = '\0'; @@ -3907,6 +3916,7 @@ STRLEN *lp; *SvEND(sv) = '\0'; } if (!SvPOK(sv)) { + dTHR; /* just for taint */ SvPOK_on(sv); /* validate pointer */ SvTAINT(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n", @@ -70,17 +70,20 @@ struct io { #define SvANY(sv) (sv)->sv_any #define SvFLAGS(sv) (sv)->sv_flags - #define SvREFCNT(sv) (sv)->sv_refcnt -#ifdef CRIPPLED_CC -#define SvREFCNT_inc(sv) sv_newref((SV*)sv) -#define SvREFCNT_dec(sv) sv_free((SV*)sv) + +#ifdef __GNUC__ +# define SvREFCNT_inc(sv) ({SV *nsv = (SV*)(sv); ++SvREFCNT(nsv); nsv;}) #else -#define SvREFCNT_inc(sv) ((Sv = (SV*)(sv)), \ - (Sv && ++SvREFCNT(Sv)), (SV*)Sv) -#define SvREFCNT_dec(sv) sv_free((SV*)sv) +# if defined(CRIPPLED_CC) || defined(USE_THREADS) +# define SvREFCNT_inc(sv) sv_newref((SV*)sv) +# else +# define SvREFCNT_inc(sv) ((Sv = (SV*)(sv)), ++SvREFCNT(Sv), (SV*)Sv) +# endif #endif +#define SvREFCNT_dec(sv) sv_free((SV*)sv) + #define SVTYPEMASK 0xff #define SvTYPE(sv) ((sv)->sv_flags & SVTYPEMASK) @@ -544,20 +547,32 @@ I32 SvTRUE _((SV *)); ? SvNVX(sv) != 0.0 \ : sv_2bool(sv) ) -#define SvIVx(sv) ((Sv = (sv)), SvIV(Sv)) -#define SvUVx(sv) ((Sv = (sv)), SvUV(Sv)) -#define SvNVx(sv) ((Sv = (sv)), SvNV(Sv)) -#define SvPVx(sv, lp) ((Sv = (sv)), SvPV(Sv, lp)) +#ifdef __GNUC__ +# define SvIVx(sv) ({SV *nsv = (SV*)(sv); SvIV(nsv); }) +# define SvUVx(sv) ({SV *nsv = (SV*)(sv); SvUV(nsv); }) +# define SvNVx(sv) ({SV *nsv = (SV*)(sv); SvNV(nsv); }) +# define SvPVx(sv, lp) ({SV *nsv = (sv); SvPV(nsv, lp); }) +#else +# define SvIVx(sv) ((Sv = (sv)), SvIV(Sv)) +# define SvUVx(sv) ((Sv = (sv)), SvUV(Sv)) +# define SvNVx(sv) ((Sv = (sv)), SvNV(Sv)) +# define SvPVx(sv, lp) ((Sv = (sv)), SvPV(Sv, lp)) +#endif /* __GNUC__ */ + #define SvTRUEx(sv) ((Sv = (sv)), SvTRUE(Sv)) #endif /* CRIPPLED_CC */ #define newRV_inc(sv) newRV(sv) -#ifdef CRIPPLED_CC -SV *newRV_noinc _((SV *)); +#ifdef __GNUC__ +# define newRV_noinc(sv) ({SV *nsv=newRV((sv)); --SvREFCNT(SvRV(nsv)); nsv;}) #else -#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv) -#endif +# if defined(CRIPPLED_CC) || defined(USE_THREADS) +SV *newRV_noinc _((SV *)); +# else +# define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv) +# endif +#endif /* __GNUC__ */ /* the following macro updates any magic values this sv is associated with */ @@ -12,6 +12,7 @@ taint_proper(f, s) const char *f; char *s; { + dTHR; /* just for taint */ char *ug; DEBUG_u(PerlIO_printf(Perl_debug_log, @@ -70,10 +71,12 @@ taint_env() svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE); if (svp && *svp) { if (SvTAINTED(*svp)) { + dTHR; TAINT; taint_proper("Insecure %s%s", "$ENV{PATH}"); } if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) { + dTHR; TAINT; taint_proper("Insecure directory in %s%s", "$ENV{PATH}"); } @@ -83,6 +86,7 @@ taint_env() /* tainted $TERM is okay if it contains no metachars */ svp = hv_fetch(GvHVn(envgv),"TERM",4,FALSE); if (svp && *svp && SvTAINTED(*svp)) { + dTHR; /* just for taint */ bool was_tainted = tainted; char *t = SvPV(*svp, na); char *e = t + na; @@ -101,6 +105,7 @@ taint_env() for (e = misc_env; *e; e++) { svp = hv_fetch(GvHVn(envgv), *e, strlen(*e), FALSE); if (svp && *svp != &sv_undef && SvTAINTED(*svp)) { + dTHR; /* just for taint */ TAINT; taint_proper("Insecure $ENV{%s}%s", *e); } @@ -171,10 +171,25 @@ struct thread { /* Now the fields that used to be "per interpreter" (even when global) */ - /* XXX What about magic variables such as $/, $? and so on? */ + /* Fields used by magic variables such as $@, $/ and so on */ + bool Ttainted; + PMOP * Tcurpm; + SV * Tnrs; + SV * Trs; + GV * Tlast_in_gv; + char * Tofs; + STRLEN Tofslen; + GV * Tdefoutgv; + char * Tchopset; + SV * Tformtarget; + SV * Tbodytarget; + SV * Ttoptarget; + + /* Stashes */ HV * Tdefstash; HV * Tcurstash; + /* Stacks */ SV ** Ttmps_stack; I32 Ttmps_ix; I32 Ttmps_floor; @@ -202,6 +217,7 @@ struct thread { HV * Tcvcache; perl_thread self; /* Underlying thread object */ U32 flags; + AV * specific; /* Thread specific data (& magicals) */ perl_mutex mutex; /* For the fields others can change */ U32 tid; struct thread *next, *prev; /* Circular linked list of threads */ @@ -277,6 +293,18 @@ typedef struct condpair { #undef Xpv #undef statbuf #undef timesbuf +#undef tainted +#undef curpm +#undef nrs +#undef rs +#undef last_in_gv +#undef ofs +#undef ofslen +#undef defoutgv +#undef chopset +#undef formtarget +#undef bodytarget +#undef toptarget #undef top_env #undef runlevel #undef in_eval @@ -323,6 +351,18 @@ typedef struct condpair { #define Xpv (thr->TXpv) #define statbuf (thr->Tstatbuf) #define timesbuf (thr->Ttimesbuf) +#define tainted (thr->Ttainted) +#define tainted (thr->Ttainted) +#define curpm (thr->Tcurpm) +#define nrs (thr->Tnrs) +#define rs (thr->Trs) +#define last_in_gv (thr->Tlast_in_gv) +#define ofs (thr->Tofs) +#define defoutgv (thr->Tdefoutgv) +#define chopset (thr->Tchopset) +#define formtarget (thr->Tformtarget) +#define bodytarget (thr->Tbodytarget) +#define toptarget (thr->Ttoptarget) #define defstash (thr->Tdefstash) #define curstash (thr->Tcurstash) @@ -1256,27 +1256,37 @@ yylex() return PRIVATEREF; } - if (!strchr(tokenbuf,':') - && (tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) { - if (last_lop_op == OP_SORT && - tokenbuf[0] == '$' && - (tokenbuf[1] == 'a' || tokenbuf[1] == 'b') - && !tokenbuf[2]) - { - for (d = in_eval ? oldoldbufptr : linestart; - d < bufend && *d != '\n'; - d++) + if (!strchr(tokenbuf,':')) { +#ifdef USE_THREADS + /* Check for single character per-thread magicals */ + if (tokenbuf[0] == '$' && tokenbuf[2] == '\0' + && (tmp = find_thread_magical(&tokenbuf[1])) != NOT_IN_PAD) { + yylval.opval = newOP(OP_SPECIFIC, 0); + yylval.opval->op_targ = tmp; + return PRIVATEREF; + } +#endif /* USE_THREADS */ + if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) { + if (last_lop_op == OP_SORT && + tokenbuf[0] == '$' && + (tokenbuf[1] == 'a' || tokenbuf[1] == 'b') + && !tokenbuf[2]) { - if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { - croak("Can't use \"my %s\" in sort comparison", - tokenbuf); + for (d = in_eval ? oldoldbufptr : linestart; + d < bufend && *d != '\n'; + d++) + { + if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { + croak("Can't use \"my %s\" in sort comparison", + tokenbuf); + } } } - } - yylval.opval = newOP(OP_PADANY, 0); - yylval.opval->op_targ = tmp; - return PRIVATEREF; + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = tmp; + return PRIVATEREF; + } } /* Force them to make up their mind on "@foo". */ @@ -5413,7 +5423,7 @@ char *s; if (in_eval & 2) warn("%_", msg); else if (in_eval) - sv_catsv(GvSV(errgv), msg); + sv_catsv(errsv, msg); else PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg)); if (++error_count >= 10) @@ -56,6 +56,10 @@ static void xstat _((void)); #endif +#ifdef USE_THREADS +static U32 threadnum = 0; +#endif /* USE_THREADS */ + #ifndef MYMALLOC /* paranoid version of malloc */ @@ -2478,6 +2482,138 @@ SV *sv; } return mg; } + +/* + * Make a new perl thread structure using t as a prototype. If t is NULL + * then this is the initial main thread and we have to bootstrap carefully. + * Some of the fields for the new thread are copied from the prototype + * thread, t, so t should not be running in perl at the time this function + * is called. The usual case, where t is the thread calling new_struct_thread, + * clearly satisfies this constraint. + */ +struct thread * +new_struct_thread(t) +struct thread *t; +{ + struct thread *thr; + XPV *xpv; + SV *sv; + + Newz(53, thr, 1, struct thread); + cvcache = newHV(); + curcop = &compiling; + thr->specific = newAV(); + thr->flags = THRf_R_JOINABLE; + MUTEX_INIT(&thr->mutex); + if (t) { + oursv = newSVpv("", 0); + SvGROW(oursv, sizeof(struct thread) + 1); + SvCUR_set(oursv, sizeof(struct thread)); + thr = (struct thread *) SvPVX(sv); + } else { + /* Handcraft thrsv similarly to mess_sv */ + New(53, thrsv, 1, SV); + Newz(53, xpv, 1, XPV); + SvFLAGS(thrsv) = SVt_PV; + SvANY(thrsv) = (void*)xpv; + SvREFCNT(thrsv) = 1 << 30; /* practically infinite */ + SvPVX(thrsv) = (char*)thr; + SvCUR_set(thrsv, sizeof(thr)); + SvLEN_set(thrsv, sizeof(thr)); + *SvEND(thrsv) = '\0'; /* in the trailing_nul field */ + oursv = thrsv; + } + if (t) { + curcop = t->Tcurcop; /* XXX As good a guess as any? */ + defstash = t->Tdefstash; /* XXX maybe these should */ + curstash = t->Tcurstash; /* always be set to main? */ + /* top_env? */ + /* runlevel */ + tainted = t->Ttainted; + curpm = t->Tcurpm; /* XXX No PMOP ref count */ + nrs = newSVsv(t->Tnrs); + rs = newSVsv(t->Trs); + last_in_gv = (GV*)SvREFCNT_inc(t->Tlast_in_gv); + ofslen = t->Tofslen; + ofs = savepvn(t->Tofs, ofslen); + defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); + chopset = t->Tchopset; + formtarget = newSVsv(t->Tformtarget); + bodytarget = newSVsv(t->Tbodytarget); + toptarget = newSVsv(t->Ttoptarget); + keys = newSVpv("", 0); + } else { + curcop = &compiling; + chopset = " \n-"; + } + MUTEX_LOCK(&threads_mutex); + nthreads++; + thr->tid = threadnum++; + if (t) { + thr->next = t->next; + thr->prev = t; + t->next = thr; + thr->next->prev = thr; + } else { + thr->next = thr; + thr->prev = thr; + } + MUTEX_UNLOCK(&threads_mutex); + +#ifdef HAVE_THREAD_INTERN + init_thread_intern(thr); +#else + thr->self = pthread_self(); +#endif /* HAVE_THREAD_INTERN */ + SET_THR(thr); + if (!t) { + /* + * These must come after the SET_THR because sv_setpvn does + * SvTAINT and the taint fields require dTHR. + */ + toptarget = NEWSV(0,0); + sv_upgrade(toptarget, SVt_PVFM); + sv_setpvn(toptarget, "", 0); + bodytarget = NEWSV(0,0); + sv_upgrade(bodytarget, SVt_PVFM); + sv_setpvn(bodytarget, "", 0); + formtarget = bodytarget; + } + return thr; +} + +PADOFFSET +key_create() +{ + char *s; + STRLEN len; + PADOFFSET i; + MUTEX_LOCK(&keys_mutex); + s = SvPV(keys, len); + for (i = 0; i < len; i++) { + if (!s[i]) { + s[i] = 1; + break; + } + } + if (i == len) + sv_catpvn(keys, "\1", 1); + MUTEX_UNLOCK(&keys_mutex); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "key_create: %d\n", (int)i)); + return i; +} + +void +key_destroy(key) +PADOFFSET key; +{ + char *s; + MUTEX_LOCK(&keys_mutex); + s = SvPVX(keys); + s[key] = 0; + MUTEX_UNLOCK(&keys_mutex); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "key_destroy: %d\n", (int)key)); +} #endif /* USE_THREADS */ #ifdef HUGE_VAL |