/* run.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2004, 2005, 2006, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
*/
+/* This file contains the main Perl opcode execution loop. It just
+ * calls the pp_foo() function associated with each op, and expects that
+ * function to return a pointer to the next op to be executed, or null if
+ * it's the end of the sub or program or whatever.
+ *
+ * There is a similar loop in dump.c, Perl_runops_debug(), which does
+ * the same, but also checks for various debug flags each time round the
+ * loop.
+ *
+ * Why this function requires a file all of its own is anybody's guess.
+ * DAPM.
+ */
+
#include "EXTERN.h"
#define PERL_IN_RUN_C
#include "perl.h"
/*
- * "Away now, Shadowfax! Run, greatheart, run as you have never run before!
- * Now we are come to the lands where you were foaled, and every stone you
- * know. Run now! Hope is in speed!" --Gandalf
+ * 'Away now, Shadowfax! Run, greatheart, run as you have never run before!
+ * Now we are come to the lands where you were foaled, and every stone you
+ * know. Run now! Hope is in speed!' --Gandalf
+ *
+ * [p.600 of _The Lord of the Rings_, III/xi: "The PalantÃr"]
*/
int
Perl_runops_standard(pTHX)
{
- while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) {
- PERL_ASYNC_CHECK();
+ OP *op = PL_op;
+ PERL_DTRACE_PROBE_OP(op);
+ while ((PL_op = op = op->op_ppaddr(aTHX))) {
+ PERL_DTRACE_PROBE_OP(op);
}
+ PERL_ASYNC_CHECK();
TAINT_NOT;
return 0;
}
+
+#ifdef PERL_RC_STACK
+
+/* this is a wrapper for all runops-style functions. It temporarily
+ * reifies the stack if necessary, then calls the real runops function
+ */
int
-Perl_runops_debug(pTHX)
+Perl_runops_wrap(pTHX)
{
-#ifdef DEBUGGING
- if (!PL_op) {
- if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
- return 0;
+ /* runops loops assume a ref-counted stack. If we have been called via a
+ * wrapper (pp_wrap or xs_wrap) with the top half of the stack not
+ * reference-counted, or with a non-real stack, temporarily convert it
+ * to reference-counted. This is because the si_stack_nonrc_base
+ * mechanism only allows a single split in the stack, not multiple
+ * stripes.
+ * At the end, we revert the stack (or part thereof) to non-refcounted
+ * to keep whoever our caller is happy.
+ *
+ * If what we call croaks, catch it, revert, then rethrow.
+ */
+
+ I32 cut; /* the cut point between refcnted and non-refcnted */
+ bool was_real = cBOOL(AvREAL(PL_curstack));
+ I32 old_base = PL_curstackinfo->si_stack_nonrc_base;
+
+ if (was_real && !old_base) {
+ PL_runops(aTHX); /* call the real loop */
+ return 0;
}
- do {
- PERL_ASYNC_CHECK();
- if (PL_debug) {
- if (PL_watchaddr != 0 && *PL_watchaddr != PL_watchok)
- PerlIO_printf(Perl_debug_log,
- "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
- PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
- PTR2UV(*PL_watchaddr));
- DEBUG_s(debstack());
- DEBUG_t(debop(PL_op));
- DEBUG_P(debprof(PL_op));
- }
- } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
+ if (was_real) {
+ cut = old_base;
+ assert(PL_stack_base + cut <= PL_stack_sp + 1);
+ PL_curstackinfo->si_stack_nonrc_base = 0;
+ }
+ else {
+ assert(!old_base);
+ assert(!AvREIFY(PL_curstack));
+ AvREAL_on(PL_curstack);
+ /* skip the PL_sv_undef guard at PL_stack_base[0] but still
+ * signal adjusting may be needed on return by setting to a
+ * non-zero value - even if stack is empty */
+ cut = 1;
+ }
- TAINT_NOT;
- return 0;
-#else
- return runops_standard();
-#endif /* DEBUGGING */
-}
+ if (cut) {
+ SV **svp = PL_stack_base + cut;
+ while (svp <= PL_stack_sp) {
+ SvREFCNT_inc_simple_void(*svp);
+ svp++;
+ }
+ }
-I32
-Perl_debop(pTHX_ OP *o)
-{
-#ifdef DEBUGGING
- AV *padlist, *comppad;
- CV *cv;
- SV *sv;
- STRLEN n_a;
- Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]);
- switch (o->op_type) {
- case OP_CONST:
- PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
- break;
- case OP_GVSV:
- case OP_GV:
- if (cGVOPo_gv) {
- sv = NEWSV(0,0);
- gv_fullname3(sv, cGVOPo_gv, Nullch);
- PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a));
- SvREFCNT_dec(sv);
- }
- else
- PerlIO_printf(Perl_debug_log, "(NULL)");
- break;
- case OP_PADSV:
- case OP_PADAV:
- case OP_PADHV:
- /* print the lexical's name */
- cv = deb_curcv(cxstack_ix);
- if (cv) {
- padlist = CvPADLIST(cv);
- comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
- sv = *av_fetch(comppad, o->op_targ, FALSE);
- } else
- sv = Nullsv;
- if (sv)
- PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv));
- else
- PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
+ AV * old_curstack = PL_curstack;
+
+ /* run the real loop while catching exceptions */
+ dJMPENV;
+ int ret;
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0: /* normal return from JMPENV_PUSH */
+ cur_env.je_mustcatch = cur_env.je_prev->je_mustcatch;
+ PL_runops(aTHX); /* call the real loop */
+
+ revert:
+ /* revert stack back its non-ref-counted state */
+ assert(AvREAL(PL_curstack));
+
+ if (cut) {
+ /* undo the stack reification that took place at the beginning of
+ * this function */
+ if (UNLIKELY(!was_real))
+ AvREAL_off(PL_curstack);
+
+ SSize_t n = PL_stack_sp - (PL_stack_base + cut) + 1;
+ if (n > 0) {
+ /* we need to decrement the refcount of every SV from cut
+ * upwards; but this may prematurely free them, so
+ * mortalise them instead */
+ EXTEND_MORTAL(n);
+ for (SSize_t i = 0; i < n; i ++) {
+ SV* sv = PL_stack_base[cut + i];
+ if (sv)
+ PL_tmps_stack[++PL_tmps_ix] = sv;
+ }
+ }
+
+ I32 sp1 = PL_stack_sp - PL_stack_base + 1;
+ PL_curstackinfo->si_stack_nonrc_base =
+ old_base > sp1 ? sp1 : old_base;
+ }
+ break;
+
+ case 3: /* exception trapped by eval - stack only partially unwound */
+
+ /* if the exception has already unwound to before the current
+ * stack, no need to fix it up */
+ if (old_curstack == PL_curstack)
+ goto revert;
break;
+
default:
- break;
+ break;
}
- PerlIO_printf(Perl_debug_log, "\n");
-#endif /* DEBUGGING */
- return 0;
-}
-STATIC CV*
-S_deb_curcv(pTHX_ I32 ix)
-{
-#ifdef DEBUGGING
- PERL_CONTEXT *cx = &cxstack[ix];
- if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
- return cx->blk_sub.cv;
- else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
- return PL_compcv;
- else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
- return PL_main_cv;
- else if (ix <= 0)
- return Nullcv;
- else
- return deb_curcv(ix - 1);
-#else
- return Nullcv;
-#endif /* DEBUGGING */
-}
+ JMPENV_POP;
-void
-Perl_watch(pTHX_ char **addr)
-{
-#ifdef DEBUGGING
- PL_watchaddr = addr;
- PL_watchok = *addr;
- PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
- PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
-#endif /* DEBUGGING */
-}
+ if (ret) {
+ JMPENV_JUMP(ret); /* re-throw the exception */
+ NOT_REACHED; /* NOTREACHED */
+ }
-STATIC void
-S_debprof(pTHX_ OP *o)
-{
-#ifdef DEBUGGING
- if (!PL_profiledata)
- Newz(000, PL_profiledata, MAXO, U32);
- ++PL_profiledata[o->op_type];
-#endif /* DEBUGGING */
+ return 0;
}
-void
-Perl_debprofdump(pTHX)
-{
-#ifdef DEBUGGING
- unsigned i;
- if (!PL_profiledata)
- return;
- for (i = 0; i < MAXO; i++) {
- if (PL_profiledata[i])
- PerlIO_printf(Perl_debug_log,
- "%5lu %s\n", (unsigned long)PL_profiledata[i],
- PL_op_name[i]);
- }
-#endif /* DEBUGGING */
-}
+#endif
+
+/*
+ * ex: set ts=8 sts=4 sw=4 et:
+ */
https://perl5.git.perl.org / perl5.git / blobdiff