This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[Merge] CV-based slab allocator for ops
authorFather Chrysostomos <sprout@cpan.org>
Fri, 29 Jun 2012 07:22:25 +0000 (00:22 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Fri, 29 Jun 2012 07:24:24 +0000 (00:24 -0700)
This branch uses per-CV slabs for ops, so that ops can all be freed
after compilation errors, fixing memory leaks and a crash.

See commit 8be227ab5e for how it works.

23 files changed:
cv.h
dist/Safe/t/safeops.t
dump.c
embed.fnc
embed.h
lib/diagnostics.pm
lib/diagnostics.t
makedef.pl
op.c
op.h
opnames.h
pad.c
perl.c
perl.h
pod/perldiag.pod
pod/perlhacktips.pod
pod/perlrun.pod
pp_ctl.c
proto.h
regen/opcode.pl
scope.h
sv.c
t/run/fresh_perl.t

diff --git a/cv.h b/cv.h
index 072ff1e..f7b1b66 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -105,6 +105,9 @@ See L<perlguts/Autoloading with XSUBs>.
 #define CVf_NODEBUG    0x0200  /* no DB::sub indirection for this CV
                                   (esp. useful for special XSUBs) */
 #define CVf_CVGV_RC    0x0400  /* CvGV is reference counted */
+#ifdef PERL_CORE
+# define CVf_SLABBED   0x0800  /* Holds refcount on op slab  */
+#endif
 #define CVf_DYNFILE    0x1000  /* The filename isn't static  */
 #define CVf_AUTOLOAD   0x2000  /* SvPVX contains AUTOLOADed sub name  */
 #define CVf_HASEVAL    0x4000  /* contains string eval  */
@@ -167,6 +170,12 @@ See L<perlguts/Autoloading with XSUBs>.
 #define CvCVGV_RC_on(cv)       (CvFLAGS(cv) |= CVf_CVGV_RC)
 #define CvCVGV_RC_off(cv)      (CvFLAGS(cv) &= ~CVf_CVGV_RC)
 
+#ifdef PERL_CORE
+# define CvSLABBED(cv)         (CvFLAGS(cv) & CVf_SLABBED)
+# define CvSLABBED_on(cv)      (CvFLAGS(cv) |= CVf_SLABBED)
+# define CvSLABBED_off(cv)     (CvFLAGS(cv) &= ~CVf_SLABBED)
+#endif
+
 #define CvDYNFILE(cv)          (CvFLAGS(cv) & CVf_DYNFILE)
 #define CvDYNFILE_on(cv)       (CvFLAGS(cv) |= CVf_DYNFILE)
 #define CvDYNFILE_off(cv)      (CvFLAGS(cv) &= ~CVf_DYNFILE)
@@ -182,6 +191,10 @@ See L<perlguts/Autoloading with XSUBs>.
 /* Flags for newXS_flags  */
 #define XS_DYNAMIC_FILENAME    0x01    /* The filename isn't static  */
 
+#ifdef PL_OP_SLAB_ALLOC
+# define cv_forget_slab(cv)    NOOP
+#endif
+
 /*
 =head1 CV reference counts and CvOUTSIDE
 
index 8edb223..85dc945 100644 (file)
@@ -40,7 +40,7 @@ while (<$fh>) {
 }
 close $fh;
 
-plan(tests => scalar @op + 2);
+plan(tests => scalar @op + 3);
 
 sub testop {
     my ($op, $opname, $code) = @_;
@@ -81,6 +81,16 @@ foreach (@op) {
        ),
        qr/Unbalanced/,
        'No Unbalanced warnings when disallowing ops';
+    unlike
+       runperl(
+           switches => [ '-MSafe', '-w' ],
+           prog     => 'Safe->new->reval('
+                       . 'q(BEGIN{$^H{foo}=bar};use strict), 0'
+                       .')',
+           stderr   => 1,
+       ),
+       qr/Unbalanced/,
+       'No Unbalanced warnings when disallowing ops with %^H set';
 }
 
 # things that begin with SKIP are skipped, for various reasons (notably
diff --git a/dump.c b/dump.c
index d9eeb25..b5240fb 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1367,6 +1367,7 @@ const struct flag_to_name cv_flags_names[] = {
     {CVf_DYNFILE, "DYNFILE,"},
     {CVf_AUTOLOAD, "AUTOLOAD,"},
     {CVf_HASEVAL, "HASEVAL"},
+    {CVf_SLABBED, "SLABBED,"},
     {CVf_ISXSUB, "ISXSUB,"}
 };
 
index 568c980..b79341b 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -281,6 +281,9 @@ ApdR        |SV*    |cv_const_sv    |NULLOK const CV *const cv
 : Used in pad.c
 pR     |SV*    |op_const_sv    |NULLOK const OP* o|NULLOK CV* cv
 Apd    |void   |cv_undef       |NN CV* cv
+#ifndef PL_OP_SLAB_ALLOC
+p      |void   |cv_forget_slab |NN CV *cv
+#endif
 Ap     |void   |cx_dump        |NN PERL_CONTEXT* cx
 Ap     |SV*    |filter_add     |NULLOK filter_t funcp|NULLOK SV* datasv
 Ap     |void   |filter_del     |NN filter_t funcp
@@ -964,6 +967,11 @@ p  |PerlIO*|nextargv       |NN GV* gv
 AnpP   |char*  |ninstr         |NN const char* big|NN const char* bigend \
                                |NN const char* little|NN const char* lend
 Ap     |void   |op_free        |NULLOK OP* arg
+#if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE)
+p      |void   |opslab_free    |NN OPSLAB *slab
+p      |void   |opslab_free_nopad|NN OPSLAB *slab
+p      |void   |opslab_force_free|NN OPSLAB *slab
+#endif
 : Used in perly.y
 #ifdef PERL_MAD
 p      |OP*    |package        |NN OP* o
@@ -1773,10 +1781,9 @@ s        |OP*    |ref_array_or_hash|NULLOK OP* cond
 s      |void   |process_special_blocks |NN const char *const fullname\
                                        |NN GV *const gv|NN CV *const cv
 #endif
-#if defined(PL_OP_SLAB_ALLOC)
-Apa    |void*  |Slab_Alloc     |size_t sz
-Ap     |void   |Slab_Free      |NN void *op
-#  if defined(PERL_DEBUG_READONLY_OPS)
+Xpa    |void*  |Slab_Alloc     |size_t sz
+Xp     |void   |Slab_Free      |NN void *op
+#if defined(PERL_DEBUG_READONLY_OPS)
 : Used in perl.c
 poxM   |void   |pending_Slabs_to_ro
 : Used in OpREFCNT_inc() in sv.c
@@ -1786,7 +1793,6 @@ poxM      |PADOFFSET      |op_refcnt_dec  |NN OP *o
 #    if defined(PERL_IN_OP_C)
 s      |void   |Slab_to_rw     |NN void *op
 #    endif
-#  endif
 #endif
 
 #if defined(PERL_IN_PERL_C)
diff --git a/embed.h b/embed.h
index efc19d8..00b54fa 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define newFORM(a,b,c)         Perl_newFORM(aTHX_ a,b,c)
 #define newMYSUB(a,b,c,d,e)    Perl_newMYSUB(aTHX_ a,b,c,d,e)
 #endif
-#if defined(PL_OP_SLAB_ALLOC)
-#define Slab_Alloc(a)          Perl_Slab_Alloc(aTHX_ a)
-#define Slab_Free(a)           Perl_Slab_Free(aTHX_ a)
-#endif
 #if defined(UNLINK_ALL_VERSIONS)
 #define unlnk(a)               Perl_unlnk(aTHX_ a)
 #endif
 #  endif
 #endif
 #ifdef PERL_CORE
+#define Slab_Alloc(a)          Perl_Slab_Alloc(aTHX_ a)
+#define Slab_Free(a)           Perl_Slab_Free(aTHX_ a)
 #define allocmy(a,b,c)         Perl_allocmy(aTHX_ a,b,c)
 #define amagic_is_enabled(a)   Perl_amagic_is_enabled(aTHX_ a)
 #define apply(a,b,c)           Perl_apply(aTHX_ a,b,c)
 #define utf16_textfilter(a,b,c)        S_utf16_textfilter(aTHX_ a,b,c)
 #    endif
 #  endif
+#  if !defined(PL_OP_SLAB_ALLOC)
+#define cv_forget_slab(a)      Perl_cv_forget_slab(aTHX_ a)
+#  endif
+#  if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE)
+#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)
+#  endif
 #  if !defined(WIN32)
 #define do_exec3(a,b,c)                Perl_do_exec3(aTHX_ a,b,c)
 #  endif
 #  endif
 #  if defined(PERL_DEBUG_READONLY_OPS)
 #    if defined(PERL_IN_OP_C)
-#      if defined(PL_OP_SLAB_ALLOC)
 #define Slab_to_rw(a)          S_Slab_to_rw(aTHX_ a)
-#      endif
 #    endif
 #  endif
 #  if defined(PERL_IN_AV_C)
index 21cdf54..1efbd67 100644 (file)
@@ -186,7 +186,7 @@ use 5.009001;
 use Carp;
 $Carp::Internal{__PACKAGE__.""}++;
 
-our $VERSION = '1.29';
+our $VERSION = '1.30';
 our $DEBUG;
 our $VERBOSE;
 our $PRETTY;
@@ -412,7 +412,7 @@ my %msg;
        # Since we strip "\.\n" when we search a warning, strip it here as well
        $header =~ s/\.?$//;
 
-        my @toks = split( /(%l?[dxX]|%u|%c|%(?:\.\d+)?[fs])/, $header );
+        my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header );
        if (@toks > 1) {
             my $conlen = 0;
             for my $i (0..$#toks){
@@ -425,8 +425,8 @@ my %msg;
                         $toks[$i] = $i == $#toks ? '.*' : '.*?';
                     } elsif( $toks[$i] =~ '%.(\d+)s' ){
                         $toks[$i] = ".{$1}";
-                    } elsif( $toks[$i] =~ '^%l*([xX])$' ){
-                        $toks[$i] = $1 eq 'x' ? '[\da-f]+' : '[\dA-F]+';
+                    } elsif( $toks[$i] =~ '^%l*([pxX])$' ){
+                        $toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+';
                     }
                 } elsif( length( $toks[$i] ) ){
                     $toks[$i] = quotemeta $toks[$i];
index 48f265f..035df76 100644 (file)
@@ -4,7 +4,7 @@ BEGIN {
     chdir '..' if -d '../pod' && -d '../t';
     @INC = 'lib';
     require './t/test.pl';
-    plan(18);
+    plan(19);
 }
 
 BEGIN {
@@ -70,6 +70,12 @@ $warning = '';
 warn "Unicode surrogate U+C0FFEE is illegal in UTF-8";
 like $warning, qr/You had a UTF-16 surrogate/, '%X';
 
+# Test for %p
+seek STDERR, 0,0;
+$warning = '';
+warn "Slab leaked from cv fadedc0ffee";
+like $warning, qr/bookkeeping of op trees/, '%p';
+
 # Strip S<>
 seek STDERR, 0,0;
 $warning = '';
index 95b4d66..6a870f8 100644 (file)
@@ -111,10 +111,6 @@ close(CFG);
 
 # perl.h logic duplication begins
 
-if ($define{PERL_IMPLICIT_SYS}) {
-    $define{PL_OP_SLAB_ALLOC} = 1;
-}
-
 if ($define{USE_ITHREADS}) {
     if (!$define{MULTIPLICITY}) {
         $define{MULTIPLICITY} = 1;
@@ -413,8 +409,6 @@ unless ($define{'PL_OP_SLAB_ALLOC'}) {
                      PL_OpPtr
                      PL_OpSlab
                      PL_OpSpace
-                    Perl_Slab_Alloc
-                    Perl_Slab_Free
                         );
 }
 
diff --git a/op.c b/op.c
index a93a458..5de86a1 100644 (file)
--- a/op.c
+++ b/op.c
@@ -298,6 +298,221 @@ Perl_Slab_Free(pTHX_ void *op)
        }
     }
 }
+#else /* !defined(PL_OP_SLAB_ALLOC) */
+
+/* See the explanatory comments above struct opslab in op.h. */
+
+# ifndef PERL_SLAB_SIZE
+#  define PERL_SLAB_SIZE 64
+# endif
+
+/* rounds up to nearest pointer */
+# define SIZE_TO_PSIZE(x)      (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
+# define DIFF(o,p)             ((size_t)((I32 **)(p) - (I32**)(o)))
+
+static OPSLAB *
+S_new_slab(pTHX_ size_t sz)
+{
+    OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
+    slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
+    return slab;
+}
+
+/* requires double parens and aTHX_ */
+#define DEBUG_S_warn(args)                                            \
+    DEBUG_S(                                                           \
+       PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
+    )
+
+void *
+Perl_Slab_Alloc(pTHX_ size_t sz)
+{
+    dVAR;
+    OPSLAB *slab;
+    OPSLAB *slab2;
+    OPSLOT *slot;
+    OP *o;
+    size_t opsz, space;
+
+    if (!PL_compcv || CvROOT(PL_compcv)
+     || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
+       return PerlMemShared_calloc(1, sz);
+
+    if (!CvSTART(PL_compcv)) { /* sneak it in here */
+       CvSTART(PL_compcv) =
+           (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
+       CvSLABBED_on(PL_compcv);
+       slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
+    }
+    else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
+
+    opsz = SIZE_TO_PSIZE(sz);
+    sz = opsz + OPSLOT_HEADER_P;
+
+    if (slab->opslab_freed) {
+       OP **too = &slab->opslab_freed;
+       o = *too;
+       DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
+       while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
+           DEBUG_S_warn((aTHX_ "Alas! too small"));
+           o = *(too = &o->op_next);
+           if (o) DEBUG_S_warn((aTHX_ "found another free op at %p", o));
+       }
+       if (o) {
+           *too = o->op_next;
+           Zero(o, opsz, I32 *);
+           o->op_slabbed = 1;
+           return (void *)o;
+       }
+    }
+
+# define INIT_OPSLOT \
+           slot->opslot_slab = slab;                   \
+           slot->opslot_next = slab2->opslab_first;    \
+           slab2->opslab_first = slot;                 \
+           o = &slot->opslot_op;                       \
+           o->op_slabbed = 1
+
+    /* The partially-filled slab is next in the chain. */
+    slab2 = slab->opslab_next ? slab->opslab_next : slab;
+    if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
+       /* Remaining space is too small. */
+
+       OPSLAB *newslab;
+
+       /* If we can fit a BASEOP, add it to the free chain, so as not
+          to waste it. */
+       if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
+           slot = &slab2->opslab_slots;
+           INIT_OPSLOT;
+           o->op_type = OP_FREED;
+           o->op_next = slab->opslab_freed;
+           slab->opslab_freed = o;
+       }
+
+       /* Create a new slab.  Make this one twice as big. */
+       slot = slab2->opslab_first;
+       while (slot->opslot_next) slot = slot->opslot_next;
+       newslab = S_new_slab(aTHX_ DIFF(slab2, slot)*2);
+       newslab->opslab_next = slab->opslab_next;
+       slab->opslab_next = slab2 = newslab;
+    }
+    assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
+
+    /* Create a new op slot */
+    slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
+    assert(slot >= &slab2->opslab_slots);
+    if (DIFF(&slab2->opslab_slots, slot)
+        < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
+       slot = &slab2->opslab_slots;
+    INIT_OPSLOT;
+    DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
+    return (void *)o;
+}
+
+# undef INIT_OPSLOT
+
+/* This cannot possibly be right, but it was copied from the old slab
+   allocator, to which it was originally added, without explanation, in
+   commit 083fcd5. */
+# ifdef NETWARE
+#    define PerlMemShared PerlMem
+# endif
+
+void
+Perl_Slab_Free(pTHX_ void *op)
+{
+    dVAR;
+    OP * const o = (OP *)op;
+    OPSLAB *slab;
+
+    PERL_ARGS_ASSERT_SLAB_FREE;
+
+    if (!o->op_slabbed) {
+       PerlMemShared_free(op);
+       return;
+    }
+
+    slab = OpSLAB(o);
+    /* If this op is already freed, our refcount will get screwy. */
+    assert(o->op_type != OP_FREED);
+    o->op_type = OP_FREED;
+    o->op_next = slab->opslab_freed;
+    slab->opslab_freed = o;
+    DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
+    OpslabREFCNT_dec_padok(slab);
+}
+
+void
+Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
+{
+    dVAR;
+    const bool havepad = !!PL_comppad;
+    PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
+    if (havepad) {
+       ENTER;
+       PAD_SAVE_SETNULLPAD();
+    }
+    opslab_free(slab);
+    if (havepad) LEAVE;
+}
+
+void
+Perl_opslab_free(pTHX_ OPSLAB *slab)
+{
+    dVAR;
+    OPSLAB *slab2;
+    PERL_ARGS_ASSERT_OPSLAB_FREE;
+    DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
+    assert(slab->opslab_refcnt == 1);
+    for (; slab; slab = slab2) {
+       slab2 = slab->opslab_next;
+# ifdef DEBUGGING
+       slab->opslab_refcnt = ~(size_t)0;
+# endif
+       PerlMemShared_free(slab);
+    }
+}
+
+void
+Perl_opslab_force_free(pTHX_ OPSLAB *slab)
+{
+    OPSLAB *slab2;
+    OPSLOT *slot;
+# ifdef DEBUGGING
+    size_t savestack_count = 0;
+# endif
+    PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
+    slab2 = slab;
+    do {
+       for (slot = slab2->opslab_first;
+            slot->opslot_next;
+            slot = slot->opslot_next) {
+           if (slot->opslot_op.op_type != OP_FREED
+            && !(slot->opslot_op.op_savefree
+# ifdef DEBUGGING
+                 && ++savestack_count
+# endif
+                )
+           ) {
+               assert(slot->opslot_op.op_slabbed);
+               slab->opslab_refcnt++; /* op_free may free slab */
+               op_free(&slot->opslot_op);
+               if (!--slab->opslab_refcnt) goto free;
+           }
+       }
+    } while ((slab2 = slab2->opslab_next));
+    /* > 1 because the CV still holds a reference count. */
+    if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
+# ifdef DEBUGGING
+       assert(savestack_count == slab->opslab_refcnt-1);
+# endif
+       return;
+    }
+   free:
+    opslab_free(slab);
+}
+
 #endif
 /*
  * In the following definition, the ", (OP*)0" is just to make the compiler
@@ -530,7 +745,14 @@ Perl_op_free(pTHX_ OP *o)
     dVAR;
     OPCODE type;
 
-    if (!o)
+#ifndef PL_OP_SLAB_ALLOC
+    /* Though ops may be freed twice, freeing the op after its slab is a
+       big no-no. */
+    assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0); 
+#endif
+    /* During the forced freeing of ops after compilation failure, kidops
+       may be freed before their parents. */
+    if (!o || o->op_type == OP_FREED)
        return;
     if (o->op_latefreed) {
        if (o->op_latefree)
@@ -2850,6 +3072,7 @@ Perl_newPROG(pTHX_ OP *o)
        PL_main_root->op_next = 0;
        CALL_PEEP(PL_main_start);
        finalize_optree(PL_main_root);
+       cv_forget_slab(PL_compcv);
        PL_compcv = 0;
 
        /* Register with debugger */
@@ -4369,6 +4592,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
                 * confident that nothing used that CV's pad while the
                 * regex was parsed */
                assert(AvFILLp(PL_comppad) == 0); /* just @_ */
+               /* But we know that one op is using this CV's slab. */
+               cv_forget_slab(PL_compcv);
                LEAVE_SCOPE(floor);
                pm->op_pmflags &= ~PMf_HAS_CV;
            }
@@ -4412,6 +4637,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
                 * pad_fixup_inner_anons() can find it */
                (void)pad_add_anon(cv, o->op_type);
                SvREFCNT_inc_simple_void(cv);
+
+               cv_forget_slab(cv);
            }
            else {
                pm->op_code_list = expr;
@@ -6217,7 +6444,10 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
     /* for my  $x () sets OPpLVAL_INTRO;
      * for our $x () sets OPpOUR_INTRO */
     loop->op_private = (U8)iterpflags;
-#ifdef PL_OP_SLAB_ALLOC
+#ifndef PL_OP_SLAB_ALLOC
+    if (DIFF(loop, OpSLOT(loop)->opslot_next)
+        < SIZE_TO_PSIZE(sizeof(LOOP)))
+#endif
     {
        LOOP *tmp;
        NewOp(1234,tmp,1,LOOP);
@@ -6225,9 +6455,6 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
        S_op_destroy(aTHX_ (OP*)loop);
        loop = tmp;
     }
-#else
-    loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
-#endif
     loop->op_targ = padoff;
     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
     if (madsv)
@@ -6878,6 +7105,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
        SvREFCNT_inc_simple_void_NN(const_sv);
        if (cv) {
            assert(!CvROOT(cv) && !CvCONST(cv));
+           cv_forget_slab(cv);
            sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
            CvXSUBANY(cv).any_ptr = const_sv;
            CvXSUB(cv) = const_sv_xsub;
@@ -6908,6 +7136,8 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
            AV *const temp_av = CvPADLIST(cv);
            CV *const temp_cv = CvOUTSIDE(cv);
+           const cv_flags_t slabbed = CvSLABBED(cv);
+           OP * const cvstart = CvSTART(cv);
 
            assert(!CvWEAKOUTSIDE(cv));
            assert(!CvCVGV_RC(cv));
@@ -6920,6 +7150,10 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            CvPADLIST(cv) = CvPADLIST(PL_compcv);
            CvOUTSIDE(PL_compcv) = temp_cv;
            CvPADLIST(PL_compcv) = temp_av;
+           CvSTART(cv) = CvSTART(PL_compcv);
+           CvSTART(PL_compcv) = cvstart;
+           if (slabbed) CvSLABBED_on(PL_compcv);
+           else CvSLABBED_off(PL_compcv);
 
            if (CvFILE(cv) && CvDYNFILE(cv)) {
                Safefree(CvFILE(cv));
@@ -6995,6 +7229,12 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
                   : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
     CvROOT(cv)->op_private |= OPpREFCOUNTED;
     OpREFCNT_set(CvROOT(cv), 1);
+#ifndef PL_OP_SLAB_ALLOC
+    /* The cv no longer needs to hold a refcount on the slab, as CvROOT
+       itself has a refcount. */
+    CvSLABBED_off(cv);
+    OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+#endif
     CvSTART(cv) = LINKLIST(CvROOT(cv));
     CvROOT(cv)->op_next = 0;
     CALL_PEEP(CvSTART(cv));
@@ -7376,6 +7616,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
     CvROOT(cv)->op_next = 0;
     CALL_PEEP(CvSTART(cv));
     finalize_optree(CvROOT(cv));
+    cv_forget_slab(cv);
 #ifdef PERL_MAD
     op_getmad(o,pegop,'n');
     op_getmad_weak(block, pegop, 'b');
diff --git a/op.h b/op.h
index 7be9bf5..6bc6c82 100644 (file)
--- a/op.h
+++ b/op.h
  *                     the op may be safely op_free()d multiple times
  *     op_latefreed    an op_latefree op has been op_free()d
  *     op_attached     this op (sub)tree has been attached to a CV
+ *     op_slabbed      allocated via opslab
+ *     op_savefree     on savestack via SAVEFREEOP
  *
- *     op_spare        three spare bits!
+ *     op_spare        a spare bit!
  *     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
@@ -62,7 +64,9 @@ typedef PERL_BITFIELD16 Optype;
     PERL_BITFIELD16 op_latefree:1;     \
     PERL_BITFIELD16 op_latefreed:1;    \
     PERL_BITFIELD16 op_attached:1;     \
-    PERL_BITFIELD16 op_spare:3;                \
+    PERL_BITFIELD16 op_slabbed:1;      \
+    PERL_BITFIELD16 op_savefree:1;     \
+    PERL_BITFIELD16 op_spare:1;                \
     U8         op_flags;               \
     U8         op_private;
 #endif
@@ -708,19 +712,66 @@ least an C<UNOP>.
 #include "reentr.h"
 #endif
 
-#if defined(PL_OP_SLAB_ALLOC)
 #define NewOp(m,var,c,type)    \
        (var = (type *) Perl_Slab_Alloc(aTHX_ c*sizeof(type)))
 #define NewOpSz(m,var,size)    \
        (var = (OP *) Perl_Slab_Alloc(aTHX_ size))
 #define FreeOp(p) Perl_Slab_Free(aTHX_ p)
-#else
-#define NewOp(m, var, c, type) \
-       (var = (MEM_WRAP_CHECK_(c,type) \
-        (type*)PerlMemShared_calloc(c, sizeof(type))))
-#define NewOpSz(m, var, size)  \
-       (var = (OP*)PerlMemShared_calloc(1, size))
-#define FreeOp(p) PerlMemShared_free(p)
+
+/*
+ * The per-CV op slabs consist of a header (the opslab struct) and a bunch
+ * of space for allocating op slots, each of which consists of two pointers
+ * followed by an op.  The first pointer points to the next op slot.  The
+ * second points to the slab.  At the end of the slab is a null pointer,
+ * so that slot->opslot_next - slot can be used to determine the size
+ * of the op.
+ *
+ * Each CV can have multiple slabs; opslab_next points to the next slab, to
+ * form a chain.  All bookkeeping is done on the first slab, which is where
+ * all the op slots point.
+ *
+ * Freed ops are marked as freed and attached to the freed chain
+ * via op_next pointers.
+ *
+ * When there is more than one slab, the second slab in the slab chain is
+ * assumed to be the one with free space available.  It is used when allo-
+ * cating an op if there are no freed ops available or big enough.
+ */
+
+#if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE)
+struct opslot {
+    /* keep opslot_next first */
+    OPSLOT *   opslot_next;            /* next slot */
+    OPSLAB *   opslot_slab;            /* owner */
+    OP         opslot_op;              /* the op itself */
+};
+
+struct opslab {
+    OPSLOT *   opslab_first;           /* first op in this slab */
+    OPSLAB *   opslab_next;            /* next slab */
+    OP *       opslab_freed;           /* chain of freed ops */
+    size_t     opslab_refcnt;          /* number of ops */
+    OPSLOT     opslab_slots;           /* slots begin here */
+};
+
+# define OPSLOT_HEADER         STRUCT_OFFSET(OPSLOT, opslot_op)
+# define OPSLOT_HEADER_P       (OPSLOT_HEADER/sizeof(I32 *))
+# ifdef DEBUGGING
+#  define OpSLOT(o)            (assert(o->op_slabbed), \
+                                (OPSLOT *)(((char *)o)-OPSLOT_HEADER))
+# else
+#  define OpSLOT(o)            ((OPSLOT *)(((char *)o)-OPSLOT_HEADER))
+# endif
+# define OpSLAB(o)             OpSLOT(o)->opslot_slab
+# define OpslabREFCNT_dec(slab)      \
+       (((slab)->opslab_refcnt == 1) \
+        ? opslab_free_nopad(slab)     \
+        : (void)--(slab)->opslab_refcnt)
+  /* Variant that does not null out the pads */
+# define OpslabREFCNT_dec_padok(slab) \
+       (((slab)->opslab_refcnt == 1)  \
+        ? opslab_free(slab)            \
+        : (void)--(slab)->opslab_refcnt)
 #endif
 
 struct block_hooks {
index 8b6a39a..fd86d2a 100644 (file)
--- a/opnames.h
+++ b/opnames.h
@@ -392,6 +392,7 @@ typedef enum opcode {
 } opcode;
 
 #define MAXO 374
+#define OP_FREED MAXO
 
 /* the OP_IS_* macros are optimized to a simple range check because
     all the member OPs are contiguous in regen/opcodes table.
diff --git a/pad.c b/pad.c
index 5473b64..9f6ccb8 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -333,6 +333,7 @@ Perl_cv_undef(pTHX_ CV *cv)
 {
     dVAR;
     const PADLIST *padlist = CvPADLIST(cv);
+    bool const slabbed = !!CvSLABBED(cv);
 
     PERL_ARGS_ASSERT_CV_UNDEF;
 
@@ -346,6 +347,7 @@ Perl_cv_undef(pTHX_ CV *cv)
     }
     CvFILE(cv) = NULL;
 
+    CvSLABBED_off(cv);
     if (!CvISXSUB(cv) && CvROOT(cv)) {
        if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
            Perl_croak(aTHX_ "Can't undef active subroutine");
@@ -353,11 +355,29 @@ Perl_cv_undef(pTHX_ CV *cv)
 
        PAD_SAVE_SETNULLPAD();
 
+#ifndef PL_OP_SLAB_ALLOC
+       if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
+#endif
        op_free(CvROOT(cv));
        CvROOT(cv) = NULL;
        CvSTART(cv) = NULL;
        LEAVE;
     }
+#ifndef PL_OP_SLAB_ALLOC
+    else if (slabbed && CvSTART(cv)) {
+       ENTER;
+       PAD_SAVE_SETNULLPAD();
+
+       /* discard any leaked ops */
+       opslab_force_free((OPSLAB *)CvSTART(cv));
+       CvSTART(cv) = NULL;
+
+       LEAVE;
+    }
+# ifdef DEBUGGING
+    else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+# endif
+#endif
     SvPOK_off(MUTABLE_SV(cv));         /* forget prototype */
     CvGV_set(cv, NULL);
 
@@ -470,6 +490,26 @@ Perl_cv_undef(pTHX_ CV *cv)
     CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
 }
 
+#ifndef PL_OP_SLAB_ALLOC
+void
+Perl_cv_forget_slab(pTHX_ CV *cv)
+{
+    const bool slabbed = !!CvSLABBED(cv);
+
+    PERL_ARGS_ASSERT_CV_FORGET_SLAB;
+
+    if (!slabbed) return;
+
+    CvSLABBED_off(cv);
+
+    if      (CvROOT(cv))  OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
+    else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
+# ifdef DEBUGGING
+    else if (slabbed)     Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+# endif
+}
+#endif
+
 /*
 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
 
@@ -1905,7 +1945,8 @@ Perl_cv_clone(pTHX_ CV *proto)
     SAVESPTR(PL_compcv);
 
     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
-    CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
+    CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
+                                   |CVf_SLABBED);
     CvCLONED_on(cv);
 
     CvFILE(cv)         = CvDYNFILE(proto) ? savepv(CvFILE(proto))
diff --git a/perl.c b/perl.c
index 9496f5c..4348954 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -3000,6 +3000,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
       "  H  Hash dump -- usurps values()\n"
       "  X  Scratchpad allocation\n"
       "  D  Cleaning up\n"
+      "  S  Op slab allocation\n"
       "  T  Tokenising\n"
       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
diff --git a/perl.h b/perl.h
index 2fec311..cf35ded 100644 (file)
--- a/perl.h
+++ b/perl.h
  * repeated in makedef.pl, so be certain to update
  * both places when editing. */
 
-#ifdef PERL_IMPLICIT_SYS
-/* PERL_IMPLICIT_SYS implies PerlMemShared != PerlMem
-   so use slab allocator to avoid lots of MUTEX overhead
- */
-#  ifndef PL_OP_SLAB_ALLOC
-#    define PL_OP_SLAB_ALLOC
-#  endif
-#endif
-
 #ifdef USE_ITHREADS
 #  if !defined(MULTIPLICITY)
 #    define MULTIPLICITY
@@ -2418,6 +2409,11 @@ typedef struct padop PADOP;
 typedef struct pvop PVOP;
 typedef struct loop LOOP;
 
+#if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE)
+typedef struct opslab OPSLAB;
+typedef struct opslot OPSLOT;
+#endif
+
 typedef struct block_hooks BHK;
 typedef struct custom_op XOP;
 
@@ -3663,7 +3659,7 @@ Gid_t getegid (void);
 #define DEBUG_H_FLAG           0x00002000 /*   8192 */
 #define DEBUG_X_FLAG           0x00004000 /*  16384 */
 #define DEBUG_D_FLAG           0x00008000 /*  32768 */
-/* 0x00010000 is unused, used to be S */
+#define DEBUG_S_FLAG           0x00010000 /*  65536 */
 #define DEBUG_T_FLAG           0x00020000 /* 131072 */
 #define DEBUG_R_FLAG           0x00040000 /* 262144 */
 #define DEBUG_J_FLAG           0x00080000 /* 524288 */
@@ -3673,7 +3669,7 @@ Gid_t getegid (void);
 #define DEBUG_q_FLAG           0x00800000 /*8388608 */
 #define DEBUG_M_FLAG           0x01000000 /*16777216*/
 #define DEBUG_B_FLAG           0x02000000 /*33554432*/
-#define DEBUG_MASK             0x03FEEFFF /* mask of all the standard flags */
+#define DEBUG_MASK             0x03FFEFFF /* mask of all the standard flags */
 
 #define DEBUG_DB_RECURSE_FLAG  0x40000000
 #define DEBUG_TOP_FLAG         0x80000000 /* XXX what's this for ??? Signal
@@ -3695,6 +3691,7 @@ Gid_t getegid (void);
 #  define DEBUG_H_TEST_ (PL_debug & DEBUG_H_FLAG)
 #  define DEBUG_X_TEST_ (PL_debug & DEBUG_X_FLAG)
 #  define DEBUG_D_TEST_ (PL_debug & DEBUG_D_FLAG)
+#  define DEBUG_S_TEST_ (PL_debug & DEBUG_S_FLAG)
 #  define DEBUG_T_TEST_ (PL_debug & DEBUG_T_FLAG)
 #  define DEBUG_R_TEST_ (PL_debug & DEBUG_R_FLAG)
 #  define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG)
@@ -3726,6 +3723,7 @@ Gid_t getegid (void);
 #  define DEBUG_H_TEST DEBUG_H_TEST_
 #  define DEBUG_X_TEST DEBUG_X_TEST_
 #  define DEBUG_D_TEST DEBUG_D_TEST_
+#  define DEBUG_S_TEST DEBUG_S_TEST_
 #  define DEBUG_T_TEST DEBUG_T_TEST_
 #  define DEBUG_R_TEST DEBUG_R_TEST_
 #  define DEBUG_J_TEST DEBUG_J_TEST_
@@ -3777,6 +3775,7 @@ Gid_t getegid (void);
 #  define DEBUG_Uv(a) DEBUG__(DEBUG_Uv_TEST, a)
 #  define DEBUG_Pv(a) DEBUG__(DEBUG_Pv_TEST, a)
 
+#  define DEBUG_S(a) DEBUG__(DEBUG_S_TEST, a)
 #  define DEBUG_T(a) DEBUG__(DEBUG_T_TEST, a)
 #  define DEBUG_R(a) DEBUG__(DEBUG_R_TEST, a)
 #  define DEBUG_v(a) DEBUG__(DEBUG_v_TEST, a)
@@ -3804,6 +3803,7 @@ Gid_t getegid (void);
 #  define DEBUG_H_TEST (0)
 #  define DEBUG_X_TEST (0)
 #  define DEBUG_D_TEST (0)
+#  define DEBUG_S_TEST (0)
 #  define DEBUG_T_TEST (0)
 #  define DEBUG_R_TEST (0)
 #  define DEBUG_J_TEST (0)
@@ -3835,6 +3835,7 @@ Gid_t getegid (void);
 #  define DEBUG_H(a)
 #  define DEBUG_X(a)
 #  define DEBUG_D(a)
+#  define DEBUG_S(a)
 #  define DEBUG_T(a)
 #  define DEBUG_R(a)
 #  define DEBUG_v(a)
index f686174..8aed54e 100644 (file)
@@ -4473,6 +4473,12 @@ superfluous.
 (W signal) The signal handler named in %SIG doesn't, in fact, exist.
 Perhaps you put it into the wrong package?
 
+=item Slab leaked from cv %p
+
+(S) If you see this message, then something is seriously wrong with the
+internal bookkeeping of op trees.  An op tree needed to be freed after
+a compilation error, but could not be found, so it was leaked instead.
+
 =item Smart matching a non-overloaded object breaks encapsulation
 
 (F) You should not use the C<~~> operator on an object that does not
index 6c33550..dba0d40 100644 (file)
@@ -1460,10 +1460,11 @@ L<perlclib>.
 
 Under ithreads the optree is read only. If you want to enforce this, to
 check for write accesses from buggy code, compile with
-C<-DPL_OP_SLAB_ALLOC> to enable the OP slab allocator and
+C<-DPL_OP_SLAB_ALLOC> to enable the old OP slab allocator and
 C<-DPERL_DEBUG_READONLY_OPS> to enable code that allocates op memory
-via C<mmap>, and sets it read-only at run time. Any write access to an
-op results in a C<SIGBUS> and abort.
+via C<mmap>, and sets it read-only at run time. (PERL_DEBUG_READONLY_OPS
+has not been rewritten for the new slab allocator, so op trees may leak.)
+Any write access to an op results in a C<SIGBUS> and abort.
 
 This code is intended for development only, and may not be portable
 even to all Unix variants. Also, it is an 80% solution, in that it
index 9421a3b..9ed678c 100644 (file)
@@ -400,6 +400,7 @@ B<-D14> is equivalent to B<-Dtls>):
      8192  H  Hash dump -- usurps values()
     16384  X  Scratchpad allocation
     32768  D  Cleaning up
+    65536  S  Op slab allocation
    131072  T  Tokenizing
    262144  R  Include reference counts of dumped variables (eg when
               using -Ds)
index 30a4d36..f3c7692 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3444,6 +3444,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
        PL_op = saveop;
        if (yystatus != 3) {
            if (PL_eval_root) {
+               cv_forget_slab(evalcv);
                op_free(PL_eval_root);
                PL_eval_root = NULL;
            }
@@ -3486,6 +3487,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
 
     CopLINE_set(&PL_compiling, 0);
     SAVEFREEOP(PL_eval_root);
+    cv_forget_slab(evalcv);
 
     DEBUG_x(dump_eval());
 
diff --git a/proto.h b/proto.h
index 6e8ae37..bfa685c 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -23,6 +23,15 @@ PERL_CALLCONV int    Perl_Gv_AMupdate(pTHX_ HV* stash, bool destructing)
        assert(stash)
 
 PERL_CALLCONV const char *     Perl_PerlIO_context_layers(pTHX_ const char *mode);
+PERL_CALLCONV void*    Perl_Slab_Alloc(pTHX_ size_t sz)
+                       __attribute__malloc__
+                       __attribute__warn_unused_result__;
+
+PERL_CALLCONV void     Perl_Slab_Free(pTHX_ void *op)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SLAB_FREE     \
+       assert(op)
+
 PERL_CALLCONV bool     Perl__is_utf8__perl_idstart(pTHX_ const U8 *p)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);
@@ -4977,6 +4986,30 @@ STATIC I32       S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 
 #  endif
 #endif
+#if !defined(PL_OP_SLAB_ALLOC)
+PERL_CALLCONV void     Perl_cv_forget_slab(pTHX_ CV *cv)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_FORGET_SLAB        \
+       assert(cv)
+
+#endif
+#if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE)
+PERL_CALLCONV void     Perl_opslab_force_free(pTHX_ OPSLAB *slab)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE     \
+       assert(slab)
+
+PERL_CALLCONV void     Perl_opslab_free(pTHX_ OPSLAB *slab)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OPSLAB_FREE   \
+       assert(slab)
+
+PERL_CALLCONV void     Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD     \
+       assert(slab)
+
+#endif
 #if !defined(SETUID_SCRIPTS_ARE_SECURE_NOW)
 #  if defined(PERL_IN_PERL_C)
 STATIC void    S_validate_suid(pTHX_ PerlIO *rsfp)
@@ -5248,16 +5281,6 @@ STATIC void      S_strip_return(pTHX_ SV *sv)
 #  endif
 #endif
 #if defined(PERL_DEBUG_READONLY_OPS)
-#  if defined(PERL_IN_OP_C)
-#    if defined(PL_OP_SLAB_ALLOC)
-STATIC void    S_Slab_to_rw(pTHX_ void *op)
-                       __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_SLAB_TO_RW    \
-       assert(op)
-
-#    endif
-#  endif
-#  if defined(PL_OP_SLAB_ALLOC)
 PERL_CALLCONV PADOFFSET        Perl_op_refcnt_dec(pTHX_ OP *o)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_OP_REFCNT_DEC \
@@ -5265,6 +5288,12 @@ PERL_CALLCONV PADOFFSET  Perl_op_refcnt_dec(pTHX_ OP *o)
 
 PERL_CALLCONV OP *     Perl_op_refcnt_inc(pTHX_ OP *o);
 PERL_CALLCONV void     Perl_pending_Slabs_to_ro(pTHX);
+#  if defined(PERL_IN_OP_C)
+STATIC void    S_Slab_to_rw(pTHX_ void *op)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SLAB_TO_RW    \
+       assert(op)
+
 #  endif
 #endif
 #if defined(PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION)
@@ -7469,17 +7498,6 @@ PERL_CALLCONV SV*        Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr)
 #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C)
 STATIC void    S_pidgone(pTHX_ Pid_t pid, int status);
 #endif
-#if defined(PL_OP_SLAB_ALLOC)
-PERL_CALLCONV void*    Perl_Slab_Alloc(pTHX_ size_t sz)
-                       __attribute__malloc__
-                       __attribute__warn_unused_result__;
-
-PERL_CALLCONV void     Perl_Slab_Free(pTHX_ void *op)
-                       __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_SLAB_FREE     \
-       assert(op)
-
-#endif
 #if defined(UNLINK_ALL_VERSIONS)
 PERL_CALLCONV I32      Perl_unlnk(pTHX_ const char* f)
                        __attribute__nonnull__(pTHX_1);
index d8186cd..1c15edc 100755 (executable)
@@ -46,6 +46,8 @@ while (<OPS>) {
     warn qq[Description "$desc" duplicates $seen{$desc}\n]
      if $seen{$desc} and $key ne "transr";
     die qq[Opcode "$key" duplicates $seen{$key}\n] if $seen{$key};
+    die qq[Opcode "freed" is reserved for the slab allocator\n]
+       if $key eq 'freed';
     $seen{$desc} = qq[description of opcode "$key"];
     $seen{$key} = qq[opcode "$key"];
 
@@ -189,6 +191,7 @@ for (@ops) {
 print $on "\t", tab(3,"OP_max"), "\n";
 print $on "} opcode;\n";
 print $on "\n#define MAXO ", scalar @ops, "\n";
+print $on "#define OP_FREED MAXO\n";
 
 # Emit op names and descriptions.
 
diff --git a/scope.h b/scope.h
index 74ebed9..f8df5b4 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -269,7 +269,21 @@ scope has the given name. Name must be a literal string.
 
 #define save_freesv(op)                save_pushptr((void *)(op), SAVEt_FREESV)
 #define save_mortalizesv(op)   save_pushptr((void *)(op), SAVEt_MORTALIZESV)
-#define save_freeop(op)                save_pushptr((void *)(op), SAVEt_FREEOP)
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
+# define save_freeop(op)                    \
+    ({                                       \
+      OP * const _o = (OP *)(op);             \
+      _o->op_savefree = 1;                     \
+      save_pushptr((void *)(_o), SAVEt_FREEOP); \
+    })
+#else
+# define save_freeop(op)                       \
+    (                                           \
+      PL_Xpv = (XPV *)(op),                      \
+      ((OP *)PL_Xpv)->op_savefree = 1,            \
+      save_pushptr((void *)(PL_Xpv), SAVEt_FREEOP) \
+    )
+#endif
 #define save_freepv(pv)                save_pushptr((void *)(pv), SAVEt_FREEPV)
 #define save_op()              save_pushptr((void *)(PL_op), SAVEt_OP)
 
diff --git a/sv.c b/sv.c
index b96f7c1..7146f38 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -12205,10 +12205,12 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                    OP_REFCNT_LOCK;
                    CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
                    OP_REFCNT_UNLOCK;
+                   CvSLABBED_off(dstr);
                } else if (CvCONST(dstr)) {
                    CvXSUBANY(dstr).any_ptr =
                        sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
                }
+               assert(!CvSLABBED(dstr));
                if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
                /* don't dup if copying back - CvGV isn't refcounted, so the
                 * duped GV may never be freed. A bit of a hack! DAPM */
index 3e56a09..cd5899a 100644 (file)
@@ -822,3 +822,55 @@ eval {
 print "If you get here, you didn't crash\n";
 EXPECT
 If you get here, you didn't crash
+######## [perl #112312] crash on syntax error
+# SKIP: !defined &DynaLoader::boot_DynaLoader # miniperl
+#!/usr/bin/perl
+use strict;
+use warnings;
+sub meow (&);
+my %h;
+my $k;
+meow {
+       my $t : need_this;
+       $t = {
+               size =>  $h{$k}{size};
+               used =>  $h{$k}(used}
+       };
+};
+EXPECT
+syntax error at - line 12, near "used"
+syntax error at - line 12, near "used}"
+Unmatched right curly bracket at - line 14, at end of line
+Execution of - aborted due to compilation errors.
+######## [perl #112312] crash on syntax error - another test
+# SKIP: !defined &DynaLoader::boot_DynaLoader # miniperl
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+sub meow (&);
+
+my %h;
+my $k;
+
+meow {
+        my $t : need_this;
+        $t = {
+                size => $h{$k}{size};
+                used => $h{$k}(used}
+        };
+};
+
+sub testo {
+        my $value = shift;
+        print;
+        print;
+        print;
+        1;
+}
+
+EXPECT
+syntax error at - line 15, near "used"
+syntax error at - line 15, near "used}"
+Unmatched right curly bracket at - line 17, at end of line
+Execution of - aborted due to compilation errors.