diff options
| -rw-r--r-- | av.c | 12 | ||||
| -rw-r--r-- | cop.h | 75 | ||||
| -rw-r--r-- | deb.c | 2 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | embedvar.h | 22 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | gv.c | 11 | ||||
| -rw-r--r-- | interp.sym | 5 | ||||
| -rw-r--r-- | intrpvar.h | 2 | ||||
| -rw-r--r-- | mg.c | 41 | ||||
| -rw-r--r-- | op.c | 2 | ||||
| -rw-r--r-- | perl.c | 38 | ||||
| -rw-r--r-- | pp.h | 13 | ||||
| -rw-r--r-- | pp_ctl.c | 21 | ||||
| -rw-r--r-- | pp_sys.c | 28 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | scope.c | 20 | ||||
| -rw-r--r-- | sv.c | 6 | ||||
| -rwxr-xr-x | t/op/runlevel.t | 262 | ||||
| -rw-r--r-- | thrdvar.h | 5 | ||||
| -rw-r--r-- | util.c | 7 |
21 files changed, 317 insertions, 258 deletions
@@ -53,12 +53,14 @@ av_extend(AV *av, I32 key) dSP; ENTER; SAVETMPS; + PUSHSTACK(SI_MAGIC); PUSHMARK(SP); EXTEND(SP,2); PUSHs(mg->mg_obj); PUSHs(sv_2mortal(newSViv(key+1))); PUTBACK; perl_call_method("EXTEND", G_SCALAR|G_DISCARD); + POPSTACK(); FREETMPS; LEAVE; return; @@ -388,6 +390,7 @@ av_push(register AV *av, SV *val) if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { dSP; + PUSHSTACK(SI_MAGIC); PUSHMARK(SP); EXTEND(SP,2); PUSHs(mg->mg_obj); @@ -396,6 +399,7 @@ av_push(register AV *av, SV *val) ENTER; perl_call_method("PUSH", G_SCALAR|G_DISCARD); LEAVE; + POPSTACK(); return; } av_store(av,AvFILLp(av)+1,val); @@ -413,6 +417,7 @@ av_pop(register AV *av) croak(no_modify); if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { dSP; + PUSHSTACK(SI_MAGIC); PUSHMARK(SP); XPUSHs(mg->mg_obj); PUTBACK; @@ -423,6 +428,7 @@ av_pop(register AV *av) retval = &sv_undef; } LEAVE; + POPSTACK(); return retval; } retval = AvARRAY(av)[AvFILLp(av)]; @@ -446,6 +452,7 @@ av_unshift(register AV *av, register I32 num) if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { dSP; + PUSHSTACK(SI_MAGIC); PUSHMARK(SP); EXTEND(SP,1+num); PUSHs(mg->mg_obj); @@ -456,6 +463,7 @@ av_unshift(register AV *av, register I32 num) ENTER; perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD); LEAVE; + POPSTACK(); return; } @@ -495,6 +503,7 @@ av_shift(register AV *av) croak(no_modify); if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { dSP; + PUSHSTACK(SI_MAGIC); PUSHMARK(SP); XPUSHs(mg->mg_obj); PUTBACK; @@ -505,6 +514,7 @@ av_shift(register AV *av) retval = &sv_undef; } LEAVE; + POPSTACK(); return retval; } retval = *AvARRAY(av); @@ -536,12 +546,14 @@ av_fill(register AV *av, I32 fill) dSP; ENTER; SAVETMPS; + PUSHSTACK(SI_MAGIC); PUSHMARK(SP); EXTEND(SP,2); PUSHs(mg->mg_obj); PUSHs(sv_2mortal(newSViv(fill+1))); PUTBACK; perl_call_method("STORESIZE", G_SCALAR|G_DISCARD); + POPSTACK(); FREETMPS; LEAVE; return; @@ -285,3 +285,78 @@ struct context { #define G_EVAL 4 /* Assume eval {} around subroutine call. */ #define G_NOARGS 8 /* Don't construct a @_ array. */ #define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */ + +/* Support for switching (stack and block) contexts. + * This ensures magic doesn't invalidate local stack and cx pointers. + */ + +#define SI_UNDEF 0 +#define SI_MAIN 1 +#define SI_MAGIC 2 +#define SI_SORT 3 +#define SI_SIGNAL 4 +#define SI_OVERLOAD 5 +#define SI_DESTROY 6 +/* XXX todo +#define SI_WARNHOOK 7 +#define SI_DIEHOOK 8 +*/ + +struct stackinfo { + AV * si_stack; /* stack for current runlevel */ + PERL_CONTEXT * si_cxstack; /* context stack for runlevel */ + I32 si_cxix; /* current context index */ + I32 si_cxmax; /* maximum allocated index */ + I32 si_type; /* type of runlevel */ + struct stackinfo * si_prev; + struct stackinfo * si_next; + I32 * si_markbase; /* where markstack begins for us. + * currently used only with DEBUGGING, + * but not #ifdef-ed for bincompat */ +}; + +typedef struct stackinfo PERL_SI; + +#define cxstack (curstackinfo->si_cxstack) +#define cxstack_ix (curstackinfo->si_cxix) +#define cxstack_max (curstackinfo->si_cxmax) + +#ifdef DEBUGGING +# define SET_MARKBASE curstackinfo->si_markbase = markstack_ptr +#else +# define SET_MARKBASE NOOP +#endif + +#define PUSHSTACK(type) \ + STMT_START { \ + PERL_SI *next = curstackinfo->si_next; \ + if (!next) { \ + next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \ + next->si_prev = curstackinfo; \ + curstackinfo->si_next = next; \ + } \ + next->si_type = type; \ + next->si_cxix = -1; \ + AvFILLp(next->si_stack) = 0; \ + SWITCHSTACK(curstack,next->si_stack); \ + curstackinfo = next; \ + SET_MARKBASE; \ + } STMT_END + +#define POPSTACK() \ + STMT_START { \ + PERL_SI *prev = curstackinfo->si_prev; \ + if (!prev) { \ + PerlIO_printf(PerlIO_stderr(), "panic: POPSTACK\n"); \ + my_exit(1); \ + } \ + SWITCHSTACK(curstack,prev->si_stack); \ + /* don't free prev here, free them all at the END{} */ \ + curstackinfo = prev; \ + } STMT_END + +#define POPSTACK_TO(s) \ + STMT_START { \ + while (curstack != s) \ + POPSTACK(); \ + } STMT_END @@ -115,7 +115,7 @@ debstack(void) dTHR; I32 top = stack_sp - stack_base; register I32 i = top - 30; - I32 *markscan = markstack; + I32 *markscan = curstackinfo->si_markbase; if (i < 0) i = 0; @@ -406,6 +406,7 @@ #define newWHILEOP Perl_newWHILEOP #define newXS Perl_newXS #define newXSUB Perl_newXSUB +#define new_stackinfo Perl_new_stackinfo #define new_struct_thread Perl_new_struct_thread #define nextargv Perl_nextargv #define ninstr Perl_ninstr diff --git a/embedvar.h b/embedvar.h index 1b93609d8c..667edab2fd 100644 --- a/embedvar.h +++ b/embedvar.h @@ -29,10 +29,8 @@ #define curpad (curinterp->Tcurpad) #define curpm (curinterp->Tcurpm) #define curstack (curinterp->Tcurstack) +#define curstackinfo (curinterp->Tcurstackinfo) #define curstash (curinterp->Tcurstash) -#define cxstack (curinterp->Tcxstack) -#define cxstack_ix (curinterp->Tcxstack_ix) -#define cxstack_max (curinterp->Tcxstack_max) #define defoutgv (curinterp->Tdefoutgv) #define defstash (curinterp->Tdefstash) #define delaymagic (curinterp->Tdelaymagic) @@ -174,9 +172,7 @@ #define screamnext (curinterp->Iscreamnext) #define secondgv (curinterp->Isecondgv) #define siggv (curinterp->Isiggv) -#define signalstack (curinterp->Isignalstack) #define sortcop (curinterp->Isortcop) -#define sortstack (curinterp->Isortstack) #define sortstash (curinterp->Isortstash) #define splitstr (curinterp->Isplitstr) #define statcache (curinterp->Istatcache) @@ -292,9 +288,7 @@ #define Iscreamnext screamnext #define Isecondgv secondgv #define Isiggv siggv -#define Isignalstack signalstack #define Isortcop sortcop -#define Isortstack sortstack #define Isortstash sortstash #define Isplitstr splitstr #define Istatcache statcache @@ -326,10 +320,8 @@ #define Tcurpad curpad #define Tcurpm curpm #define Tcurstack curstack +#define Tcurstackinfo curstackinfo #define Tcurstash curstash -#define Tcxstack cxstack -#define Tcxstack_ix cxstack_ix -#define Tcxstack_max cxstack_max #define Tdefoutgv defoutgv #define Tdefstash defstash #define Tdelaymagic delaymagic @@ -473,9 +465,7 @@ #define screamnext Perl_screamnext #define secondgv Perl_secondgv #define siggv Perl_siggv -#define signalstack Perl_signalstack #define sortcop Perl_sortcop -#define sortstack Perl_sortstack #define sortstash Perl_sortstash #define splitstr Perl_splitstr #define statcache Perl_statcache @@ -507,10 +497,8 @@ #define curpad Perl_curpad #define curpm Perl_curpm #define curstack Perl_curstack +#define curstackinfo Perl_curstackinfo #define curstash Perl_curstash -#define cxstack Perl_cxstack -#define cxstack_ix Perl_cxstack_ix -#define cxstack_max Perl_cxstack_max #define defoutgv Perl_defoutgv #define defstash Perl_defstash #define delaymagic Perl_delaymagic @@ -572,10 +560,8 @@ #define curpad (thr->Tcurpad) #define curpm (thr->Tcurpm) #define curstack (thr->Tcurstack) +#define curstackinfo (thr->Tcurstackinfo) #define curstash (thr->Tcurstash) -#define cxstack (thr->Tcxstack) -#define cxstack_ix (thr->Tcxstack_ix) -#define cxstack_max (thr->Tcxstack_max) #define defoutgv (thr->Tdefoutgv) #define defstash (thr->Tdefstash) #define delaymagic (thr->Tdelaymagic) diff --git a/global.sym b/global.sym index 26c25283b0..43a223ebd7 100644 --- a/global.sym +++ b/global.sym @@ -53,6 +53,7 @@ ncmp_amg ne_amg neg_amg new_struct_thread +new_stackinfo no_aelem no_dir_func no_func @@ -639,11 +639,6 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) psig_ptr[i] = 0; psig_name[i] = 0; } - /* initialize signal stack */ - signalstack = newAV(); - AvREAL_off(signalstack); - av_extend(signalstack, 30); - av_fill(signalstack, 0); } break; @@ -1094,9 +1089,6 @@ Gv_AMupdate(HV *stash) return FALSE; } -/* During call to this subroutine stack can be reallocated. It is - * advised to call SPAGAIN macro in your code after call */ - SV* amagic_call(SV *left, SV *right, int method, int flags) { @@ -1311,6 +1303,7 @@ amagic_call(SV *left, SV *right, int method, int flags) myop.op_next = Nullop; myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; + PUSHSTACK(SI_OVERLOAD); ENTER; SAVEOP(); op = (OP *) &myop; @@ -1335,7 +1328,7 @@ amagic_call(SV *left, SV *right, int method, int flags) SPAGAIN; res=POPs; - PUTBACK; + POPSTACK(); CATCH_SET(oldcatch); if (postpr) { diff --git a/interp.sym b/interp.sym index 5453afa064..3e06da36ed 100644 --- a/interp.sym +++ b/interp.sym @@ -21,9 +21,6 @@ curpm curstack curstash curstname -cxstack -cxstack_ix -cxstack_max dbargs debdelim debname @@ -114,9 +111,7 @@ screamfirst screamnext secondgv siggv -signalstack sortcop -sortstack sortstash splitstr start_env diff --git a/intrpvar.h b/intrpvar.h index be081be3d5..59f7e098db 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -138,8 +138,6 @@ PERLVAR(Isortcop, OP *) /* user defined sort routine */ PERLVAR(Isortstash, HV *) /* which is in some package or other */ PERLVAR(Ifirstgv, GV *) /* $a */ PERLVAR(Isecondgv, GV *) /* $b */ -PERLVAR(Isortstack, AV *) /* temp stack during pp_sort() */ -PERLVAR(Isignalstack, AV *) /* temp stack during sighandler() */ PERLVAR(Imystrk, SV *) /* temp key string for do_each() */ PERLVAR(Idumplvl, I32) /* indentation level on syntax tree dump */ PERLVAR(Ioldlastpm, PMOP *) /* for saving regexp context during debugger */ @@ -954,6 +954,7 @@ magic_setnkeys(SV *sv, MAGIC *mg) return 0; } +/* caller is responsible for stack switching/cleanup */ static int magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val) { @@ -988,11 +989,13 @@ magic_methpack(SV *sv, MAGIC *mg, char *meth) ENTER; SAVETMPS; + PUSHSTACK(SI_MAGIC); if (magic_methcall(mg, meth, G_SCALAR, 2, NULL)) { sv_setsv(sv, *stack_sp--); } + POPSTACK(); FREETMPS; LEAVE; return 0; @@ -1009,9 +1012,12 @@ magic_getpack(SV *sv, MAGIC *mg) int magic_setpack(SV *sv, MAGIC *mg) -{ +{ + dSP; ENTER; + PUSHSTACK(SI_MAGIC); magic_methcall(mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); + POPSTACK(); LEAVE; return 0; } @@ -1026,15 +1032,17 @@ magic_clearpack(SV *sv, MAGIC *mg) U32 magic_sizepack(SV *sv, MAGIC *mg) { - dTHR; + dSP; U32 retval = 0; ENTER; SAVETMPS; + PUSHSTACK(SI_MAGIC); if (magic_methcall(mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { sv = *stack_sp--; retval = (U32) SvIV(sv)-1; } + POPSTACK(); FREETMPS; LEAVE; return retval; @@ -1044,11 +1052,13 @@ int magic_wipepack(SV *sv, MAGIC *mg) { dSP; + ENTER; + PUSHSTACK(SI_MAGIC); PUSHMARK(SP); XPUSHs(mg->mg_obj); PUTBACK; - ENTER; perl_call_method("CLEAR", G_SCALAR|G_DISCARD); + POPSTACK(); LEAVE; return 0; } @@ -1061,6 +1071,7 @@ magic_nextpack(SV *sv, MAGIC *mg, SV *key) ENTER; SAVETMPS; + PUSHSTACK(SI_MAGIC); PUSHMARK(SP); EXTEND(SP, 2); PUSHs(mg->mg_obj); @@ -1071,6 +1082,7 @@ magic_nextpack(SV *sv, MAGIC *mg, SV *key) if (perl_call_method(meth, G_SCALAR)) sv_setsv(key, *stack_sp--); + POPSTACK(); FREETMPS; LEAVE; return 0; @@ -1803,17 +1815,13 @@ sighandler(int sig) HV *st; SV *sv, *tSv = Sv; CV *cv = Nullcv; - AV *oldstack; OP *myop = op; U32 flags = 0; I32 o_save_i = savestack_ix, type; - PERL_CONTEXT *cx; XPV *tXpv = Xpv; if (savestack_ix + 15 <= savestack_max) flags |= 1; - if (cxstack_ix < cxstack_max - 2) - flags |= 2; if (markstack_ptr < markstack_max - 2) flags |= 4; if (retstack_ix < retstack_max - 2) @@ -1821,12 +1829,6 @@ sighandler(int sig) if (scopestack_ix < scopestack_max - 3) flags |= 16; - if (flags & 2) { /* POPBLOCK may decrease cxstack too early. */ - cxstack_ix++; /* Protect from overwrite. */ - cx = &cxstack[cxstack_ix]; - type = cx->cx_type; /* Can be during partial write. */ - cx->cx_type = CXt_NULL; /* Make it safe for unwind. */ - } if (!psig_ptr[sig]) die("Signal SIG%s received, but no signal handler set.\n", sig_name[sig]); @@ -1861,11 +1863,6 @@ sighandler(int sig) goto cleanup; } - oldstack = curstack; - if (curstack != signalstack) - AvFILLp(signalstack) = 0; - SWITCHSTACK(curstack, signalstack); - if(psig_name[sig]) { sv = SvREFCNT_inc(psig_name[sig]); flags |= 64; @@ -1874,20 +1871,18 @@ sighandler(int sig) sv = sv_newmortal(); sv_setpv(sv,sig_name[sig]); } + + PUSHSTACK(SI_SIGNAL); PUSHMARK(SP); PUSHs(sv); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - SWITCHSTACK(signalstack, oldstack); + POPSTACK(); cleanup: if (flags & 1) savestack_ix -= 8; /* Unprotect save in progress. */ - if (flags & 2) { - cxstack[cxstack_ix].cx_type = type; - cxstack_ix -= 1; - } if (flags & 4) markstack_ptr--; if (flags & 8) @@ -3330,7 +3330,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) goto done; } /* ahem, death to those who redefine active sort subs */ - if (curstack == sortstack && sortcop == CvSTART(cv)) + if (curstackinfo->si_type == SI_SORT && sortcop == CvSTART(cv)) croak("Can't redefine active sort subroutine %s", name); const_sv = cv_const_sv(cv); if (const_sv || dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv)) @@ -423,10 +423,6 @@ perl_destruct(register PerlInterpreter *sv_interp) endav = Nullav; initav = Nullav; - /* temp stack during pp_sort() */ - SvREFCNT_dec(sortstack); - sortstack = Nullav; - /* shortcuts just get cleared */ envgv = Nullgv; siggv = Nullgv; @@ -955,7 +951,7 @@ print \" \\@INC:\\n @INC\\n\";"); int perl_run(PerlInterpreter *sv_interp) { - dTHR; + dSP; I32 oldscope; dJMPENV; int ret; @@ -991,10 +987,7 @@ perl_run(PerlInterpreter *sv_interp) JMPENV_POP; return 1; } - if (curstack != mainstack) { - dSP; - SWITCHSTACK(curstack, mainstack); - } + POPSTACK_TO(mainstack); break; } @@ -2410,19 +2403,16 @@ init_debugger(void) void init_stacks(ARGSproto) { - curstack = newAV(); + /* start with 128-item stack and 8K cxstack */ + curstackinfo = new_stackinfo(REASONABLE(128), + REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); + curstackinfo->si_type = SI_MAIN; + curstack = curstackinfo->si_stack; mainstack = curstack; /* remember in case we switch stacks */ - AvREAL_off(curstack); /* not a real array */ - av_extend(curstack,REASONABLE(127)); stack_base = AvARRAY(curstack); stack_sp = stack_base; - stack_max = stack_base + REASONABLE(127); - - /* Use most of 8K. */ - cxstack_max = REASONABLE(8192 / sizeof(PERL_CONTEXT) - 2); - New(50,cxstack,cxstack_max + 1,PERL_CONTEXT); - cxstack_ix = -1; + stack_max = stack_base + AvMAX(curstack); New(50,tmps_stack,REASONABLE(128),SV*); tmps_floor = -1; @@ -2442,6 +2432,8 @@ init_stacks(ARGSproto) markstack_max = markstack + REASONABLE(32); } + SET_MARKBASE; + if (scopestack) { scopestack_ix = 0; } else { @@ -2473,7 +2465,15 @@ static void nuke_stacks(void) { dTHR; - Safefree(cxstack); + while (curstackinfo->si_next) + curstackinfo = curstackinfo->si_next; + while (curstackinfo) { + PERL_SI *p = curstackinfo->si_prev; + SvREFCNT_dec(curstackinfo->si_stack); + Safefree(curstackinfo->si_cxstack); + Safefree(curstackinfo); + curstackinfo = p; + } Safefree(tmps_stack); DEBUG( { Safefree(debname); @@ -150,11 +150,14 @@ #define ARGTARG op->op_targ #define MAXARG op->op_private -#define SWITCHSTACK(f,t) AvFILLp(f) = sp - stack_base; \ - stack_base = AvARRAY(t); \ - stack_max = stack_base + AvMAX(t); \ - sp = stack_sp = stack_base + AvFILLp(t); \ - curstack = t; +#define SWITCHSTACK(f,t) \ + STMT_START { \ + AvFILLp(f) = sp - stack_base; \ + stack_base = AvARRAY(t); \ + stack_max = stack_base + AvMAX(t); \ + sp = stack_sp = stack_base + AvFILLp(t); \ + curstack = t; \ + } STMT_END #define EXTEND_MORTAL(n) \ STMT_START { \ @@ -705,7 +705,6 @@ PP(pp_sort) max = --up - myorigmark; if (sortcop) { if (max > 1) { - AV *oldstack; PERL_CONTEXT *cx; SV** newsp; bool oldcatch = CATCH_GET; @@ -713,14 +712,8 @@ PP(pp_sort) SAVETMPS; SAVEOP(); - oldstack = curstack; - if (!sortstack) { - sortstack = newAV(); - AvREAL_off(sortstack); - av_extend(sortstack, 32); - } CATCH_SET(TRUE); - SWITCHSTACK(curstack, sortstack); + PUSHSTACK(SI_SORT); if (sortstash != stash) { firstgv = gv_fetchpv("a", TRUE, SVt_PV); secondgv = gv_fetchpv("b", TRUE, SVt_PV); @@ -744,7 +737,7 @@ PP(pp_sort) qsortsv(myorigmark+1, max, sortcv); POPBLOCK(cx,curpm); - SWITCHSTACK(sortstack, oldstack); + POPSTACK(); CATCH_SET(oldcatch); } LEAVE; @@ -1036,7 +1029,7 @@ dounwind(I32 cxix) OP * die_where(char *message) { - dTHR; + dSP; if (in_eval) { I32 cxix; register PERL_CONTEXT *cx; @@ -1066,7 +1059,9 @@ die_where(char *message) else sv_setpv(ERRSV, message); - cxix = dopoptoeval(cxstack_ix); + while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) + POPSTACK(); + if (cxix >= 0) { I32 optype; @@ -1436,7 +1431,7 @@ PP(pp_return) PMOP *newpm; I32 optype = 0; - if (curstack == sortstack) { + if (curstackinfo->si_type == SI_SORT) { if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) { if (cxstack_ix > sortcxix) dounwind(sortcxix); @@ -1991,7 +1986,7 @@ PP(pp_goto) do_undump = FALSE; } - if (curstack == signalstack) { + if (top_env->je_prev) { restartop = retop; JMPENV_JUMP(3); } @@ -521,16 +521,17 @@ PP(pp_binmode) PP(pp_tie) { djSP; + dMARK; SV *varsv; HV* stash; GV *gv; SV *sv; - SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */ - I32 markoff = mark - stack_base - 1; + I32 markoff = MARK - stack_base; char *methname; int how = 'P'; + U32 items; - varsv = mark[0]; + varsv = *++MARK; switch(SvTYPE(varsv)) { case SVt_PVHV: methname = "TIEHASH"; @@ -547,26 +548,39 @@ PP(pp_tie) how = 'q'; break; } - - if (sv_isobject(mark[1])) { + items = SP - MARK++; + if (sv_isobject(*MARK)) { ENTER; + PUSHSTACK(SI_MAGIC); + PUSHMARK(SP); + EXTEND(SP,items); + while (items--) + PUSHs(*MARK++); + PUTBACK; perl_call_method(methname, G_SCALAR); } else { /* Not clear why we don't call perl_call_method here too. * perhaps to get different error message ? */ - stash = gv_stashsv(mark[1], FALSE); + stash = gv_stashsv(*MARK, FALSE); if (!stash || !(gv = gv_fetchmethod(stash, methname))) { DIE("Can't locate object method \"%s\" via package \"%s\"", - methname, SvPV(mark[1],na)); + methname, SvPV(*MARK,na)); } ENTER; + PUSHSTACK(SI_MAGIC); + PUSHMARK(SP); + EXTEND(SP,items); + while (items--) + PUSHs(*MARK++); + PUTBACK; perl_call_sv((SV*)GvCV(gv), G_SCALAR); } SPAGAIN; sv = TOPs; + POPSTACK(); if (sv_isobject(sv)) { sv_unmagic(varsv, how); sv_magic(varsv, sv, how, Nullch, 0); @@ -353,6 +353,7 @@ OP* newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop, #ifdef USE_THREADS struct perl_thread * new_struct_thread _((struct perl_thread *t)); #endif +PERL_SI * new_stackinfo _((I32 stitems, I32 cxitems)); PerlIO* nextargv _((GV* gv)); char* ninstr _((char* big, char* bigend, char* little, char* lend)); OP* oopsCV _((OP* o)); @@ -42,6 +42,26 @@ stack_grow(SV **sp, SV **p, int n) #define GROW(old) ((old) + 1) #endif +PERL_SI * +new_stackinfo(I32 stitems, I32 cxitems) +{ + PERL_SI *si; + PERL_CONTEXT *cxt; + New(56, si, 1, PERL_SI); + si->si_stack = newAV(); + AvREAL_off(si->si_stack); + av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0); + AvALLOC(si->si_stack)[0] = &sv_undef; + AvFILLp(si->si_stack) = 0; + si->si_prev = 0; + si->si_next = 0; + si->si_cxmax = cxitems - 1; + si->si_cxix = -1; + si->si_type = SI_UNDEF; + New(56, si->si_cxstack, cxitems, PERL_CONTEXT); + return si; +} + I32 cxinc(void) { @@ -1964,7 +1964,7 @@ sv_setsv(SV *dstr, register SV *sstr) SvFAKE_on(dstr); /* can coerce to non-glob */ } /* ahem, death to those who redefine active sort subs */ - else if (curstack == sortstack + else if (curstackinfo->si_type == SI_SORT && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr))) croak("Can't redefine active sort subroutine %s", GvNAME(dstr)); @@ -2055,7 +2055,7 @@ sv_setsv(SV *dstr, register SV *sstr) { /* ahem, death to those who redefine * active sort subs */ - if (curstack == sortstack && + if (curstackinfo->si_type == SI_SORT && sortcop == CvSTART(cv)) croak( "Can't redefine active sort subroutine %s", @@ -2740,6 +2740,7 @@ sv_clear(register SV *sv) destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); if (destructor) { ENTER; + PUSHSTACK(SI_DESTROY); SvRV(&ref) = SvREFCNT_inc(sv); EXTEND(SP, 2); PUSHMARK(SP); @@ -2748,6 +2749,7 @@ sv_clear(register SV *sv) perl_call_sv((SV*)GvCV(destructor), G_DISCARD|G_EVAL|G_KEEPERR); SvREFCNT(sv)--; + POPSTACK(); LEAVE; } } while (SvOBJECT(sv) && SvSTASH(sv) != stash); diff --git a/t/op/runlevel.t b/t/op/runlevel.t index 6693a829a8..b5e5dbb08c 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -1,17 +1,9 @@ #!./perl ## -## all of these tests are from Michael Schroeder +## Many of these tests are originally from Michael Schroeder ## <Michael.Schroeder@informatik.uni-erlangen.de> -## -## The more esoteric failure modes require Michael's -## stack-of-stacks patch (so we don't test them here, -## and they are commented out before the __END__). -## -## The remaining tests pass with a simpler fix -## intended for 5.004 -## -## Gurusamy Sarathy <gsar@umich.edu> 97-02-24 +## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu> ## chdir 't' if -d 't'; @@ -59,138 +51,6 @@ for (@prgs){ print "ok ", ++$i, "\n"; } -=head2 stay out of here (the real tests are after __END__) - -## -## these tests don't pass yet (need the full stack-of-stacks patch) -## GSAR 97-02-24 -## - -######## -# sort within sort -sub sortfn { - (split(/./, 'x'x10000))[0]; - my (@y) = ( 4, 6, 5); - @y = sort { $a <=> $b } @y; - print "sortfn ".join(', ', @y)."\n"; - return $_[0] <=> $_[1]; -} -@x = ( 3, 2, 1 ); -@x = sort { &sortfn($a, $b) } @x; -print "---- ".join(', ', @x)."\n"; -EXPECT -sortfn 4, 5, 6 ----- 1, 2, 3 -######## -# trapping eval within sort (doesn't work currently because -# die does a SWITCHSTACK()) -@a = (3, 2, 1); -@a = sort { eval('die("no way")') , $a <=> $b} @a; -print join(", ", @a)."\n"; -EXPECT -1, 2, 3 -######## -# this actually works fine, but results in a poor error message -@a = (1, 2, 3); -foo: -{ - @a = sort { last foo; } @a; -} -EXPECT -cannot reach destination block at - line 2. -######## -package TEST; - -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - next; - return "ZZZ"; -} -sub STORE { -} - -package main; - -tie $bar, TEST; -{ - print "- $bar\n"; -} -print "OK\n"; -EXPECT -cannot reach destination block at - line 8. -######## -package TEST; - -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - goto bbb; - return "ZZZ"; -} - -package main; - -tie $bar, TEST; -print "- $bar\n"; -exit; -bbb: -print "bbb\n"; -EXPECT -bbb -######## -# trapping eval within sort (doesn't work currently because -# die does a SWITCHSTACK()) -sub foo { - $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); -} -@a = (3, 2, 0, 1); -@a = sort foo @a; -print join(', ', @a)."\n"; -EXPECT -0, 1, 2, 3 -######## -package TEST; -sub TIESCALAR { - my $foo; - next; - return bless \$foo; -} -package main; -{ -tie $bar, TEST; -} -EXPECT -cannot reach destination block at - line 4. -######## -# large stack extension causes realloc, and segfault -package TEST; -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - return "fetch"; -} -sub STORE { -(split(/./, 'x'x10000))[0]; -} -package main; -tie $bar, TEST; -$bar = "x"; - -=cut - -## -## -## The real tests begin here -## -## - __END__ @a = (1, 2, 3); { @@ -315,3 +175,121 @@ bar: print "bar reached\n"; EXPECT Can't "goto" outside a block at - line 2. +######## +sub sortfn { + (split(/./, 'x'x10000))[0]; + my (@y) = ( 4, 6, 5); + @y = sort { $a <=> $b } @y; + print "sortfn ".join(', ', @y)."\n"; + return $_[0] <=> $_[1]; +} +@x = ( 3, 2, 1 ); +@x = sort { &sortfn($a, $b) } @x; +print "---- ".join(', ', @x)."\n"; +EXPECT +sortfn 4, 5, 6 +---- 1, 2, 3 +######## +@a = (3, 2, 1); +@a = sort { eval('die("no way")') , $a <=> $b} @a; +print join(", ", @a)."\n"; +EXPECT +1, 2, 3 +######## +@a = (1, 2, 3); +foo: +{ + @a = sort { last foo; } @a; +} +EXPECT +Label not found for "last foo" at - line 2. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + next; + return "ZZZ"; +} +sub STORE { +} + +package main; + +tie $bar, TEST; +{ + print "- $bar\n"; +} +print "OK\n"; +EXPECT +Can't "next" outside a block at - line 8. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + goto bbb; + return "ZZZ"; +} + +package main; + +tie $bar, TEST; +print "- $bar\n"; +exit; +bbb: +print "bbb\n"; +EXPECT +Can't find label bbb at - line 8. +######## +sub foo { + $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +EXPECT +0, 1, 2, 3 +######## +package TEST; +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + return "fetch"; +} +sub STORE { +(split(/./, 'x'x10000))[0]; +} +package main; +tie $bar, TEST; +$bar = "x"; +######## +package TEST; +sub TIESCALAR { + my $foo; + next; + return bless \$foo; +} +package main; +{ +tie $bar, TEST; +} +EXPECT +Can't "next" outside a block at - line 4. +######## +@a = (1, 2, 3); +foo: +{ + @a = sort { exit(0) } @a; +} +END { print "foobar\n" } +EXPECT +foobar @@ -68,11 +68,8 @@ PERLVAR(Tdelaymagic, int) /* ($<,$>) = ... */ PERLVAR(Tdirty, bool) /* In the middle of tearing things down? */ PERLVAR(Tlocalizing, int) /* are we processing a local() list? */ -PERLVAR(Tcxstack, PERL_CONTEXT *) -PERLVARI(Tcxstack_ix, I32, -1) -PERLVARI(Tcxstack_max, I32, 128) - PERLVAR(Tcurstack, AV *) /* THE STACK */ +PERLVAR(Tcurstackinfo, PERL_SI *) /* current stack + context */ PERLVAR(Tmainstack, AV *) /* the stack when nothing funny is happening */ PERLVAR(Ttop_env, JMPENV *) /* ptr. to current sigjmp() environment */ PERLVAR(Tstart_env, JMPENV) /* empty startup sigjmp() environment */ @@ -1273,13 +1273,6 @@ die(pat, va_alist) "%p: die: curstack = %p, mainstack = %p\n", thr, curstack, mainstack)); #endif /* USE_THREADS */ - /* 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 */ - if (curstack != mainstack) { - dSP; - SWITCHSTACK(curstack, mainstack); - } #ifdef I_STDARG va_start(args, pat); |