This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Stop eval "END OF TERMS" from leaking
authorFather Chrysostomos <sprout@cpan.org>
Wed, 14 Nov 2012 14:10:37 +0000 (06:10 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Wed, 14 Nov 2012 17:53:47 +0000 (09:53 -0800)
I found this memory leak by evaluating lines of the Copying file as
Perl code. :-)

The parser requires yylex to return exactly one token with each call.
Sometimes yylex needs to record a few tokens ahead of time, so its
puts them in its forced token stack.  The next call to yylex then pops
the pending token off that stack.

Ops belong to their subroutines.  If the subroutine is freed before
its root is attached, all the ops created when PL_compcv pointed
to that sub are freed as well.  To avoid crashes, the ops on the
savestack and the forced token stack are specially marked so they are
not freed when the sub is freed.

When it comes to evaluating "END OF TERMS AND CONDITIONS", the END
token causes a subroutine to be created and placed in PL_compcv.  The
OF token is treated by the lexer as a method call on the TERMS pack-
age.  The TERMS token is placed in the forced token stack as an sv in
an op for a WORD token, and a METHOD token for OF is returned.  As
soon as the parser sees the OF, it generates an error, which results
in LEAVE_SCOPE being called, which frees the subroutine for END while
TERMS is still on the forced token stack.  So the subroutine’s op
cleanup skips that op.  Then the parser calls back into the lexer,
which returns the TERMS token from the forced token stack.  Since
there has been an error, the parser discards that token, so the op
is never freed.  The forced token stack cleanup that happens in
parser_free does not catch this, as the token is no longer on
that stack.

Earlier, to solve the problem of yylex returning freed ops to the
parser, resulting in crashes, I set the op_savefree flag on ops on the
forced token stack.  But that resulted in a leak.

So now I am using a different approach: When the sub is freed and
frees all its ops, have it also look in the parser’s forced token
stack, freeing any ops that belong to it, and setting the point-
ers to null.

embed.fnc
embed.h
pad.c
proto.h
t/op/svleak.t
toke.c

index 3eb0084..d4982b8 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1547,6 +1547,10 @@ p        |void   |yyunlex
 p      |int    |yyparse        |int gramtype
 : Only used in scope.c
 p      |void   |parser_free    |NN const yy_parser *parser
+#ifdef PERL_CORE
+p      |void   |parser_free_nexttoke_ops|NN yy_parser *parser \
+                                        |NN OPSLAB *slab
+#endif
 #if defined(PERL_IN_TOKE_C)
 s      |int    |yywarn         |NN const char *const s|U32 flags
 #endif
diff --git a/embed.h b/embed.h
index aaff3f7..b8ad138 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define opslab_force_free(a)   Perl_opslab_force_free(aTHX_ a)
 #define opslab_free(a)         Perl_opslab_free(aTHX_ a)
 #define opslab_free_nopad(a)   Perl_opslab_free_nopad(aTHX_ a)
+#define parser_free_nexttoke_ops(a,b)  Perl_parser_free_nexttoke_ops(aTHX_ a,b)
 #    if defined(PERL_DEBUG_READONLY_OPS)
 #define Slab_to_ro(a)          Perl_Slab_to_ro(aTHX_ a)
 #define Slab_to_rw(a)          Perl_Slab_to_rw(aTHX_ a)
diff --git a/pad.c b/pad.c
index cc34ade..12d23b0 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -370,6 +370,8 @@ Perl_cv_undef(pTHX_ CV *cv)
        PAD_SAVE_SETNULLPAD();
 
        /* discard any leaked ops */
+       if (PL_parser)
+           parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
        opslab_force_free((OPSLAB *)CvSTART(cv));
        CvSTART(cv) = NULL;
 
diff --git a/proto.h b/proto.h
index 14d512b..5bb3352 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5261,6 +5261,12 @@ PERL_CALLCONV void       Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 #define PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD     \
        assert(slab)
 
+PERL_CALLCONV void     Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS      \
+       assert(parser); assert(slab)
+
 #  if defined(PERL_DEBUG_READONLY_OPS)
 PERL_CALLCONV void     Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
                        __attribute__nonnull__(pTHX_1);
index c365709..d38c92d 100644 (file)
@@ -218,10 +218,7 @@ eleak(2, 0, 'no warnings; 2 2;BEGIN{}',
                 'implicit "use Errno" after syntax error');
 }
 eleak(2, 0, "\"\$\0\356\"", 'qq containing $ <null> something');
-{
-    local $::TODO = 'eval "END blah blah" still leaks';
-    eleak(2, 0, 'END OF TERMS AND CONDITIONS', 'END followed by words');
-}
+eleak(2, 0, 'END OF TERMS AND CONDITIONS', 'END followed by words');
 
 
 # [perl #114764] Attributes leak scalars
diff --git a/toke.c b/toke.c
index 6027af3..cac14b9 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -773,12 +773,6 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
 void
 Perl_parser_free(pTHX_  const yy_parser *parser)
 {
-#ifdef PERL_MAD
-   I32 nexttoke = parser->lasttoke;
-#else
-   I32 nexttoke = parser->nexttoke;
-#endif
-
     PERL_ARGS_ASSERT_PARSER_FREE;
 
     PL_curcop = parser->saved_curcop;
@@ -792,22 +786,43 @@ Perl_parser_free(pTHX_  const yy_parser *parser)
     SvREFCNT_dec(parser->rsfp_filters);
     SvREFCNT_dec(parser->lex_stuff);
     SvREFCNT_dec(parser->sublex_info.repl);
+
+    Safefree(parser->lex_brackstack);
+    Safefree(parser->lex_casestack);
+    Safefree(parser->lex_shared);
+    PL_parser = parser->old_parser;
+    Safefree(parser);
+}
+
+void
+Perl_parser_free_nexttoke_ops(pTHX_  yy_parser *parser, OPSLAB *slab)
+{
+#ifdef PERL_MAD
+    I32 nexttoke = parser->lasttoke;
+#else
+    I32 nexttoke = parser->nexttoke;
+#endif
+    PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
     while (nexttoke--) {
 #ifdef PERL_MAD
        if (S_is_opval_token(parser->nexttoke[nexttoke].next_type
-                               & 0xffff))
-           op_free(parser->nexttoke[nexttoke].next_val.opval);
+                               & 0xffff)
+        && parser->nexttoke[nexttoke].next_val.opval
+        && parser->nexttoke[nexttoke].next_val.opval->op_slabbed
+        && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) {
+               op_free(parser->nexttoke[nexttoke].next_val.opval);
+               parser->nexttoke[nexttoke].next_val.opval = NULL;
+       }
 #else
-       if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff))
+       if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
+        && parser->nextval[nexttoke].opval
+        && parser->nextval[nexttoke].opval->op_slabbed
+        && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
            op_free(parser->nextval[nexttoke].opval);
+           parser->nextval[nexttoke].opval = NULL;
+       }
 #endif
     }
-
-    Safefree(parser->lex_brackstack);
-    Safefree(parser->lex_casestack);
-    Safefree(parser->lex_shared);
-    PL_parser = parser->old_parser;
-    Safefree(parser);
 }
 
 
@@ -2023,11 +2038,6 @@ S_force_next(pTHX_ I32 type)
        tokereport(type, &NEXTVAL_NEXTTOKE);
     }
 #endif
-    /* Don’t let opslab_force_free snatch it */
-    if (S_is_opval_token(type & 0xffff) && NEXTVAL_NEXTTOKE.opval) {
-       assert(!NEXTVAL_NEXTTOKE.opval->op_savefree);
-       NEXTVAL_NEXTTOKE.opval->op_savefree = 1;
-    }  
 #ifdef PERL_MAD
     if (PL_curforce < 0)
        start_force(PL_lasttoke);
@@ -4653,8 +4663,6 @@ Perl_yylex(pTHX)
                    PL_lex_allbrackets--;
                next_type &= 0xffff;
            }
-           if (S_is_opval_token(next_type) && pl_yylval.opval)
-               pl_yylval.opval->op_savefree = 0; /* release */
            return REPORT(next_type == 'p' ? pending_ident() : next_type);
        }