X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=9f49b835ffefccdb1daa51e61d02deb4034963af;hb=c7848ba184fac8eca4125f4296d6e09fee2c1846;hp=93e7aa1f10f57d879bb33267306dd2faa4d057ed;hpb=38a1ac3f7341206073b47f38b6bdb094f3f50352;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 93e7aa1..9f49b83 100644 --- a/perl.c +++ b/perl.c @@ -72,7 +72,6 @@ static void init_main_stash _((void)); static void init_perllib _((void)); static void init_postdump_symbols _((int, char **, char **)); static void init_predump_symbols _((void)); -static void init_stacks _((void)); static void my_exit_jump _((void)) __attribute__((noreturn)); static void nuke_stacks _((void)); static void open_script _((char *, bool, SV *)); @@ -81,6 +80,19 @@ static void validate_suid _((char *, char*)); static int fdscript = -1; +#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) +#include +static void +catch_sigsegv(int signo, struct sigcontext_struct sc) +{ + signal(SIGSEGV, SIG_DFL); + fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n" + "return_address = 0x%lx, eip = 0x%lx\n", + sc.cr2, __builtin_return_address(0), sc.eip); + fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR); +} +#endif + PerlInterpreter * perl_alloc() { @@ -95,6 +107,10 @@ void perl_construct( sv_interp ) register PerlInterpreter *sv_interp; { +#if defined(USE_THREADS) && !defined(FAKE_THREADS) + struct thread *thr; +#endif + if (!(curinterp = sv_interp)) return; @@ -102,8 +118,36 @@ register PerlInterpreter *sv_interp; Zero(sv_interp, 1, PerlInterpreter); #endif - /* Init the real globals? */ + /* Init the real globals (and main thread)? */ if (!linestr) { +#ifdef USE_THREADS + INIT_THREADS; + New(53, thr, 1, struct thread); + MUTEX_INIT(&malloc_mutex); + MUTEX_INIT(&sv_mutex); + 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; +#ifdef HAVE_THREAD_INTERN + init_thread_intern(thr); +#else + self = pthread_self(); + if (pthread_key_create(&thr_key, 0)) + croak("panic: pthread_key_create"); + if (pthread_setspecific(thr_key, (void *) thr)) + croak("panic: pthread_setspecific"); +#endif /* FAKE_THREADS */ +#endif /* USE_THREADS */ + linestr = NEWSV(65,80); sv_upgrade(linestr,SVt_PVIV); @@ -122,6 +166,7 @@ register PerlInterpreter *sv_interp; nrs = newSVpv("\n", 1); rs = SvREFCNT_inc(nrs); + sighandlerp = sighandler; pidstatus = newHV(); #ifdef MSDOS @@ -169,7 +214,12 @@ register PerlInterpreter *sv_interp; fdpid = newAV(); /* for remembering popen pids by fd */ - init_stacks(); + init_stacks(ARGS); + DEBUG( { + New(51,debname,128,char); + New(52,debdelim,128,char); + } ) + ENTER; } @@ -177,13 +227,78 @@ void perl_destruct(sv_interp) register PerlInterpreter *sv_interp; { + dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ I32 last_sv_count; HV *hv; + Thread t; if (!(curinterp = sv_interp)) return; +#ifdef USE_THREADS +#ifndef FAKE_THREADS + /* Join with any remaining non-detached threads */ + MUTEX_LOCK(&threads_mutex); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "perl_destruct: waiting for %d threads...\n", + nthreads - 1)); + for (t = thr->next; t != thr; t = t->next) { + MUTEX_LOCK(&t->mutex); + switch (ThrSTATE(t)) { + AV *av; + case THRf_ZOMBIE: + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "perl_destruct: joining zombie %p\n", t)); + ThrSETSTATE(t, THRf_DEAD); + MUTEX_UNLOCK(&t->mutex); + nthreads--; + MUTEX_UNLOCK(&threads_mutex); + if (pthread_join(t->Tself, (void**)&av)) + croak("panic: pthread_join failed during global destruction"); + SvREFCNT_dec((SV*)av); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "perl_destruct: joined zombie %p OK\n", t)); + break; + case THRf_R_JOINABLE: + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "perl_destruct: detaching thread %p\n", t)); + ThrSETSTATE(t, THRf_R_DETACHED); + /* + * We unlock threads_mutex and t->mutex in the opposite order + * from which we locked them just so that DETACH won't + * deadlock if it panics. It's only a breach of good style + * not a bug since they are unlocks not locks. + */ + MUTEX_UNLOCK(&threads_mutex); + DETACH(t); + MUTEX_UNLOCK(&t->mutex); + break; + default: + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "perl_destruct: ignoring %p (state %u)\n", + t, ThrSTATE(t))); + MUTEX_UNLOCK(&t->mutex); + MUTEX_UNLOCK(&threads_mutex); + /* fall through and out */ + } + } + /* Now wait for the thread count nthreads to drop to one */ + while (nthreads > 1) + { + DEBUG_L(PerlIO_printf(PerlIO_stderr(), + "perl_destruct: final wait for %d threads\n", + nthreads - 1)); + COND_WAIT(&nthreads_cond, &threads_mutex); + } + /* At this point, we're the last thread */ + MUTEX_UNLOCK(&threads_mutex); + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n")); + MUTEX_DESTROY(&threads_mutex); + COND_DESTROY(&nthreads_cond); +#endif /* !defined(FAKE_THREADS) */ +#endif /* USE_THREADS */ + destruct_level = perl_destruct_level; #ifdef DEBUGGING { @@ -335,8 +450,10 @@ register PerlInterpreter *sv_interp; /* startup and shutdown function lists */ SvREFCNT_dec(beginav); SvREFCNT_dec(endav); + SvREFCNT_dec(initav); beginav = Nullav; endav = Nullav; + initav = Nullav; /* temp stack during pp_sort() */ SvREFCNT_dec(sortstack); @@ -431,6 +548,12 @@ register PerlInterpreter *sv_interp; hints = 0; /* Reset hints. Should hints be per-interpreter ? */ DEBUG_P(debprofdump()); +#ifdef USE_THREADS + MUTEX_DESTROY(&sv_mutex); + MUTEX_DESTROY(&malloc_mutex); + MUTEX_DESTROY(&eval_mutex); + COND_DESTROY(&eval_cond); +#endif /* USE_THREADS */ /* As the absolutely last thing, free the non-arena SV for mess() */ @@ -461,6 +584,7 @@ int argc; char **argv; char **env; { + dTHR; register SV *sv; register char *s; char *scriptname = NULL; @@ -527,6 +651,7 @@ setuid perl scripts securely.\n"); /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; + FREETMPS; curstash = defstash; if (endav) call_list(oldscope, endav); @@ -693,12 +818,23 @@ print \" \\@INC:\\n @INC\\n\";"); cddir = savepv(s); break; case '-': + if (*++s) { /* catch use of gnu style long options */ + if (strEQ(s, "version")) { + s = "v"; + goto reswitch; + } + if (strEQ(s, "help")) { + s = "h"; + goto reswitch; + } + croak("Unrecognized switch: --%s (-h will show valid options)",s); + } argc--,argv++; goto switch_end; case 0: break; default: - croak("Unrecognized switch: -%s",s); + croak("Unrecognized switch: -%s (-h will show valid options)",s); } } switch_end: @@ -761,6 +897,14 @@ print \" \\@INC:\\n @INC\\n\";"); comppad_name_fill = 0; min_intro_pending = 0; padix = 0; +#ifdef USE_THREADS + av_store(comppad_name, 0, newSVpv("@_", 2)); + curpad[0] = (SV*)newAV(); + SvPADMY_on(curpad[0]); /* XXX Needed? */ + CvOWNER(compcv) = 0; + New(666, CvMUTEXP(compcv), 1, perl_mutex); + MUTEX_INIT(CvMUTEXP(compcv)); +#endif /* USE_THREADS */ comppadlist = newAV(); AvREAL_off(comppadlist); @@ -771,10 +915,14 @@ print \" \\@INC:\\n @INC\\n\";"); boot_core_UNIVERSAL(); if (xsinit) (*xsinit)(); /* in case linked C routines want magical variables */ -#ifdef VMS +#if defined(VMS) || defined(WIN32) init_os_extras(); #endif +#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) + DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv);); +#endif + init_predump_symbols(); if (!do_undump) init_postdump_symbols(argc,argv,env); @@ -830,6 +978,7 @@ int perl_run(sv_interp) PerlInterpreter *sv_interp; { + dTHR; I32 oldscope; dJMPENV; int ret; @@ -848,10 +997,10 @@ PerlInterpreter *sv_interp; /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; + FREETMPS; curstash = defstash; if (endav) call_list(oldscope, endav); - FREETMPS; #ifdef MYMALLOC if (getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); @@ -878,13 +1027,19 @@ PerlInterpreter *sv_interp; if (!restartop) { DEBUG_x(dump_all()); DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); +#ifdef USE_THREADS + DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n", + (unsigned long) thr)); +#endif /* USE_THREADS */ if (minus_c) { PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename); my_exit(0); } - if (perldb && DBsingle) + if (PERLDB_SINGLE && DBsingle) sv_setiv(DBsingle, 1); + if (initav) + call_list(oldscope, initav); } /* do it */ @@ -966,6 +1121,7 @@ char *subname; I32 flags; /* See G_* flags in cop.h */ register char **argv; /* null terminated arg list */ { + dTHR; dSP; PUSHMARK(sp); @@ -992,13 +1148,14 @@ perl_call_method(methname, flags) char *methname; /* name of the subroutine */ I32 flags; /* See G_* flags in cop.h */ { + dTHR; dSP; OP myop; if (!op) op = &myop; XPUSHs(sv_2mortal(newSVpv(methname,0))); PUTBACK; - pp_method(); + pp_method(ARGS); return perl_call_sv(*stack_sp--, flags); } @@ -1008,6 +1165,7 @@ perl_call_sv(sv, flags) SV* sv; I32 flags; /* See G_* flags in cop.h */ { + dTHR; LOGOP myop; /* fake syntax tree node */ SV** sp = stack_sp; I32 oldmark; @@ -1017,6 +1175,7 @@ I32 flags; /* See G_* flags in cop.h */ bool oldcatch = CATCH_GET; dJMPENV; int ret; + OP* oldop = op; if (flags & G_DISCARD) { ENTER; @@ -1030,7 +1189,7 @@ I32 flags; /* See G_* flags in cop.h */ myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : (flags & G_ARRAY) ? OPf_WANT_LIST : OPf_WANT_SCALAR); - SAVESPTR(op); + SAVEOP(); op = (OP*)&myop; EXTEND(stack_sp, 1); @@ -1038,7 +1197,7 @@ I32 flags; /* See G_* flags in cop.h */ oldmark = TOPMARK; oldscope = scopestack_ix; - if (perldb && curstash != debstash + if (PERLDB_SUB && curstash != debstash /* Handle first BEGIN of -d. */ && (DBcv || (DBcv = GvCV(DBsub))) /* Try harder, since this may have been a sighandler, thus @@ -1106,7 +1265,7 @@ I32 flags; /* See G_* flags in cop.h */ CATCH_SET(TRUE); if (op == (OP*)&myop) - op = pp_entersub(); + op = pp_entersub(ARGS); if (op) runops(); retval = stack_sp - (stack_base + oldmark); @@ -1139,6 +1298,7 @@ I32 flags; /* See G_* flags in cop.h */ FREETMPS; LEAVE; } + op = oldop; return retval; } @@ -1149,6 +1309,7 @@ perl_eval_sv(sv, flags) SV* sv; I32 flags; /* See G_* flags in cop.h */ { + dTHR; UNOP myop; /* fake syntax tree node */ SV** sp = stack_sp; I32 oldmark = sp - stack_base; @@ -1156,13 +1317,14 @@ I32 flags; /* See G_* flags in cop.h */ I32 oldscope; dJMPENV; int ret; - + OP* oldop = op; + if (flags & G_DISCARD) { ENTER; SAVETMPS; } - SAVESPTR(op); + SAVEOP(); op = (OP*)&myop; Zero(op, 1, UNOP); EXTEND(stack_sp, 1); @@ -1212,7 +1374,7 @@ I32 flags; /* See G_* flags in cop.h */ } if (op == (OP*)&myop) - op = pp_entereval(); + op = pp_entereval(ARGS); if (op) runops(); retval = stack_sp - (stack_base + oldmark); @@ -1227,6 +1389,7 @@ I32 flags; /* See G_* flags in cop.h */ FREETMPS; LEAVE; } + op = oldop; return retval; } @@ -1235,6 +1398,7 @@ perl_eval_pv(p, croak_on_error) char* p; I32 croak_on_error; { + dTHR; dSP; SV* sv = newSVpv(p, 0); @@ -1292,10 +1456,10 @@ char *name; printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile]."); printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional."); printf("\n -i[extension] edit <> files in place (make backup if extension supplied)"); - printf("\n -Idirectory specify @INC/#include directory (may be used more then once)"); - printf("\n -l[octal] enable line ending processing, specifies line teminator"); + printf("\n -Idirectory specify @INC/#include directory (may be used more than once)"); + printf("\n -l[octal] enable line ending processing, specifies line terminator"); printf("\n -[mM][-]module.. executes `use/no module...' before executing your script."); - printf("\n -n assume 'while (<>) { ... }' loop arround your script"); + printf("\n -n assume 'while (<>) { ... }' loop around your script"); printf("\n -p assume loop like -n but print line also like sed"); printf("\n -P run script through C preprocessor before compilation"); printf("\n -s enable some switch parsing for switches after script name"); @@ -1305,7 +1469,7 @@ char *name; printf("\n -U allow unsafe operations"); printf("\n -v print version number and patchlevel of perl"); printf("\n -V[:variable] print perl configuration information"); - printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT."); + printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended."); printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n"); } @@ -1352,7 +1516,7 @@ char *s; s += strlen(s); } if (!perldb) { - perldb = TRUE; + perldb = PERLDB_ALL; init_debugger(); } return s; @@ -1430,30 +1594,31 @@ char *s; forbid_setid("-m"); /* XXX ? */ if (*++s) { char *start; + SV *sv; char *use = "use "; /* -M-foo == 'no foo' */ if (*s == '-') { use = "no "; ++s; } - Sv = newSVpv(use,0); + sv = newSVpv(use,0); start = s; /* We allow -M'Module qw(Foo Bar)' */ while(isALNUM(*s) || *s==':') ++s; if (*s != '=') { - sv_catpv(Sv, start); + sv_catpv(sv, start); if (*(start-1) == 'm') { if (*s != '\0') croak("Can't use '%c' after -mname", *s); - sv_catpv( Sv, " ()"); + sv_catpv( sv, " ()"); } } else { - sv_catpvn(Sv, start, s-start); - sv_catpv(Sv, " split(/,/,q{"); - sv_catpv(Sv, ++s); - sv_catpv(Sv, "})"); + sv_catpvn(sv, start, s-start); + sv_catpv(sv, " split(/,/,q{"); + sv_catpv(sv, ++s); + sv_catpv(sv, "})"); } s += strlen(s); if (preambleav == NULL) preambleav = newAV(); - av_push(preambleav, Sv); + av_push(preambleav, sv); } else croak("No space allowed after -%c", *(s-1)); @@ -1573,6 +1738,7 @@ my_unexec() static void init_main_stash() { + dTHR; GV *gv; /* Note that strtab is a rather special HV. Assumptions are made @@ -1595,6 +1761,8 @@ init_main_stash() defgv = gv_fetchpv("_",TRUE, SVt_PVAV); errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); GvMULTI_on(errgv); + (void)form("%240s",""); /* Preallocate temp - for immediate signals. */ + sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */ sv_setpvn(GvSV(errgv), "", 0); curstash = defstash; compiling.cop_stash = defstash; @@ -1614,6 +1782,7 @@ bool dosearch; SV *sv; #endif { + dTHR; char *xfound = Nullch; char *xfailed = Nullch; register char *s; @@ -1623,6 +1792,10 @@ SV *sv; # define SEARCH_EXTS ".bat", ".cmd", NULL # define MAX_EXT_LEN 4 #endif +#ifdef OS2 +# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL +# define MAX_EXT_LEN 4 +#endif #ifdef VMS # define SEARCH_EXTS ".pl", ".com", NULL # define MAX_EXT_LEN 4 @@ -1630,14 +1803,35 @@ SV *sv; /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS char *ext[] = { SEARCH_EXTS }; - int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */ + int extidx = 0, i = 0; + char *curext = Nullch; #else # define MAX_EXT_LEN 0 #endif + /* + * If dosearch is true and if scriptname does not contain path + * delimiters, search the PATH for scriptname. + * + * If SEARCH_EXTS is also defined, will look for each + * scriptname{SEARCH_EXTS} whenever scriptname is not found + * while searching the PATH. + * + * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search + * proceeds as follows: + * If DOSISH: + * + look for ./scriptname{,.foo,.bar} + * + search the PATH for scriptname{,.foo,.bar} + * + * If !DOSISH: + * + look *only* in the PATH for scriptname{,.foo,.bar} (note + * this will not look in '.' if it's not in the PATH) + */ + #ifdef VMS if (dosearch) { int hasdir, idx = 0, deftypes = 1; + bool seen_dot = 1; hasdir = (strpbrk(scriptname,":[= 0) { + dosearch = 0; + scriptname = cur; +#ifdef SEARCH_EXTS + break; +#endif + } +#ifdef SEARCH_EXTS + if (cur == scriptname) { + len = strlen(scriptname); + if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf)) + break; + cur = strcpy(tokenbuf, scriptname); + } + } while (extidx >= 0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+len, ext[extidx++])); +#endif + } +#endif + + if (dosearch && !strchr(scriptname, '/') +#ifdef DOSISH + && !strchr(scriptname, '\\') #endif - &len); -#else /* atarist */ - for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) { + && (s = getenv("PATH"))) { + bool seen_dot = 0; + + bufend = s + strlen(s); + while (s < bufend) { +#if defined(atarist) || defined(DOSISH) + for (len = 0; *s +# ifdef atarist + && *s != ',' +# endif + && *s != ';'; len++, s++) { if (len < sizeof tokenbuf) tokenbuf[len] = *s; } if (len < sizeof tokenbuf) tokenbuf[len] = '\0'; -#endif /* atarist */ +#else /* ! (atarist || DOSISH) */ + s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, + ':', + &len); +#endif /* ! (atarist || DOSISH) */ if (s < bufend) s++; if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) continue; /* don't search dir with too-long name */ if (len -#if defined(atarist) && !defined(DOSISH) - && tokenbuf[len - 1] != '/' -#endif #if defined(atarist) || defined(DOSISH) + && tokenbuf[len - 1] != '/' && tokenbuf[len - 1] != '\\' #endif ) tokenbuf[len++] = '/'; + if (len == 2 && tokenbuf[0] == '.') + seen_dot = 1; (void)strcpy(tokenbuf + len, scriptname); #endif /* !VMS */ @@ -1718,8 +1955,16 @@ SV *sv; if (!xfailed) xfailed = savepv(tokenbuf); } +#ifndef DOSISH + if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0)) +#endif + seen_dot = 1; /* Disable message. */ if (!xfound) - croak("Can't execute %s", xfailed ? xfailed : scriptname ); + croak("Can't %s %s%s%s", + (xfailed ? "execute" : "find"), + (xfailed ? xfailed : scriptname), + (xfailed ? "" : " on PATH"), + (xfailed || seen_dot) ? "" : ", '.' not in PATH"); if (xfailed) Safefree(xfailed); scriptname = xfound; @@ -2075,6 +2320,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #else /* !DOSUID */ if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW + dTHR; Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || @@ -2145,6 +2391,7 @@ char *s; static void init_debugger() { + dTHR; curstash = debstash; dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); AvREAL_off(dbargs); @@ -2160,8 +2407,9 @@ init_debugger() curstash = defstash; } -static void -init_stacks() +void +init_stacks(ARGS) +dARGS { curstack = newAV(); mainstack = curstack; /* remember in case we switch stacks */ @@ -2177,14 +2425,10 @@ init_stacks() cxstack_ix = -1; New(50,tmps_stack,128,SV*); + tmps_floor = -1; tmps_ix = -1; tmps_max = 128; - DEBUG( { - New(51,debname,128,char); - New(52,debdelim,128,char); - } ) - /* * The following stacks almost certainly should be per-interpreter, * but for now they're not. XXX @@ -2226,6 +2470,7 @@ init_stacks() static void nuke_stacks() { + dTHR; Safefree(cxstack); Safefree(tmps_stack); DEBUG( { @@ -2240,6 +2485,7 @@ static void init_lexer() { tmpfp = rsfp; + rsfp = Nullfp; lex_start(linestr); rsfp = tmpfp; subname = newSVpv("main",4); @@ -2248,6 +2494,7 @@ init_lexer() static void init_predump_symbols() { + dTHR; GV *tmpgv; GV *othergv; @@ -2535,6 +2782,7 @@ call_list(oldscope, list) I32 oldscope; AV* list; { + dTHR; line_t oldline = curcop->cop_line; STRLEN len; dJMPENV; @@ -2573,10 +2821,10 @@ AV* list; /* my_exit() was called */ while (scopestack_ix > oldscope) LEAVE; + FREETMPS; curstash = defstash; if (endav) call_list(oldscope, endav); - FREETMPS; JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; @@ -2607,6 +2855,12 @@ void my_exit(status) 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)); +#endif /* USE_THREADS */ switch (status) { case 0: STATUS_ALL_SUCCESS; @@ -2647,6 +2901,7 @@ my_failure_exit() static void my_exit_jump() { + dTHR; register CONTEXT *cx; I32 gimme; SV **newsp;