#ifdef DUMPADDR
Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
#endif
- if (o->op_flags || o->op_latefree || o->op_latefreed) {
+ if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
SV * const tmpsv = newSVpvs("");
switch (o->op_flags & OPf_WANT) {
case OPf_WANT_VOID:
sv_catpv(tmpsv, ",LATEFREE");
if (o->op_latefreed)
sv_catpv(tmpsv, ",LATEFREED");
+ if (o->op_attached)
+ sv_catpv(tmpsv, ",ATTACHED");
Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
SvREFCNT_dec(tmpsv);
}
* 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.
+ *
+ * See the comments in S_clear_yystack() for more
+ * details on the following three flags:
+
* 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_attached this op (sub)tree has been attached to a CV
+ *
+ * op_spare two 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
unsigned op_static:1; \
unsigned op_latefree:1; \
unsigned op_latefreed:1; \
- unsigned op_spare:3; \
+ unsigned op_attached:1; \
+ unsigned op_spare:2; \
U8 op_flags; \
U8 op_private;
#endif
YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n"));
- /* Freeing ops on the stack, and the op_latefree/op_latefreed flags:
+ /* Freeing ops on the stack, and the op_latefree / op_latefreed /
+ * op_attached 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
+ * reduce (i.e. Perl_croak somewhere in yylex() or in one of the
+ * newFOO() functions), then it's 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
+ * larger tree. In this case, we should clearly free the op (making
+ * sure, for each op we free that 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
+ * 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 .... }
+ * OP *newFOO { ....; if (...) 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
+ * * left them as is
* * attached them to part of a larger tree
+ * * attached them to PL_compcv
+ * * attached them to PL_compcv then freed it (as in BEGIN {die } )
*
* 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
* 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.
+ * and free them. A little thought should convince you that this
+ * two-part approach to the reducing ops should handle the first three
+ * cases above safely.
+ *
+ * In the case of attaching to PL_compcv (currently just newATTRSUB
+ * does this), then we set the op_attached flag on the op that has
+ * been so attached, then avoid doing the final op_free during
+ * cleanup, on the assumption that it will happen (or has already
+ * happened) when PL_compcv is freed.
+ *
+ * Note this is fairly fragile mechanism. A more robust approach
+ * would be to use two of these flag bits as 2-bit reference count
+ * field for each op, indicating whether it is pointed to from:
+ * * a parent op
+ * * the parser stack
+ * * a CV
+ * but this would involve reworking all code (core and external) that
+ * manipulate op trees.
*/
- /* free any reducing ops (1st pass) */
+ /* clear any reducing ops (1st pass) */
for (i=0; i< parser->yylen; i++) {
if (yy_type_tab[yystos[ps[-i].state]] == toketype_opval
&& ps[-i].val.opval) {
- if (ps[-i].comppad != PL_comppad) {
- PAD_RESTORE_LOCAL(ps[-i].comppad);
+ if ( ! (ps[-i].val.opval->op_attached
+ && !ps[-i].val.opval->op_latefreed))
+ {
+ if (ps[-i].comppad != PL_comppad) {
+ PAD_RESTORE_LOCAL(ps[-i].comppad);
+ }
+ op_free(ps[-i].val.opval);
}
- op_free(ps[-i].val.opval);
}
}
}
YYDPRINTF ((Perl_debug_log, "(freeing op)\n"));
ps->val.opval->op_latefree = 0;
- op_free(ps->val.opval);
+ if (!(ps->val.opval->op_attached && !ps->val.opval->op_latefreed))
+ op_free(ps->val.opval);
}
ps--;
}
}
BEGIN { require "./test.pl"; }
-plan( tests => 65 );
+plan( tests => 72 );
eval '%@x=0;';
like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' );
like($@, qr/Can't modify/, 'croak cleanup 3' );
+# these might leak, or have duplicate frees, depending on the bugginess of
+# the parser stack 'fail in reduce' cleanup code. They're here mainly as
+# something to be run under valgrind, with PERL_DESTRUCT_LEVEL=1.
+
+eval q[ BEGIN { } ] for 1..10;
+is($@, "", 'BEGIN 1' );
+
+eval q[ BEGIN { my $x; $x = 1 } ] for 1..10;
+is($@, "", 'BEGIN 2' );
+
+eval q[ BEGIN { \&foo1 } ] for 1..10;
+is($@, "", 'BEGIN 3' );
+
+eval q[ sub foo2 { } ] for 1..10;
+is($@, "", 'BEGIN 4' );
+
+eval q[ sub foo3 { my $x; $x=1 } ] for 1..10;
+is($@, "", 'BEGIN 5' );
+
+eval q[ BEGIN { die } ] for 1..10;
+like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 6' );
+
+eval q[ BEGIN {\&foo4; die } ] for 1..10;
+like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' );
projects / p5sagit/p5-mst-13.2.git / commitdiff