From: Dave Mitchell Date: Fri, 29 Dec 2006 00:08:35 +0000 (+0000) Subject: further fix for #29543: fix parser leaks caused by croaking X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7e5d8ed22a9e0983529873e07602c1b147b8b5b8;p=p5sagit%2Fp5-mst-13.2.git further fix for #29543: fix parser leaks caused by croaking p4raw-id: //depot/perl@29636 --- diff --git a/dump.c b/dump.c index eefa477..0ad48d1 100644 --- a/dump.c +++ b/dump.c @@ -739,7 +739,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) #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: @@ -771,6 +771,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) 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); } diff --git a/op.c b/op.c index ecff57f..6422ff1 100644 --- a/op.c +++ b/op.c @@ -2726,6 +2726,7 @@ Perl_newOP(pTHX_ I32 type, I32 flags) o->op_flags = (U8)flags; o->op_latefree = 0; o->op_latefreed = 0; + o->op_attached = 0; o->op_next = o; o->op_private = (U8)(0 | (flags >> 8)); @@ -5323,6 +5324,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (CvLVALUE(cv)) { CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); + block->op_attached = 1; } else { /* This makes sub {}; work as expected. */ @@ -5335,6 +5337,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) #endif block = newblock; } + else + block->op_attached = 1; CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); } CvROOT(cv)->op_private |= OPpREFCOUNTED; diff --git a/op.h b/op.h index d2369df..5283098 100644 --- a/op.h +++ b/op.h @@ -22,11 +22,17 @@ * 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 @@ -60,7 +66,8 @@ 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 diff --git a/perly.c b/perly.c index d5b243b..2357bb0 100644 --- a/perly.c +++ b/perly.c @@ -206,33 +206,36 @@ S_clear_yystack(pTHX_ const void *p) 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 @@ -243,20 +246,39 @@ S_clear_yystack(pTHX_ const void *p) * 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); } } @@ -271,7 +293,8 @@ S_clear_yystack(pTHX_ const void *p) } 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--; } diff --git a/t/comp/parser.t b/t/comp/parser.t index ddbb760..4895d06 100644 --- a/t/comp/parser.t +++ b/t/comp/parser.t @@ -9,7 +9,7 @@ BEGIN { } 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' ); @@ -251,3 +251,27 @@ eval q[ 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' );