summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--op.c12
-rw-r--r--op.h10
-rw-r--r--perly.c118
3 files changed, 122 insertions, 18 deletions
diff --git a/op.c b/op.c
index ab84ef143d..1a3baa34c5 100644
--- a/op.c
+++ b/op.c
@@ -287,6 +287,11 @@ Perl_op_free(pTHX_ OP *o)
if (!o || o->op_static)
return;
+ if (o->op_latefreed) {
+ if (o->op_latefree)
+ return;
+ goto do_free;
+ }
type = o->op_type;
if (o->op_private & OPpREFCOUNTED) {
@@ -327,6 +332,11 @@ Perl_op_free(pTHX_ OP *o)
cop_free((COP*)o);
op_clear(o);
+ if (o->op_latefree) {
+ o->op_latefreed = 1;
+ return;
+ }
+ do_free:
FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
@@ -2712,6 +2722,8 @@ Perl_newOP(pTHX_ I32 type, I32 flags)
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
o->op_flags = (U8)flags;
+ o->op_latefree = 0;
+ o->op_latefreed = 0;
o->op_next = o;
o->op_private = (U8)(0 | (flags >> 8));
diff --git a/op.h b/op.h
index e3596b5b4d..5c12c77f0d 100644
--- a/op.h
+++ b/op.h
@@ -22,7 +22,11 @@
* op_static Whether or not the op is statically defined.
* This flag is used by the B::C compiler backend
* and indicates that the op should not be freed.
- * op_spare Five spare bits!
+ * op_latefree tell op_free() to clear this op (and free any kids)
+ * but not yet deallocate the struct. This means that
+ * the op may be safely op_free()d multiple times
+ * op_latefreed an op_latefree op has been op_free()d
+ * op_spare three spare bits!
* op_flags Flags common to all operations. See OPf_* below.
* op_private Flags peculiar to a particular operation (BUT,
* by default, set to the number of children until
@@ -54,7 +58,9 @@
unsigned op_type:9; \
unsigned op_opt:1; \
unsigned op_static:1; \
- unsigned op_spare:5; \
+ unsigned op_latefree:1; \
+ unsigned op_latefreed:1; \
+ unsigned op_spare:3; \
U8 op_flags; \
U8 op_private;
#endif
diff --git a/perly.c b/perly.c
index b0c8bab75d..8ac349aad0 100644
--- a/perly.c
+++ b/perly.c
@@ -162,7 +162,7 @@ yy_stack_print (pTHX_ const short *yyss, const short *yyssp, const YYSTYPE *yyvs
PerlIO_printf(Perl_debug_log, " %8.8s",
yyvs[start+i].opval
? PL_op_name[yyvs[start+i].opval->op_type]
- : "(NULL)"
+ : "(Nullop)"
);
break;
#ifndef PERL_IN_MADLY_C
@@ -287,19 +287,77 @@ static void
S_clear_yystack(pTHX_ const void *p)
{
yystack_positions *y = (yystack_positions*) p;
+ int i;
if (!y->yyss)
return;
YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
- y->yyvsp -= y->yylen; /* ignore the tokens that have just been reduced */
- y->yyssp -= y->yylen;
- y->yypsp -= y->yylen;
+
+ /* Freeing ops on the stack, and the op_latefree/op_latefreed flags:
+ *
+ * When we pop tokens off the stack during error recovery, or when
+ * we pop all the tokens off the stack after a die during a shift or
+ * reduce (ie Perl_croak somewhere in yylex(), or in one of the
+ * newFOO() functions, then its possible that some of these tokens are
+ * of type opval, pointing to an OP. All these ops are orphans; each is
+ * its own miniature subtree that has not yet been attached to a
+ * larger tree. In this case, we shoould clearly free the op (making
+ * sure, for each op we free thyat we have PL_comppad pointing to the
+ * right place for freeing any SVs attached to the op in threaded
+ * builds.
+ *
+ * However, there is a particular problem if we die in newFOO called
+ * by a reducing action; e.g.
+ *
+ * foo : bar baz boz
+ * { $$ = newFOO($1,$2,$3) }
+ *
+ * where
+ * OP *newFOO { .... croak .... }
+ *
+ * In this case, when we come to clean bar baz and boz off the stack,
+ * we don't know whether newFOO() has already:
+ * * freed them
+ * * left them as it
+ * * attached them to part of a larger tree
+ *
+ * To get round this problem, we set the flag op_latefree on every op
+ * that gets pushed onto the parser stack. If op_free() sees this
+ * flag, it clears the op and frees any children,, but *doesn't* free
+ * the op itself; instead it sets the op_latefreed flag. This means
+ * that we can safely call op_free() multiple times on each stack op.
+ * So, when clearing the stack, we first, for each op that was being
+ * reduced, call op_free with op_latefree=1. This ensures that all ops
+ * hanging off these op are freed, but the reducing ops themselces are
+ * just undefed. Then we set op_latefreed=0 on *all* ops on the stack
+ * and free them. A little though should convince you that this
+ * two-part approach to the reducing ops should handle all three cases
+ * above safely.
+ */
+
+ /* free any reducing ops (1st pass) */
+
+ for (i=0; i< y->yylen; i++) {
+ if (yy_type_tab[yystos[y->yyssp[-i]]] == toketype_opval
+ && y->yyvsp[-i].opval) {
+ if (y->yypsp[-i] != PL_comppad) {
+ PAD_RESTORE_LOCAL(y->yypsp[-i]);
+ }
+ op_free(y->yyvsp[-i].opval);
+ }
+ }
+
+ /* now free whole the stack, including the just-reduced ops */
+
while (y->yyssp > y->yyss) {
- if (yy_type_tab[yystos[*y->yyssp]] == toketype_opval) {
+ if (yy_type_tab[yystos[*y->yyssp]] == toketype_opval
+ && y->yyvsp->opval)
+ {
if (*y->yypsp != PL_comppad) {
PAD_RESTORE_LOCAL(*y->yypsp);
}
YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
+ y->yyvsp->opval->op_latefree = 0;
op_free(y->yyvsp->opval);
}
y->yyvsp--;
@@ -431,8 +489,6 @@ Perl_yyparse (pTHX)
yynerrs = 0;
yychar = YYEMPTY; /* Cause a token to be read. */
- YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
-
goto yysetstate;
/*------------------------------------------------------------.
@@ -445,8 +501,20 @@ Perl_yyparse (pTHX)
yyssp++;
yysetstate:
+ YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
*yyssp = yystate;
+ if (yy_type_tab[yystos[yystate]] == toketype_opval && yyvsp->opval) {
+ yyvsp->opval->op_latefree = 1;
+ yyvsp->opval->op_latefreed = 0;
+ }
+
+ ss_save->yyss = yyss;
+ ss_save->yyssp = yyssp;
+ ss_save->yyvsp = yyvsp;
+ ss_save->yypsp = yypsp;
+ ss_save->yylen = 0;
+
if (yyss + yystacksize - 1 <= yyssp) {
/* Get the current used size of the three stacks, in elements. */
const YYSIZE_T yysize = yyssp - yyss + 1;
@@ -485,6 +553,12 @@ Perl_yyparse (pTHX)
if (yyss + yystacksize - 1 <= yyssp)
YYABORT;
+
+ ss_save->yyss = yyss;
+ ss_save->yyssp = yyssp;
+ ss_save->yyvsp = yyvsp;
+ ss_save->yypsp = yypsp;
+ ss_save->yylen = 0;
}
goto yybackup;
@@ -567,7 +641,6 @@ Perl_yyparse (pTHX)
yyerrstatus--;
yystate = yyn;
- YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
goto yynewstate;
@@ -641,6 +714,21 @@ Perl_yyparse (pTHX)
}
+ /* any just-reduced ops with the op_latefreed flag cleared need to be
+ * freed; the rest need the flag resetting */
+ {
+ int i;
+ for (i=0; i< yylen; i++) {
+ if (yy_type_tab[yystos[yyssp[-i]]] == toketype_opval
+ && yyvsp[-i].opval)
+ {
+ yyvsp[-i].opval->op_latefree = 0;
+ if (yyvsp[-i].opval->op_latefreed)
+ op_free(yyvsp[-i].opval);
+ }
+ }
+ }
+
yyvsp -= yylen;
yyssp -= yylen;
yypsp -= yylen;
@@ -648,14 +736,11 @@ Perl_yyparse (pTHX)
yynsp -= yylen;
#endif
-
*++yyvsp = yyval;
*++yypsp = PL_comppad;
-
#ifdef DEBUGGING
*++yynsp = (const char *)(yytname [yyr1[yyn]]);
#endif
-
/* Now shift the result of the reduction. Determine what state
that goes to, based on the state we popped back to and the rule
number reduced by. */
@@ -668,8 +753,6 @@ Perl_yyparse (pTHX)
else
yystate = yydefgoto[yyn - YYNTOKENS];
- YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
-
#ifdef DEBUGGING
/* tmp push yystate for stack print; this is normally pushed later in
* yynewstate */
@@ -750,11 +833,14 @@ Perl_yyparse (pTHX)
/* Pop the rest of the stack. */
while (yyss < yyssp) {
YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp);
- if (yy_type_tab[yystos[*yyssp]] == toketype_opval) {
+ if (yy_type_tab[yystos[*yyssp]] == toketype_opval
+ && yyvsp->opval)
+ {
YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
if (*yypsp != PL_comppad) {
PAD_RESTORE_LOCAL(*yypsp);
}
+ yyvsp->opval->op_latefree = 0;
op_free(yyvsp->opval);
}
YYPOPSTACK;
@@ -794,11 +880,12 @@ Perl_yyparse (pTHX)
YYABORT;
YYDSYMPRINTF ("Error: popping", yystos[*yyssp], yyvsp);
- if (yy_type_tab[yystos[*yyssp]] == toketype_opval) {
+ if (yy_type_tab[yystos[*yyssp]] == toketype_opval && yyvsp->opval) {
YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
if (*yypsp != PL_comppad) {
PAD_RESTORE_LOCAL(*yypsp);
}
+ yyvsp->opval->op_latefree = 0;
op_free(yyvsp->opval);
}
yyvsp--;
@@ -823,7 +910,6 @@ Perl_yyparse (pTHX)
#endif
yystate = yyn;
- YYDPRINTF ((Perl_debug_log, "Entering state %d\n", yystate));
goto yynewstate;