CV-based slab allocation for ops
authorFather Chrysostomos <sprout@cpan.org>
Sat, 23 Jun 2012 16:54:31 +0000 (09:54 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Fri, 29 Jun 2012 07:20:56 +0000 (00:20 -0700)
This addresses bugs #111462 and #112312 and part of #107000.

When a longjmp occurs during lexing, parsing or compilation, any ops
in C autos that are not referenced anywhere are leaked.

This commit introduces op slabs that are attached to the currently-
compiling CV.  New ops are allocated on the slab.  When an error
occurs and the CV is freed, any ops remaining are freed.

This is based on Nick Ing-Simmons’ old experimental op slab implemen-
tation, but it had to be rewritten to work this way.

The old slab allocator has a pointer before each op that points to a
reference count stored at the beginning of the slab.  Freed ops are
never reused.  When the last op on a slab is freed, the slab itself is
freed.  When a slab fills up, a new one is created.

To allow iteration through the slab to free everything, I had to have
two pointers; one points to the next item (op slot); the other points
to the slab, for accessing the reference count.  Ops come in different
sizes, so adding sizeof(OP) to a pointer won’t work.

The old slab allocator puts the ops at the end of the slab first, the
idea being that the leaves are allocated first, so the order will be
cache-friendly as a result.  I have preserved that order for a dif-
ferent reason:  We don’t need to store the size of the slab (slabs
vary in size; see below) if we can simply follow pointers to find
the last op.

I tried eliminating reference counts altogether, by having all ops
implicitly attached to PL_compcv when allocated and freed when the CV
is freed.  That also allowed op_free to skip FreeOp altogether, free-
ing ops faster.  But that doesn’t work in those cases where ops need
to survive beyond their CVs; e.g., re-evals.

The CV also has to have a reference count on the slab.  Sometimes the
first op created is immediately freed.  If the reference count of
the slab reaches 0, then it will be freed with the CV still point-
ing to it.

CVs use the new CVf_SLABBED flag to indicate that the CV has a refer-
ence count on the slab.  When this flag is set, the slab is accessible
via CvSTART when CvROOT is not set, or by subtracting two pointers
(2*sizeof(I32 *)) from CvROOT when it is set.  I decided to sneak the
slab into CvSTART during compilation, because enlarging the xpvcv
struct by another pointer would make all CVs larger, even though this
patch only benefits few (programs using string eval).

When the CVf_SLABBED flag is set, the CV takes responsibility for
freeing the slab.  If CvROOT is not set when the CV is freed or
undeffed, it is assumed that a compilation error has occurred, so the
op slab is traversed and all the ops are freed.

Under normal circumstances, the CV forgets about its slab (decrement-
ing the reference count) when the root is attached.  So the slab ref-
erence counting that happens when ops are freed takes care of free-
ing the slab.  In some cases, the CV is told to forget about the slab
(cv_forget_slab) precisely so that the ops can survive after the CV is
done away with.

Forgetting the slab when the root is attached is not strictly neces-
sary, but avoids potential problems with CvROOT being written over.
There is code all over the place, both in core and on CPAN, that does
things with CvROOT, so forgetting the slab makes things more robust
and avoids potential problems.

Since the CV takes ownership of its slab when flagged, that flag is
never copied when a CV is cloned, as one CV could free a slab that
another CV still points to, since forced freeing of ops ignores the
reference count (but asserts that it looks right).

To avoid slab fragmentation, freed ops are marked as freed and
attached to the slab’s freed chain (an idea stolen from DBM::Deep).
Those freed ops are reused when possible.  I did consider not reusing
freed ops, but realised that would result in significantly higher mem-
ory using for programs with large ‘if (DEBUG) {...}’ blocks.

SAVEFREEOP was slightly problematic.  Sometimes it can cause an op to
be freed after its CV.  If the CV has forcibly freed the ops on its
slab and the slab itself, then we will be fiddling with a freed slab.
Making SAVEFREEOP a no-op won’t help, as sometimes an op can be
savefreed when there is no compilation error, so the op would never
be freed.  It holds a reference count on the slab, so the whole
slab would leak.  So SAVEFREEOP now sets a special flag on the op
(->op_savefree).  The forced freeing of ops after a compilation error
won’t free any ops thus marked.

Since many pieces of code create tiny subroutines consisting of only
a few ops, and since a huge slab would be quite a bit of baggage for
those to carry around, the first slab is always very small.  To avoid
allocating too many slabs for a single CV, each subsequent slab is
twice the size of the previous.

Smartmatch expects to be able to allocate an op at run time, run it,
and then throw it away.  For that to work the op is simply mallocked
when PL_compcv has’t been set up.  So all slab-allocated ops are
marked as such (->op_slabbed), to distinguish them from mallocked ops.

All of this is kept under lock and key via #ifdef PERL_CORE, as it
should be completely transparent.  If it isn’t transparent, I would
consider that a bug.

I have left the old slab allocator (PL_OP_SLAB_ALLOC) in place, as
it is used by PERL_DEBUG_READONLY_OPS, which I am not about to
rewrite. :-)

Concerning the change from A to X for slab allocation functions:
Many times in the past, A has been used for functions that were
not intended to be public but were used for public macros.  Since
PL_OP_SLAB_ALLOC is rarely used, it didn’t make sense for Perl_Slab_*
to be API functions, since they were rarely actually available.  To
avoid propagating this mistake further, they are now X.

embed.fnc
embed.h
makedef.pl
op.c
op.h
pad.c
perl.h
pp_ctl.c
proto.h
sv.c

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 95b4d66..ff26b74 100644 (file)
@@ -413,8 +413,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..41219df 100644 (file)
--- a/op.c
+++ b/op.c
@@ -298,6 +298,203 @@ 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;
+}
+
+void *
+Perl_Slab_Alloc(pTHX_ size_t sz)
+{
+    dVAR;
+    OPSLAB *slab;
+    OPSLAB *slab2;
+    OPSLOT *slot;
+    OP *o;
+    size_t 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;
+
+    sz = SIZE_TO_PSIZE(sz) + OPSLOT_HEADER_P;
+
+    if (slab->opslab_freed) {
+       OP **too = &slab->opslab_freed;
+       o = *too;
+       while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
+           o = *(too = &o->op_next);
+       }
+       if (o) {
+           *too = o->op_next;
+           Zero(o, DIFF(o, OpSLOT(o)->opslot_next), 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);
+    INIT_OPSLOT;
+    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)
+{
+    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;
+    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)
+{
+    OPSLAB *slab2;
+    PERL_ARGS_ASSERT_OPSLAB_FREE;
+    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 +727,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 +3054,9 @@ Perl_newPROG(pTHX_ OP *o)
        PL_main_root->op_next = 0;
        CALL_PEEP(PL_main_start);
        finalize_optree(PL_main_root);
+#ifndef PL_OP_SLAB_ALLOC
+       cv_forget_slab(PL_compcv);
+#endif
        PL_compcv = 0;
 
        /* Register with debugger */
@@ -4369,6 +4576,10 @@ 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 @_ */
+#ifndef PL_OP_SLAB_ALLOC
+               /* But we know that one op is using this CV's slab. */
+               cv_forget_slab(PL_compcv);
+#endif
                LEAVE_SCOPE(floor);
                pm->op_pmflags &= ~PMf_HAS_CV;
            }
@@ -4412,6 +4623,10 @@ 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);
+
+#ifndef PL_OP_SLAB_ALLOC
+               cv_forget_slab(cv);
+#endif
            }
            else {
                pm->op_code_list = expr;
@@ -6217,7 +6432,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 +6443,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 +7093,9 @@ 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));
+#ifndef PL_OP_SLAB_ALLOC
+           cv_forget_slab(cv);
+#endif
            sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
            CvXSUBANY(cv).any_ptr = const_sv;
            CvXSUB(cv) = const_sv_xsub;
@@ -6908,6 +7126,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 +7140,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 +7219,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 +7606,9 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
     CvROOT(cv)->op_next = 0;
     CALL_PEEP(CvSTART(cv));
     finalize_optree(CvROOT(cv));
+#ifndef PL_OP_SLAB_ALLOC
+    cv_forget_slab(cv);
+#endif
 #ifdef PERL_MAD
     op_getmad(o,pegop,'n');
     op_getmad_weak(block, pegop, 'b');
diff --git a/op.h b/op.h
index 7e20c70..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        two 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
@@ -63,8 +64,9 @@ typedef PERL_BITFIELD16 Optype;
     PERL_BITFIELD16 op_latefree:1;     \
     PERL_BITFIELD16 op_latefreed:1;    \
     PERL_BITFIELD16 op_attached:1;     \
+    PERL_BITFIELD16 op_slabbed:1;      \
     PERL_BITFIELD16 op_savefree:1;     \
-    PERL_BITFIELD16 op_spare:2;                \
+    PERL_BITFIELD16 op_spare:1;                \
     U8         op_flags;               \
     U8         op_private;
 #endif
@@ -710,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 {
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.h b/perl.h
index 2fec311..5ada97e 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2418,6 +2418,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;
 
index 30a4d36..c55afb1 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3444,6 +3444,9 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
        PL_op = saveop;
        if (yystatus != 3) {
            if (PL_eval_root) {
+#ifndef PL_OP_SLAB_ALLOC
+               cv_forget_slab(evalcv);
+#endif
                op_free(PL_eval_root);
                PL_eval_root = NULL;
            }
@@ -3486,6 +3489,9 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
 
     CopLINE_set(&PL_compiling, 0);
     SAVEFREEOP(PL_eval_root);
+#ifndef PL_OP_SLAB_ALLOC
+    cv_forget_slab(evalcv);
+#endif
 
     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);
@@ -4976,6 +4985,30 @@ STATIC I32       S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
        assert(sv)
 
 #  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)
@@ -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)
@@ -7468,17 +7497,6 @@ PERL_CALLCONV SV*        Perl_sv_setsv_cow(pTHX_ SV* dstr, SV* sstr)
 #endif
 #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)
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 */