perl5 version 5.14.2 coredumps during perl -c #12039
Comments
From andrej.zverev@gmail.comCreated by andrej.zverev@gmail.com5.14 coredumps during perl -c for me with following scripts. Try to run one of the two scripts, one of them should crash perl. # --- script #1 meow { # --- script #2 use strict; sub meow (&); my %h; meow { sub testo { # --- end of script #2 results look like this: Perl Info |
From @jkeenanOn Fri Apr 06 10:59:31 2012, azus wrote:
It appears there are two syntax errors here. If $t is a hash reference, Thank you very much. |
|
The RT System itself - Status changed from 'new' to 'open' |
From andrej.zverev@gmail.com
Yes, there are two syntax errors but this is not a reason for segfault. Since 5.10 and 5.12 eat this |
From [Unknown Contact. See original ticket]
Yes, there are two syntax errors but this is not a reason for segfault. Since 5.10 and 5.12 eat this |
From perl@profvince.comOn 06/04/2012 22:27, James E Keenan via RT wrote:
perl shouldn't crash, regardless of whether the code is valid or not. I can confirm the segfault with a perl built with PERL_POISON defined $ gdb --args perl5.14.2-dbg-psn-thr-64 x.pl Program received signal SIGSEGV, Segmentation fault. Vincent. |
From @cpansproutOn Fri Apr 06 13:43:56 2012, perl@profvince.com wrote:
Can we make this a 5.16 blocker? -- Father Chrysostomos |
From @cpansproutOn Fri Apr 06 13:43:56 2012, perl@profvince.com wrote:
po=11354992)
o=0xab8aa0)
gramtype=258)
For me, with the ‘my $t : need_this;’ line deleted, this command: $ PERL_DESTRUCT_LEVEL=1 ../perl.git-copy/Porting/bisect.pl points to this commit: f120055 is the first bad commit make string-append on win32 100 times faster This is on darwin. I couldn’t reproduce in on dromedary, hence: That took 1710 seconds -- Father Chrysostomos |
From @iabynOn Fri, Apr 06, 2012 at 05:44:56PM -0700, Father Chrysostomos via RT wrote:
valgrind shows that the fault goes back as far as 5.10.0 and has been Given how long this bug has been present, I don't think it needs to be a -- |
From @nwc10On Sat, Apr 07, 2012 at 10:47:44PM +0100, Dave Mitchell wrote:
I bisected with this: $ cat ../112312.sh #!/bin/sh valgrind --error-exitcode=1 ./perl -Ilib <<'EOT' meow { ret=$? and got to this commit: HEAD is now at 9a51af3 Fix a typo in Dynaloader_pm.PL. disable parser stack cleanup on reduce croak (too fragile) p4raw-id: //depot/perl@29866 :100644 100644 a9e569d9c9ccd42ad9241f0d6881f30607ac2c57 c8ee62ffc62dfcd4f5a7079f97775fa70562b6e8 M perly.c IIRC this was the reversion of some work to deal with leaking ops, so I went commit 0539ab6 stop OPs leaking in eval "syntax error" so I built its parent, and for that valgrind shows no errors. So, sadly, I But, I'm suspecting, that the only *real* fix to all of this mess is to Nicholas Clark |
From @iabynOn Sun, Apr 08, 2012 at 11:31:37AM +0100, Nicholas Clark wrote:
Ah yes, *that* quagmire. -- |
From @nwc10On Sun, Apr 08, 2012 at 11:42:06AM +0100, Dave Mitchell wrote:
No problem. I'm waiting for the HP-UX box to build things. I was also wondering if it would be simple enough to add a --valgrind option $ cat ../112312.sh valgrind --error-exitcode=1 ./perl -Ilib <<'EOT' meow { ret=$? So I'll do something else for a bit, to see if inspiration attacks. Nicholas Clark |
From @cpansproutOn Sun Apr 08 03:32:21 2012, nicholas wrote:
The simplest way might be to create something like the mortals’ stack, Code that could croak can do the equivalent of SAVEFREEOP, and then Would that be as fast as a tortoise, or slower? Or maybe a suggestion I had earlier: a variant of SAVEFREEOP that uses I32 token = SAVEFREEOP_token(o); -- Father Chrysostomos |
From @iabynOn Tue, Apr 24, 2012 at 02:01:45PM -0700, Father Chrysostomos via RT wrote:
I think another suggestion that was mooted a while ago would be to -- |
From @cpansproutOn Wed Apr 25 03:38:30 2012, davem wrote:
I sort of understand that in theory, but I don’t understand it well -- Father Chrysostomos |
From @cpansproutOn Wed Apr 25 03:38:30 2012, davem wrote:
What exactly is that code at the top of op.c that is compiled only when -- Father Chrysostomos |
From @iabynOn Thu, May 17, 2012 at 10:02:39AM -0700, Father Chrysostomos via RT wrote:
It's Nick Ing-Simmons's "Experimental" slab allocator for op from 1999. I suspect it would need heavy reworking to make it into a 'one pool per CV commit b7dc083 Experimental "slab" allocator for ops. -- |
From @cpansproutOn Sun May 20 01:34:06 2012, davem wrote:
So basically I can just throw the whole thing away and start from Anyway this ‘slab allocation’ is not something I’ve ever done before (my I *think* you mean something like this: Every CV can point to a slab, which is allocated much like HvARRAY, The beginning of the slab contains a pointer to the next slab, and so Freeing a CV consists of calling op_free on every element of each slab Is that how slabs work, more or less? What do we do about different op types? Do we allocate separate slabs One way to do separate slabs would be to put a flag at the beginning of What should be the default slab size? 64 ops? That seems a bit small Does sizeof(struct op) in C return the padded or unpadded size of the To avoid making the xpvcv struct any bigger for XSUBs, we could point Alternatively, we could make sure that the root is the first op in the -- Father Chrysostomos |
From @bulk88On Fri Jun 08 22:39:12 2012, sprout wrote:
I am jumping into this ticket blindly. You bring up the issue of what is |
From @cpansproutOn Fri Jun 08 23:29:45 2012, bulk88. wrote:
Yes, that’s true, more or less.
That’s what I was suggesting when I mentioned HvARRAY, but I wasn’t
That’s what I had in mind.
The complexity makes me shudder. That would be hard to get right.
That would require rewriting a lot of code, and breaking some CPAN modules.
I suggested using the savestack to free individual ops, but Dave As for freeing slabs/blocks via the savestack, I’m not sure how that
That’s a separate issue altogether. On Unix, heavy use of malloc -- Father Chrysostomos |
From @bulk88On Sat Jun 09 18:58:17 2012, sprout wrote:>
From reading how sbrk works, in unix all user mode non executable space From reading cygwin's docs, they apparently use a system wide limit of If you include mmap, from it man page, its sounds identical to Window's |
From @cpansproutOn Sun Jun 10 08:30:28 2012, bulk88. wrote:
This is getting way out of my comfort zone. I don’t know enough about -- Father Chrysostomos |
From @rurbanOn Sun, Apr 8, 2012 at 6:05 AM, Nicholas Clark <nick@ccl4.org> wrote:
I suggest to rather use clang -faddress-sanitizer as it is much Similar errors are in various CPAN modules also. |
From @cpansproutOn Wed Apr 25 03:38:30 2012, davem wrote:
And the slab/pool belonging to the sub is freed when the sub is freed. What happens to the ops attached to the regexp returned by sub { What is the value of PL_compcv when regular expressions are compiled? Do run-time code blocks get their own PL_compcv? -- Father Chrysostomos |
From @cpansproutOn Wed Apr 25 03:38:30 2012, davem wrote:
You mean something like this attachment? -- Father Chrysostomos |
From @cpansproutFrom 14e817cdd7be799d37dc309a74b7c0da97fefba2 Mon Sep 17 00:00:00 2001 This addresses bugs #111462 and #112312 and part of #107000. When a longjmp occurs during lexing, parsing or compilation, any ops This commit introduces op slabs that are attached to the currently- This is based on Nick Ing-Simmons’ old experimental op slab implemen- The old slab allocator has a pointer before each op that points to a To allow iteration through the slab to free everything, I had to have The old slab allocator puts the ops at the end of the slab first, the I tried eliminating reference counts altogether, by having all ops The CV also has to have a reference count on the slab. Sometimes the CVs use the new CVf_SLABBED flag to indicate that the CV has a refer- When the CVf_SLABBED flag is set, the CV takes responsibility for Under normal circumstances, the CV forgets about its slab (decrement- Forgetting the slab when the root is attached is not strictly neces- Since the CV takes ownership of its slab when flagged, that flag is To avoid slab fragmentation, freed ops are marked as freed and SAVEFREEOP was slightly problematic. Sometimes it can cause an op to Since many pieces of code create tiny subroutines consisting of only Smartmatch expects to be able to allocate an op at run time, run it, All of this is kept under lock and key via #ifdef PERL_CORE, as it I have left the old slab allocator (PL_OP_SLAB_ALLOC) in place, as Inline Patchdiff --git a/cv.h b/cv.h
index 072ff1e..e2644e1 100644
--- 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)
diff --git a/dump.c b/dump.c
index d9eeb25..b5240fb 100644
--- 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,"}
};
diff --git a/embed.fnc b/embed.fnc
index 568c980..b79341b 100644
--- 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
--- a/embed.h
+++ b/embed.h
@@ -794,10 +794,6 @@
#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
@@ -994,6 +990,8 @@
# 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)
@@ -1269,6 +1267,14 @@
#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
@@ -1311,9 +1317,7 @@
# 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)
diff --git a/op.c b/op.c
index 5756eeb..3be793c 100644
--- a/op.c
+++ b/op.c
@@ -298,6 +298,212 @@ 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 *
+new_slab(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 = new_slab(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;
+ DEBUG_S(Perl_warn(aTHX_ "found free op at %p, slab %p", o, slab));
+ while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
+ DEBUG_S(Perl_warn(aTHX_ "Alas! too small"));
+ o = *(too = &o->op_next);
+ DEBUG_S(
+ if(o) Perl_warn(aTHX_ "found another free op at %p", o)
+ );
+ }
+ 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 = new_slab(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;
+ DEBUG_S(Perl_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)
+{
+ 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(
+ Perl_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)
+{
+ OPSLAB *slab2;
+ PERL_ARGS_ASSERT_OPSLAB_FREE;
+ DEBUG_S(Perl_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 +736,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)
@@ -2854,6 +3067,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 */
@@ -4373,6 +4589,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;
}
@@ -4416,6 +4636,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;
@@ -6221,7 +6445,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);
@@ -6229,9 +6456,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)
@@ -6882,6 +7106,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;
@@ -6912,6 +7139,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));
@@ -6924,6 +7153,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));
@@ -6999,6 +7232,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));
@@ -7380,6 +7619,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..8e2f28f 100644
--- a/op.h
+++ b/op.h
@@ -28,8 +28,10 @@
* 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) \
+ : --(slab)->opslab_refcnt)
+ /* Variant that does not null out the pads */
+# define OpslabREFCNT_dec_padok(slab) \
+ (((slab)->opslab_refcnt == 1) \
+ ? opslab_free(slab) \
+ : --(slab)->opslab_refcnt)
#endif
struct block_hooks {
diff --git a/opnames.h b/opnames.h
index 8b6a39a..fd86d2a 100644
--- 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 0ab4f5e..58a9810 100644
--- 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);
@@ -469,6 +489,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
@@ -1892,7 +1932,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 ae4390e..878e099 100644
--- 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..88786e1 100644
--- 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;
@@ -3663,7 +3668,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 +3678,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 +3700,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 +3732,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 +3784,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 +3812,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 +3844,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)
diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index 6ddc608..1de5172 100644
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -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)
diff --git a/pp_ctl.c b/pp_ctl.c
index 437bc8f..6ebcf66 100644
--- 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
--- 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);
diff --git a/regen/opcode.pl b/regen/opcode.pl
index d8186cd..1c15edc 100755
--- a/regen/opcode.pl
+++ b/regen/opcode.pl
@@ -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
--- 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
--- 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 */ |
From @cpansproutOn Fri Jun 22 18:31:51 2012, sprout wrote:
I’ve broken it into a few commits and pushed it to the smoke-me/slop -- Father Chrysostomos |
From @iabynOn Fri, Jun 22, 2012 at 06:31:52PM -0700, Father Chrysostomos via RT wrote:
yes, thanks :-) From a cursory read of the commit message, it looks good. The only thing
IIRC, all OPs allocated for /(?{})/ code blocks are now firmly owned by a 1 for literal matches, /(?{})/, they are in the CV containing the match; -- |
From @cpansproutOn Mon Jun 25 04:56:58 2012, davem wrote:
The ops may all be attached to CVs, but I know that sometimes the op Stepping through the debugger while working on it, I found out this: The PMFUNC branch of the term rule in perly.y calls start_subparse. @@ -4373,6 +4579,10 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, -- Father Chrysostomos |
From @iabynOn Mon, Jun 25, 2012 at 08:20:27AM -0700, Father Chrysostomos via RT wrote:
I'm confused. My understand of that code path is that toke.c creates a -- |
From @cpansproutOn Mon Jun 25 09:31:07 2012, davem wrote:
Yacc confuses me, too. I can never figure out what order things are allocating op at 305b64, slab 305a80 at -e line 1. The CV discarded in pmruntime has the same slab address (it’s stored in $ gdb --args ./miniperl -DS -e 'qr/(?#(?{)/' (gdb) break Perl_start_subparse Breakpoint 3, Perl_Slab_Alloc (sz=48) at op.c:331 Breakpoint 1, Perl_start_subparse (is_format=0, flags=128) at toke.c:10759 Breakpoint 3, Perl_Slab_Alloc (sz=24) at op.c:331 Breakpoint 2, Perl_pmruntime (o=0x30595c, expr=0x305b64, isreg=true, -- Father Chrysostomos |
From @iabynOn Mon, Jun 25, 2012 at 11:09:50AM -0700, Father Chrysostomos via RT wrote:
Ah, *that* const op ;-) In which case, as regards my code, yuck! I'm tempted to eliminate it altogether. Would doing this enable you to -- |
From @cpansproutOn Mon Jun 25 14:41:06 2012, davem wrote:
No, because I still have to take SAVEFREEOP into account. :-) I could The three things I didn’t have working with my earlier (non-refcounted) smartmatch is solved by using malloc. SAVEFREEOP is solved using the refcounting system. That solves re-evals -- Father Chrysostomos |
From @cpansproutOn Sat Jun 23 16:32:20 2012, sprout wrote:
After two weeks writing the initial patch and another week tweaking and I just had another look at 8be227a, which is the main part of it, and It’s probably also my greenest patch. -- Father Chrysostomos |
From [Unknown Contact. See original ticket]On Sat Jun 23 16:32:20 2012, sprout wrote:
After two weeks writing the initial patch and another week tweaking and I just had another look at 8be227a, which is the main part of it, and It’s probably also my greenest patch. -- Father Chrysostomos |
|
@cpansprout - Status changed from 'open' to 'resolved' |
From @cpansproutOn Mon Jun 25 14:50:38 2012, sprout wrote:
Attached is an early diff containing the alternative mentioned above, This was before the re-eval rewrite was merged, before newSTUB, and -- Father Chrysostomos |
From @cpansproutInline Patchdiff --git a/cop.h b/cop.h
index af98965..650ada4 100644
--- a/cop.h
+++ b/cop.h
@@ -719,6 +719,10 @@ struct block_eval {
PL_eval_root = cx->blk_eval.old_eval_root; \
if (cx->blk_eval.old_namesv) \
sv_2mortal(cx->blk_eval.old_namesv); \
+ if (cx->blk_eval.cv) { \
+ assert(CvDEPTH(cx->blk_eval.cv) <= 1); \
+ CvDEPTH(cx->blk_eval.cv) = 0; \
+ } \
} STMT_END
/* loop context */
diff --git a/embed.fnc b/embed.fnc
index 594485d..238e89e 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -962,6 +962,9 @@ 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
+#ifndef PL_OP_SLAB_ALLOC
+p |void |op_free_root |NN OP* o
+#endif
: Used in perly.y
#ifdef PERL_MAD
p |OP* |package |NN OP* o
@@ -1770,10 +1773,12 @@ 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
+#ifndef PL_OP_SLAB_ALLOC
+p |void |Slab_Free_Slab |NN OPSLAB *slab|bool fast
+#endif
+#if defined(PERL_DEBUG_READONLY_OPS)
: Used in perl.c
poxM |void |pending_Slabs_to_ro
: Used in OpREFCNT_inc() in sv.c
@@ -1783,7 +1788,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 a980a87..a2e4ece 100644
--- a/embed.h
+++ b/embed.h
@@ -795,10 +795,6 @@
#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
@@ -993,6 +989,8 @@
# 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)
@@ -1265,6 +1263,10 @@
#define utf16_textfilter(a,b,c) S_utf16_textfilter(aTHX_ a,b,c)
# endif
# endif
+# if !defined(PL_OP_SLAB_ALLOC)
+#define Slab_Free_Slab(a,b) Perl_Slab_Free_Slab(aTHX_ a,b)
+#define op_free_root(a) Perl_op_free_root(aTHX_ a)
+# endif
# if !defined(WIN32)
#define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c)
# endif
@@ -1307,9 +1309,7 @@
# 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)
diff --git a/op.c b/op.c
index 400291a..1cc3c59 100644
--- a/op.c
+++ b/op.c
@@ -297,6 +297,182 @@ 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
+
+# define SIZE_TO_POINTERS(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
+# define DIFF(o,p) ((I32 **)(p) - (I32**)(o))
+# define NOT_FIRST_SLAB (OP *)((STRLEN *)0 + 1)
+
+static OPSLAB *
+new_slab(size_t sz)
+{
+ OPSLAB *slab = PerlMemShared_calloc(sz, sizeof(I32 *));
+ slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
+ slab->opslab_first->opslot_next = (OPSLOT *)slab;
+ return slab;
+}
+
+static OPSLAB *
+OpSLAB(OP *o)
+{
+if(!o->op_slabbed) Perl_warn_nocontext("op %p is not slabbed", o);
+ OPSLOT *slot = OpSLOT(o);
+ OPSLAB *slab;
+ while (slot->opslot_next > slot) slot = slot->opslot_next;
+ slab = (OPSLAB *)slot->opslot_next;
+ while (slab->opslab_freed == NOT_FIRST_SLAB) slab = slab->opslab_next;
+ return slab;
+}
+
+void *
+Perl_Slab_Alloc(pTHX_ size_t sz)
+{
+ dVAR;
+ OPSLAB *slab;
+ OPSLAB *slab2;
+ OPSLOT *slot;
+ OP *o;
+ size_t space;
+
+ assert(PL_compcv);
+ assert(!CvISXSUB(PL_compcv));
+DEBUG_U(if (CvROOT(PL_compcv)) { Perl_warn(aTHX_ "compcv %p root %p", PL_compcv, CvROOT(PL_compcv)); Perl_sv_dump(aTHX_ (SV *)PL_compcv); });
+ assert(!CvROOT(PL_compcv));
+ if (!CvSTART(PL_compcv)) { /* sneak it in here */
+ CvSTART(PL_compcv) = (OP *)(slab = new_slab(PERL_SLAB_SIZE));
+ slab->opslab_next = slab;
+ }
+ else slab = (OPSLAB *)CvSTART(PL_compcv);
+
+/* slab->opslab_refcnt++;*/
+
+ /*
+ * Round up the op size to the nearest pointer, and add one more
+ * pointer for opslot_next; convert to a pointer count in the process.
+ */
+ sz = SIZE_TO_POINTERS(sz) + 1;
+
+ if (slab->opslab_freed) {
+ OP **too = &slab->opslab_freed;
+ o = *too;
+ DEBUG_U(Perl_warn(aTHX_ "found free op at %p, slab %p", o, slab));
+ while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz)
+{ DEBUG_U(Perl_warn(aTHX_ "Alas! too small"));
+ o = *(too = &o->op_next);
+ DEBUG_U(if(o) Perl_warn(aTHX_ "found another free op at %p", o));}
+ if (o) {
+ *too = o->op_next;
+ Zero(o, DIFF(OpSLOT(o), OpSLOT(o)->opslot_next)-1, I32 *);
+# ifdef DEBUGGING
+ o->op_slabbed = 1;
+# endif
+ return (void *)o;
+ }
+ }
+
+ slab2 = slab;
+ while (slab2->opslab_next != slab) slab2 = slab2->opslab_next;
+ 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_POINTERS(sizeof(OP))) { /* not >= */
+ slot = &slab2->opslab_slots;
+ slot->opslot_next = slab2->opslab_first;
+ slab2->opslab_first = slot;
+ o = &slot->opslot_op;
+ o->op_type = OP_FREED;
+# ifdef DEBUGGING
+ o->op_slabbed = 1;
+# endif
+ 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 > (OPSLOT *)slab2)
+ slot = slot->opslot_next;
+ newslab = new_slab(DIFF(slab2, slot)*2);
+ slab2->opslab_next = newslab;
+ newslab->opslab_next = slab;
+ newslab->opslab_freed = NOT_FIRST_SLAB;
+ 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);
+ slot->opslot_next = slab2->opslab_first;
+ slab2->opslab_first = slot;
+ o = &slot->opslot_op;
+ DEBUG_U(Perl_warn(aTHX_ "allocating op at %p, slab %p", o, slab));
+# ifdef DEBUGGING
+ o->op_slabbed = 1;
+# endif
+ return (void *)o;
+}
+
+void
+Perl_Slab_Free(pTHX_ void *op)
+{
+ OP * const o = (OP *)op;
+ OPSLAB * const slab = OpSLAB(o);
+ PERL_ARGS_ASSERT_SLAB_FREE;
+ assert(o->op_slabbed);
+ o->op_type = OP_FREED;
+ o->op_next = slab->opslab_freed;
+/* Perl_warn(aTHX_ "free op at %p, recorded in slab %p", o, slab);*/
+ slab->opslab_freed = o;
+/* if (!--slab->opslab_refcnt) Slab_Free_Slab(slab, 1);*/
+}
+
+/* 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
+
+/* If fast is true, it is a promise that all ops have been freed. */
+
+void
+Perl_Slab_Free_Slab(pTHX_ OPSLAB *slab, bool fast) {
+ OPSLAB *slab2 = slab;
+ OPSLOT *slot;
+ PERL_ARGS_ASSERT_SLAB_FREE_SLAB;
+ assert(slab->opslab_freed != NOT_FIRST_SLAB);
+ DEBUG_U(Perl_warn(aTHX_ "freeing slab %p", slab));
+ if (!fast) {
+ do {
+ for (slot = slab->opslab_first;
+ slot->opslot_next > (OPSLOT *)slab;
+ slot = slot->opslot_next) {
+ if (slot->opslot_op.op_type != OP_FREED)
+ op_free(&slot->opslot_op);
+ }
+ /* Don’t free the slab yet, as ops in other slabs might still
+ point to it. */
+ } while ((slab2 = slab2->opslab_next) != slab);
+ }
+ for (;;) {
+ OPSLAB *nextslab = slab2->opslab_next;
+ PerlMemShared_free(slab2);
+ if (nextslab == slab) break;
+ slab2 = nextslab;
+ }
+}
+
#endif
/*
* In the following definition, the ", (OP*)0" is just to make the compiler
@@ -523,14 +699,13 @@ S_op_destroy(pTHX_ OP *o)
/* Destructor */
-void
-Perl_op_free(pTHX_ OP *o)
+static void
+S_op_free(pTHX_ OP *o, bool fast, bool is_root)
{
dVAR;
OPCODE type;
- if (!o)
- return;
+ assert(o);
if (o->op_latefreed) {
if (o->op_latefree)
return;
@@ -573,7 +748,7 @@ Perl_op_free(pTHX_ OP *o)
register OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
nextkid = kid->op_sibling; /* Get before next freeing kid */
- op_free(kid);
+ S_op_free(aTHX_ kid, fast, 0);
}
}
@@ -599,13 +774,34 @@ Perl_op_free(pTHX_ OP *o)
return;
}
do_free:
- FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
PL_op = NULL;
#endif
+#ifndef PL_OP_SLAB_ALLOC
+ if (fast) {
+ if (is_root) Slab_Free_Slab(OpSLAB(o), 1);
+ return;
+ }
+#endif
+ FreeOp(o);
+}
+
+void
+Perl_op_free(pTHX_ OP *o)
+{
+ if (o) S_op_free(aTHX_ o, 0, 0);
}
+#ifndef PL_OP_SLAB_ALLOC
+void
+Perl_op_free_root(pTHX_ OP *o)
+{
+ PERL_ARGS_ASSERT_OP_FREE_ROOT;
+ S_op_free(aTHX_ o, 1, 1);
+}
+#endif
+
void
Perl_op_clear(pTHX_ OP *o)
{
@@ -2830,6 +3026,7 @@ Perl_newPROG(pTHX_ OP *o)
PL_eval_root->op_private |= OPpREFCOUNTED;
OpREFCNT_set(PL_eval_root, 1);
PL_eval_root->op_next = 0;
+ CvROOT(PL_compcv) = PL_eval_root;
i = PL_savestack_ix;
SAVEFREEOP(o);
ENTER;
@@ -2853,6 +3050,8 @@ Perl_newPROG(pTHX_ OP *o)
PL_main_root->op_next = 0;
CALL_PEEP(PL_main_start);
finalize_optree(PL_main_root);
+ /* Stop CvSTART from pointing to the op slab. */
+ CvSTART(PL_compcv) = NULL;
PL_compcv = 0;
/* Register with debugger */
@@ -4644,7 +4843,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
OP *imop;
OP *veop;
#ifdef PERL_MAD
- OP *pegop = newOP(OP_NULL,0);
+ OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
#endif
SV *use_version = NULL;
@@ -4779,11 +4978,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
PL_cop_seqmax++;
#ifdef PERL_MAD
- if (!PL_madskills) {
- /* FIXME - don't allocate pegop if !PL_madskills */
- op_free(pegop);
- return NULL;
- }
return pegop;
#endif
}
@@ -4840,10 +5034,23 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
{
dVAR;
OP *veop, *imop;
- OP * const modname = newSVOP(OP_CONST, 0, name);
+ OP *modname;
+ I32 floor;
PERL_ARGS_ASSERT_VLOAD_MODULE;
+ /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
+ * that it has a PL_parser to play with while doing that, and also
+ * that it doesn't mess with any existing parser, by creating a tmp
+ * new parser with lex_start(). This won't actually be used for much,
+ * since pp_require() will create another parser for the real work. */
+
+ ENTER;
+ SAVEVPTR(PL_curcop);
+ lex_start(NULL, NULL, LEX_START_SAME_FILTER);
+ floor = start_subparse(FALSE, 0);
+
+ modname = newSVOP(OP_CONST, 0, name);
modname->op_private |= OPpCONST_BARE;
if (ver) {
veop = newSVOP(OP_CONST, 0, ver);
@@ -4866,16 +5073,7 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
}
}
- /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
- * that it has a PL_parser to play with while doing that, and also
- * that it doesn't mess with any existing parser, by creating a tmp
- * new parser with lex_start(). This won't actually be used for much,
- * since pp_require() will create another parser for the real work. */
-
- ENTER;
- SAVEVPTR(PL_curcop);
- lex_start(NULL, NULL, LEX_START_SAME_FILTER);
- utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
+ utilize(!(flags & PERL_LOADMOD_DENY), floor,
veop, modname, imop);
LEAVE;
}
@@ -6060,7 +6258,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(OpSLOT(loop), OpSLOT(loop)->opslot_next)
+ < SIZE_TO_POINTERS(sizeof(LOOP))+1)
+#endif
{
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
@@ -6068,9 +6269,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)
@@ -6699,6 +6897,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
+ if (CvSTART(cv)) Slab_Free_Slab((OPSLAB *)CvSTART(cv), 0);
+#endif
sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
@@ -6749,6 +6950,8 @@ 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) = NULL;
if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
@@ -6837,15 +7040,26 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
block = newblock;
}
else block->op_attached = 1;
- CvROOT(cv) = CvLVALUE(cv)
+ block = CvLVALUE(cv)
? newUNOP(OP_LEAVESUBLV, 0,
op_lvalue(scalarseq(block), OP_LEAVESUBLV))
: newUNOP(OP_LEAVESUB, 0, scalarseq(block));
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ block->op_private |= OPpREFCOUNTED;
+ OpREFCNT_set(block, 1);
+ o = LINKLIST(block);
+ block->op_next = 0;
+#ifdef PL_OP_SLAB_ALLOC
+ CvROOT(cv) = block;
+ CvSTART(cv) = o;
+#endif
+ CALL_PEEP(o);
+#ifndef PL_OP_SLAB_ALLOC
+ /* Do this after CALL_PEEP, as CALL_PEEP could create new ops, and
+ needs to see the slab in CvSTART(cv). And CvROOT(cv) must be null
+ for CvSTART(cv) to contain the slab. */
+ CvROOT(cv) = block;
+ CvSTART(cv) = o;
+#endif
finalize_optree(CvROOT(cv));
/* now that optimizer has done its work, adjust pad values */
diff --git a/op.h b/op.h
index 6aa16f5..edfb9bd 100644
--- a/op.h
+++ b/op.h
@@ -28,8 +28,9 @@
* 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_spare three spare bits!
+ * 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
@@ -62,7 +63,8 @@ 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_spare:2; \
U8 op_flags; \
U8 op_private;
#endif
@@ -579,6 +581,52 @@ struct loop {
# define Nullop ((OP*)NULL)
#endif
+/*
+ * 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 a pointer
+ * followed by an op. Each pointer points to the next op slot. At the
+ * end of the slab is a pointer back to the beginning, so that
+ * slot->opslot_next - slot can be used to determine the size of the op,
+ * and so that the beginning of the slab can be found by following the
+ * opslot_next pointers.
+ *
+ * Each CV can have multiple slabs; opslab_next points to the next slab, to
+ * form a chain.
+ *
+ * Freed ops are marked as freed and attached to the freed chain
+ * via op_next pointers. Only the first slab uses opslab_freed and
+ * opslab_refcnt.
+ *
+ * The last slab in the slab chain is assumed to be the one with free space
+ * available. It is used when allocating an op if there are no freed ops
+ * available.
+ */
+
+#if !defined(PL_OP_SLAB_ALLOC) && defined(PERL_CORE)
+struct opslot {
+ OPSLOT * opslot_next; /* next slot */
+ 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 */
+};
+
+/* First struct member used only by first slab */
+# define OPSLAB_UNUSED opslot_freed
+
+# ifdef DEBUGGING
+# define OpSLOT(o) (assert(o->op_slabbed), \
+ (OPSLOT *)(((I32 **)o)-1))
+# else
+# define OpSLOT(o) ((OPSLOT *)(((I32 **)o)-1))
+# endif
+#endif
+
/* Lowest byte of PL_opargs */
#define OA_MARK 1
#define OA_FOLDCONST 2
@@ -694,20 +742,11 @@ 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)
-#endif
struct block_hooks {
U32 bhk_flags;
diff --git a/opnames.h b/opnames.h
index 8b6a39a..fd86d2a 100644
--- 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 689a180..a1f42b4 100644
--- a/pad.c
+++ b/pad.c
@@ -346,17 +346,34 @@ Perl_cv_undef(pTHX_ CV *cv)
}
CvFILE(cv) = NULL;
- if (!CvISXSUB(cv) && CvROOT(cv)) {
+ if (!CvISXSUB(cv)) {
+ if (CvROOT(cv)) {
if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
Perl_croak(aTHX_ "Can't undef active subroutine");
ENTER;
PAD_SAVE_SETNULLPAD();
+#ifdef PL_OP_SLAB_ALLOC
op_free(CvROOT(cv));
+#else
+ op_free_root(CvROOT(cv));
+#endif
CvROOT(cv) = NULL;
CvSTART(cv) = NULL;
LEAVE;
+ }
+#ifndef PL_OP_SLAB_ALLOC
+ else if (CvSTART(cv)) {
+ ENTER;
+ PAD_SAVE_SETNULLPAD();
+
+ Slab_Free_Slab((OPSLAB *)CvSTART(cv), 0);
+ CvSTART(cv) = NULL;
+
+ LEAVE;
+ }
+#endif
}
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
CvGV_set(cv, NULL);
diff --git a/perl.c b/perl.c
index 79d15e2..04b58f2 100644
--- a/perl.c
+++ b/perl.c
@@ -747,7 +747,11 @@ perl_destruct(pTHXx)
if (CvPADLIST(PL_main_cv)) {
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
}
+#ifdef PL_OP_SLAB_ALLOC
op_free(PL_main_root);
+#else
+ op_free_root(PL_main_root);
+#endif
PL_main_root = NULL;
}
PL_main_start = NULL;
@@ -1616,7 +1620,11 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
}
if (PL_main_root) {
+#ifdef PL_OP_SLAB_ALLOC
op_free(PL_main_root);
+#else
+ op_free_root(PL_main_root);
+#endif
PL_main_root = NULL;
}
PL_main_start = NULL;
diff --git a/perl.h b/perl.h
index 798e7b7..ffddee9 100644
--- 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;
diff --git a/pp_ctl.c b/pp_ctl.c
index e196022..45afc70 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3673,7 +3673,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
PL_op = saveop;
if (yystatus != 3) {
if (PL_eval_root) {
- op_free(PL_eval_root);
+assert(CvROOT(evalcv) == PL_eval_root);
+/* op_free(PL_eval_root);*/
PL_eval_root = NULL;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
@@ -3724,10 +3725,12 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
}
else if (!startop) LEAVE_with_name("evalcomp");
CopLINE_set(&PL_compiling, 0);
+ assert(CvROOT(evalcv) == PL_eval_root);
if (startop) {
*startop = PL_eval_root;
- } else
- SAVEFREEOP(PL_eval_root);
+ CvROOT(evalcv) = NULL;
+ CvSTART(evalcv) = NULL; /* XXX This leaks a slab. */
+ }
DEBUG_x(dump_eval());
@@ -4389,11 +4392,6 @@ PP(pp_leaveeval)
gimme, SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
-#ifdef DEBUGGING
- assert(CvDEPTH(evalcv) == 1);
-#endif
- CvDEPTH(evalcv) = 0;
-
if (optype == OP_REQUIRE &&
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
{
diff --git a/proto.h b/proto.h
index 02bc3cc..c65e9cd 100644
--- 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,18 @@ STATIC I32 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
# endif
#endif
+#if !defined(PL_OP_SLAB_ALLOC)
+PERL_CALLCONV void Perl_Slab_Free_Slab(pTHX_ OPSLAB *slab, bool fast)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SLAB_FREE_SLAB \
+ assert(slab)
+
+PERL_CALLCONV void Perl_op_free_root(pTHX_ OP* o)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_OP_FREE_ROOT \
+ assert(o)
+
+#endif
#if !defined(SETUID_SCRIPTS_ARE_SECURE_NOW)
# if defined(PERL_IN_PERL_C)
STATIC void S_validate_suid(pTHX_ PerlIO *rsfp)
@@ -5248,16 +5269,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 +5276,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)
@@ -7456,17 +7473,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);
diff --git a/regen/opcode.pl b/regen/opcode.pl
index d8186cd..1c15edc 100755
--- a/regen/opcode.pl
+++ b/regen/opcode.pl
@@ -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..ec78b95 100644
--- a/scope.h
+++ b/scope.h
@@ -177,7 +177,11 @@ scope has the given name. Name must be a literal string.
#define SAVEPADSVANDMORTALIZE(s) save_padsv_and_mortalize(s)
#define SAVEFREESV(s) save_freesv(MUTABLE_SV(s))
#define SAVEMORTALIZESV(s) save_mortalizesv(MUTABLE_SV(s))
-#define SAVEFREEOP(o) save_freeop((OP*)(o))
+#ifdef PL_OP_SLAB_ALLOC
+# define SAVEFREEOP(o) save_freeop((OP*)(o))
+#else
+# define SAVEFREEOP(o) NOOP
+#endif
#define SAVEFREEPV(p) save_freepv((char*)(p))
#define SAVECLEARSV(sv) save_clearsv((SV**)&(sv))
#define SAVEGENERICSV(s) save_generic_svref((SV**)&(s))
diff --git a/sv.c b/sv.c
index fcd76a9..549cad0 100644
--- a/sv.c
+++ b/sv.c
@@ -9026,13 +9026,15 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
*st = GvESTASH(gv);
if (lref & ~GV_ADDMG && !GvCVu(gv)) {
SV *tmpsv;
+ I32 floor;
ENTER;
tmpsv = newSV(0);
gv_efullname3(tmpsv, gv, NULL);
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
- newSUB(start_subparse(FALSE, 0),
+ floor = start_subparse(FALSE, 0);
+ newSUB(floor,
newSVOP(OP_CONST, 0, tmpsv),
NULL, NULL);
LEAVE; |
From [Unknown Contact. See original ticket]On Mon Jun 25 14:50:38 2012, sprout wrote:
Attached is an early diff containing the alternative mentioned above, This was before the re-eval rewrite was merged, before newSTUB, and -- Father Chrysostomos |
Migrated from rt.perl.org#112312 (status was 'resolved')
Searchable as RT112312$
The text was updated successfully, but these errors were encountered: