perl5 version 5.14.2 coredumps during perl -c

p5pRT commented 12 years ago

Migrated from rt.perl.org#112312 (status was 'resolved')

Searchable as RT112312$

p5pRT commented 12 years ago

From andrej.zverev@gmail.com

Created by andrej.zverev@gmail.com

5.14 coredumps during perl -c for me with following scripts. with perl 5.10\, 5.12 perl -c show only syntax errors as it must be. I don't checked it with version > 5.14.2

Try to run one of the two scripts\, one of them should crash perl.

# --- script #1 #!/usr/bin/perl use strict; use warnings; sub meow (&); my %h; my $k;

meow { my $t : need_this; $t = { size => $h{$k}{size}; used => $h{$k}(used} }; }; # --- end of script #1

# --- script #2 #!/usr/bin/perl

use strict; use warnings;

sub meow (&);

my %h; my $k;

meow { my $t : need_this; $t = { size => $h{$k}{size}; used => $h{$k}(used} }; };

sub testo { my $value = shift; print; print; print; 1; }

# --- end of script #2 or links: script #1: https://gist.github.com/2318879 script #2: https://gist.github.com/2319125

results look like this: # perl -c script(1|2).pl Segmentation fault (core dumped)

Perl Info

``` Flags: category=core severity=low Site configuration information for perl 5.14.2: Configured by azverev at Wed Apr 4 07:36:27 UTC 2012. Summary of my perl5 (revision 5 version 14 subversion 2) configuration: Platform: osname=freebsd, osvers=8.3-rc2, archname=amd64-freebsd uname='freebsd bz1s2.balancers.o3.ru 8.3-rc2 freebsd 8.3-rc2 #1: wed apr 4 06:23:55 utc 2012 azverev@bz1s2.balancers.o3.ru:usrobjusrsrcsysgeneric amd64 ' config_args='-sde -Dprefix=/usr/local -Darchlib=/usr/local/lib/perl5/5.14.2/mach -Dprivlib=/usr/local/lib/perl5/5.14.2 -Dman3dir=/usr/local/lib/perl5/5.14.2/perl/man/man3 -Dman1dir=/usr/local/man/man1 -Dsitearch=/usr/local/lib/perl5/site_perl/5.14.2/mach -Dsitelib=/usr/local/lib/perl5/site_perl/5.14.2 -Dscriptdir=/usr/local/bin -Dsiteman3dir=/usr/local/lib/perl5/5.14.2/man/man3 -Dsiteman1dir=/usr/local/man/man1 -Ui_malloc -Ui_iconv -Uinstallusrbinperl -Dcc=cc -Duseshrplib -Dinc_version_list=none -Dccflags=-DAPPLLIB_EXP="/usr/local/lib/perl5/5.14.2/BSDPAN" -Doptimize=-O2 -pipe -fno-strict-aliasing -Ui_gdbm -Dusethreads=n -Dusemymalloc=n -Duse64bitint' hint=recommended, useposix=true, d_sigaction=define useithreads=undef, usemultiplicity=undef useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef use64bitint=define, use64bitall=define, uselongdouble=undef usemymalloc=n, bincompat5005=undef Compiler: cc='cc', ccflags ='-DAPPLLIB_EXP="/usr/local/lib/perl5/5.14.2/BSDPAN" -DHAS_FPSETMASK -DHAS_FLOATINGPOINT_H -fno-strict-aliasing -pipe -fstack-protector', optimize='-O2 -pipe -fno-strict-aliasing', cppflags='-DAPPLLIB_EXP="/usr/local/lib/perl5/5.14.2/BSDPAN" -DHAS_FPSETMASK -DHAS_FLOATINGPOINT_H -fno-strict-aliasing -pipe -fstack-protector' ccversion='', gccversion='4.2.2 20070831 prerelease [FreeBSD]', gccosandvers='' intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678 d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16 ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8 alignbytes=8, prototype=define Linker and Libraries: ld='cc', ldflags ='-pthread -Wl,-E -fstack-protector -L/usr/local/lib' libpth=/usr/lib /usr/local/lib libs=-lm -lcrypt -lutil perllibs=-lm -lcrypt -lutil libc=, so=so, useshrplib=true, libperl=libperl.so gnulibc_version='' Dynamic Linking: dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags=' -Wl,-R/usr/local/lib/perl5/5.14.2/mach/CORE' cccdlflags='-DPIC -fPIC', lddlflags='-shared -L/usr/local/lib -fstack-protector' Locally applied patches: @INC for perl 5.14.2: /usr/local/lib/perl5/5.14.2/BSDPAN /usr/local/lib/perl5/site_perl/5.14.2/mach /usr/local/lib/perl5/site_perl/5.14.2 /usr/local/lib/perl5/5.14.2/mach /usr/local/lib/perl5/5.14.2 . Environment for perl 5.14.2: HOME=/home/azverev LANG (unset) LANGUAGE (unset) LD_LIBRARY_PATH (unset) LOGDIR (unset) PATH=/sbin:/bin:/usr/sbin:/usr/bin:/usr/games:/usr/local/sbin:/usr/local/bin:/home/azverev/bin PERL_BADLANG (unset) SHELL=/bin/csh ```

p5pRT commented 12 years ago

From @jkeenan

On Fri Apr 06 10:59:31 2012\, azus wrote:

This is a bug report for perl from andrej.zverev@gmail.com\, generated with the help of perlbug 1.39 running under perl 5.14.2.

----------------------------------------------------------------- [Please describe your issue here]

5.14 coredumps during perl -c for me with following scripts. with perl 5.10\, 5.12 perl -c show only syntax errors as it must be. I don't checked it with version > 5.14.2

Try to run one of the two scripts\, one of them should crash perl.

# --- script #1 #!/usr/bin/perl use strict; use warnings; sub meow (&); my %h; my $k;

meow { my $t : need_this; $t = { size => $h{$k}{size}; used => $h{$k}(used} }; };

It appears there are two syntax errors here. If $t is a hash reference\, then there should be a comma after {size} -- not a semicolon. And '(used}' probably should be '{used}\,'.

Thank you very much. Jim Keenan

p5pRT commented 12 years ago

The RT System itself - Status changed from 'new' to 'open'

p5pRT commented 12 years ago

From andrej.zverev@gmail.com

It appears there are two syntax errors here. If $t is a hash reference\, then there should be a comma after {size} -- not a semicolon. And '(used}' probably should be '{used}\,'.

Yes\, there are two syntax errors but this is not a reason for segfault. Since 5.10 and 5.12 eat this fine.

p5pRT commented 12 years ago

From [Unknown Contact. See original ticket]

It appears there are two syntax errors here. If $t is a hash reference\, then there should be a comma after {size} -- not a semicolon. And '(used}' probably should be '{used}\,'.

Yes\, there are two syntax errors but this is not a reason for segfault. Since 5.10 and 5.12 eat this fine.

p5pRT commented 12 years ago

From perl@profvince.com

On 06/04/2012 22:27\, James E Keenan via RT wrote:

It appears there are two syntax errors here. If $t is a hash reference\, then there should be a comma after {size} -- not a semicolon. And '(used}' probably should be '{used}\,'.

Thank you very much. Jim Keenan

--- via perlbug: queue: perl5 status: new https://rt-archive.perl.org/perl5/Ticket/Display.html?id=112312

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 (otherwise my system's libc isn't sensitive enough to catch it). 5.12.4 doesn't crash\, but 5.14.2\, 5.15.3 and 5.15.6 do. Here's a stacktrace for perl 5.14.2 :

$ gdb --args perl5.14.2-dbg-psn-thr-64 x.pl GNU gdb (Gentoo 7.4 p1) 7.4 Copyright (C) 2012 Free Software Foundation\, Inc. License GPLv3+: GNU GPL version 3 or later \<http://gnu.org/licenses/gpl.html> This is free software: you are free to change and redistribute it. There is NO WARRANTY\, to the extent permitted by law. Type "show copying" and "show warranty" for details. This GDB was configured as "x86_64-pc-linux-gnu". For bug reporting instructions\, please see: \<http://bugs.gentoo.org/>... Reading symbols from /home/vince/perl/builds/bin/perl5.14.2-dbg-psn-thr-64...done. (gdb) r Starting program: /home/vince/perl/builds/bin/perl5.14.2-dbg-psn-thr-64 x.pl [Thread debugging using libthread_db enabled] Using host libthread_db library "/lib64/libthread_db.so.1".

Program received signal SIGSEGV\, Segmentation fault. 0x00000000004d7e84 in Perl_pad_free (my_perl=0xa86010\, po=11354992) at pad.c:1498 1498 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) { (gdb) bt #0 0x00000000004d7e84 in Perl_pad_free (my_perl=0xa86010\, po=11354992) at pad.c:1498 #1 0x000000000041dff2 in Perl_op_clear (my_perl=0xa86010\, o=0xab8aa0) at op.c:713 #2 0x000000000041d9d9 in Perl_op_free (my_perl=0xa86010\, o=0xab8aa0) at op.c:528 #3 0x00000000004d02a1 in Perl_yyparse (my_perl=0xa86010\, gramtype=258) at perly.c:678 #4 0x00000000004529aa in S_parse_body (my_perl=0xa86010\, env=0x0\, xsinit=0x41cf02 \<xs_init>) at perl.c:2194 #5 0x0000000000450a30 in perl_parse (my_perl=0xa86010\, xsinit=0x41cf02 \<xs_init>\, argc=2\, argv=0x7fffffffde88\, env=0x0) at perl.c:1613 #6 0x000000000041ce45 in main (argc=2\, argv=0x7fffffffde88\, env=0x7fffffffdea0) at perlmain.c:118

Vincent.

p5pRT commented 12 years ago

From @cpansprout

On Fri Apr 06 13:43:56 2012\, perl@profvince.com wrote:

On 06/04/2012 22:27\, James E Keenan via RT wrote:

It appears there are two syntax errors here. If $t is a hash reference\, then there should be a comma after {size} -- not a semicolon. And '(used}' probably should be '{used}\,'.

Thank you very much. Jim Keenan

--- via perlbug: queue: perl5 status: new https://rt-archive.perl.org/perl5/Ticket/Display.html?id=112312

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 (otherwise my system's libc isn't sensitive enough to catch it). 5.12.4 doesn't crash\, but 5.14.2\, 5.15.3 and 5.15.6 do. Here's a stacktrace for perl 5.14.2 :

Can we make this a 5.16 blocker?

--

Father Chrysostomos

p5pRT commented 12 years ago

From @cpansprout

On Fri Apr 06 13:43:56 2012\, perl@profvince.com wrote:

On 06/04/2012 22:27\, James E Keenan via RT wrote:

It appears there are two syntax errors here. If $t is a hash reference\, then there should be a comma after {size} -- not a semicolon. And '(used}' probably should be '{used}\,'.

Thank you very much. Jim Keenan

--- via perlbug: queue: perl5 status: new https://rt-archive.perl.org/perl5/Ticket/Display.html?id=112312

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 (otherwise my system's libc isn't sensitive enough to catch it). 5.12.4 doesn't crash\, but 5.14.2\, 5.15.3 and 5.15.6 do. Here's a stacktrace for perl 5.14.2 :
 $ gdb \-\-args perl5\.14\.2\-dbg\-psn\-thr\-64 x\.pl
 GNU gdb $Gentoo 7\.4 p1$ 7\.4
 Copyright $C$ 2012 Free Software Foundation\, Inc\.
 License GPLv3\+&#8203;: GNU GPL version 3 or later 
\<http://gnu.org/licenses/gpl.html> This is free software: you are free to change and redistribute it. There is NO WARRANTY\, to the extent permitted by law. Type "show copying" and "show warranty" for details. This GDB was configured as "x86_64-pc-linux-gnu". For bug reporting instructions\, please see: \<http://bugs.gentoo.org/>... Reading symbols from /home/vince/perl/builds/bin/perl5.14.2-dbg-psn-thr-64...done. (gdb) r Starting program: /home/vince/perl/builds/bin/perl5.14.2-dbg-psn-thr-64 x.pl [Thread debugging using libthread_db enabled] Using host libthread_db library "/lib64/libthread_db.so.1".
 Program received signal SIGSEGV\, Segmentation fault\.
 0x00000000004d7e84 in Perl\_pad\_free $my\_perl=0xa86010\, po=11354992$
     at pad\.c&#8203;:1498
 1498        if $PL\_curpad\[po\] && PL\_curpad\[po\] \!= &PL\_sv\_undef$ \{
 $gdb$ bt
 \#0  0x00000000004d7e84 in Perl\_pad\_free \(my\_perl=0xa86010\,
po=11354992) at pad.c:1498 #1 0x000000000041dff2 in Perl_op_clear (my_perl=0xa86010\, o=0xab8aa0) at op.c:713 #2 0x000000000041d9d9 in Perl_op_free (my_perl=0xa86010\, o=0xab8aa0) at op.c:528 #3 0x00000000004d02a1 in Perl_yyparse (my_perl=0xa86010\, gramtype=258) at perly.c:678 #4 0x00000000004529aa in S_parse_body (my_perl=0xa86010\, env=0x0\, xsinit=0x41cf02 \<xs_init>) at perl.c:2194 #5 0x0000000000450a30 in perl_parse (my_perl=0xa86010\, xsinit=0x41cf02 \<xs_init>\, argc=2\, argv=0x7fffffffde88\, env=0x0) at perl.c:1613 #6 0x000000000041ce45 in main (argc=2\, argv=0x7fffffffde88\, env=0x7fffffffdea0) at perlmain.c:118

For me\, with the ‘my $t : need_this;’ line deleted\, this command:

$ PERL_DESTRUCT_LEVEL=1 ../perl.git-copy/Porting/bisect.pl --target=miniperl -DDEBUGGING -Duseithreads -e '`$^X -Ilib ../foo`; warn $?; die if ($?>>8) != 255'

points to this commit:

f12005599f648e675af22dfef1047191e260bc48 is the first bad commit commit f12005599f648e675af22dfef1047191e260bc48 Author: Wolfram Humann \w\.c\.humann@arcor\.de Date: Fri Aug 13 17:20:26 2010 -0700

make string-append on win32 100 times faster
When a string grows (e.g. gets appended to)\, perl calls sv_grow. When sv_grow decides that the memory currently allocated to the string is insufficient\, it calls saferealloc. Depending on whether or not perl was compiled with 'usemymalloc' this calls realloc in either perls internal version or on the operating system. Perl requests from realloc just the amount of memory required for the current operation. With 'usemymalloc' this is not a problem because it rounds up memory allocation to a certain geometric progression anyway. When the operating system's realloc is called\, this may or may not lead to desaster\, depending on how it's implemented. On win32 it does lead to desaster: when I loop 1000 times and each time append 1000 chars to an initial string size of 10 million\, the memory grows from 10.000e6 to 10.001e6 to 10.002e6 and so on 1000 times till it ends at 11.000e6.

This is on darwin. I couldn’t reproduce in on dromedary\, hence:

That took 1710 seconds

--

Father Chrysostomos

p5pRT commented 12 years ago

From @iabyn

On Fri\, Apr 06\, 2012 at 05:44:56PM -0700\, Father Chrysostomos via RT wrote:

On Fri Apr 06 13:43:56 2012\, perl@profvince.com wrote:

On 06/04/2012 22:27\, James E Keenan via RT wrote:

It appears there are two syntax errors here. If $t is a hash reference\, then there should be a comma after {size} -- not a semicolon. And '(used}' probably should be '{used}\,'.

Thank you very much. Jim Keenan

--- via perlbug: queue: perl5 status: new https://rt-archive.perl.org/perl5/Ticket/Display.html?id=112312

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 (otherwise my system's libc isn't sensitive enough to catch it). 5.12.4 doesn't crash\, but 5.14.2\, 5.15.3 and 5.15.6 do. Here's a stacktrace for perl 5.14.2 :

Can we make this a 5.16 blocker?

valgrind shows that the fault goes back as far as 5.10.0 and has been present ever since; whether it happens to segfault is just down to circumstance.

Given how long this bug has been present\, I don't think it needs to be a 5.16 blocker.

-- Hofstadter's Law: It always takes longer than you expect\, even when you take into account Hofstadter's Law.

p5pRT commented 12 years ago

From @nwc10

On Sat\, Apr 07\, 2012 at 10:47:44PM +0100\, Dave Mitchell wrote:

On Fri\, Apr 06\, 2012 at 05:44:56PM -0700\, Father Chrysostomos via RT wrote:

On Fri Apr 06 13:43:56 2012\, perl@profvince.com 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 (otherwise my system's libc isn't sensitive enough to catch it). 5.12.4 doesn't crash\, but 5.14.2\, 5.15.3 and 5.15.6 do. Here's a stacktrace for perl 5.14.2 :

Can we make this a 5.16 blocker?

valgrind shows that the fault goes back as far as 5.10.0 and has been present ever since; whether it happens to segfault is just down to circumstance.

Given how long this bug has been present\, I don't think it needs to be a 5.16 blocker.

I bisected with this:

$ cat ../112312.sh #!/bin/sh

valgrind --error-exitcode=1 ./perl -Ilib \<\<'EOT' use strict; use warnings; sub meow (&); my %h; my $k;

meow { my $t : need_this; $t = { size => $h{$k}{size}; used => $h{$k}(used} }; }; EOT

ret=$? test $ret -eq 255 && exit 0 exit $ret

and got to this commit:

HEAD is now at 9a51af3 Fix a typo in Dynaloader_pm.PL. good - zero exit from ../112312.sh 0aded6e1de0ffebe70e2ec9f995c5ca8a55617d4 is the first bad commit commit 0aded6e1de0ffebe70e2ec9f995c5ca8a55617d4 Author: Dave Mitchell \davem@fdisolutions\.com Date: Thu Jan 18 02:14:48 2007 +0000

disable parser stack cleanup on reduce croak (too fragile)

p4raw-id: //depot/perl@29866

:100644 100644 a9e569d9c9ccd42ad9241f0d6881f30607ac2c57 c8ee62ffc62dfcd4f5a7079f97775fa70562b6e8 M perly.c bisect run success That took 2216 seconds

IIRC this was the reversion of some work to deal with leaking ops\, so I went looking for whether it previously was a regression. I *think* this is the earliest commit relating to OP leaking:

commit 0539ab63267d5a989c8b513c410c39b33c15aa25 Author: Dave Mitchell \davem@fdisolutions\.com Date: Sat May 27 00:31:33 2006 +0000

stop OPs leaking in eval "syntax error" When bison pops states during error recovery\, any states holding an OP would leak the OP. Create an extra YY table that tells us which states are of type opval\, and when popping one of those\, free the op.
p4raw-id: //depot/perl@28315

so I built its parent\, and for that valgrind shows no errors. So\, sadly\, I think that the commit 0aded6e1de0ffebe is the immediate cause of this.

But\, I'm suspecting\, that the only *real* fix to all of this mess is to garbage collect the OPs\, in some fashion.

Nicholas Clark

p5pRT commented 12 years ago

From @iabyn

On Sun\, Apr 08\, 2012 at 11:31:37AM +0100\, Nicholas Clark wrote:

But\, I'm suspecting\, that the only *real* fix to all of this mess is to garbage collect the OPs\, in some fashion.

Ah yes\, *that* quagmire. Anyway\, thanks for bisecting this. It may be that my disabling of the experimental anti-leaking code just didn't quite disable enough.

-- "Do not dabble in paradox\, Edward\, it puts you in danger of fortuitous wit." -- Lady Croom\, "Arcadia"

p5pRT commented 12 years ago

From @nwc10

On Sun\, Apr 08\, 2012 at 11:42:06AM +0100\, Dave Mitchell wrote:

On Sun\, Apr 08\, 2012 at 11:31:37AM +0100\, Nicholas Clark wrote:

But\, I'm suspecting\, that the only *real* fix to all of this mess is to garbage collect the OPs\, in some fashion.

Ah yes\, *that* quagmire. Anyway\, thanks for bisecting this.

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 to the bisect thingy to make this fall-off-a-log easy for anyone to do in future (ie valgrind --error-exitcode=1 ./perl ...). *But* the use case here was syntax checking\, which that seems to be something we're going to need to test again\, and as one can see from the structure of the shell script\, it's not as simple as I'd hoped. A failure exit code from valgrind is a failure\, whereas a failure exit code passed through from the perl interpreter (because valgrind found no errors) is a pass.

$ cat ../112312.sh #!/bin/sh

valgrind --error-exitcode=1 ./perl -Ilib \<\<'EOT' use strict; use warnings; sub meow (&); my %h; my $k;

meow { my $t : need_this; $t = { size => $h{$k}{size}; used => $h{$k}(used} }; }; EOT

ret=$? test $ret -eq 255 && exit 0 exit $ret

So I'll do something else for a bit\, to see if inspiration attacks. (Or maybe lunch will attack first.)

Nicholas Clark

p5pRT commented 12 years ago

From @cpansprout

On Sun Apr 08 03:32:21 2012\, nicholas wrote:

But\, I'm suspecting\, that the only *real* fix to all of this mess is to garbage collect the OPs\, in some fashion.

The simplest way might be to create something like the mortals’ stack\, but for OPs. Or maybe a mortalop hash.

Code that could croak can do the equivalent of SAVEFREEOP\, and then delete the op from the mortalop stack when everything is safe.

Would that be as fast as a tortoise\, or slower?

Or maybe a suggestion I had earlier: a variant of SAVEFREEOP that uses the savestack but returns a token (probably a stack offset) that can be used to disarm the item on the savestack and turn it into a no-op:

I32 token = SAVEFREEOP_token(o); ... do something unsafe that might croak ... DISARM_SAVESTACK(token); op_free(o);

--

Father Chrysostomos

p5pRT commented 12 years ago

From @iabyn

On Tue\, Apr 24\, 2012 at 02:01:45PM -0700\, Father Chrysostomos via RT wrote:

On Sun Apr 08 03:32:21 2012\, nicholas wrote:

But\, I'm suspecting\, that the only *real* fix to all of this mess is to garbage collect the OPs\, in some fashion.

The simplest way might be to create something like the mortals’ stack\, but for OPs. Or maybe a mortalop hash.

Code that could croak can do the equivalent of SAVEFREEOP\, and then delete the op from the mortalop stack when everything is safe.

Would that be as fast as a tortoise\, or slower?

Or maybe a suggestion I had earlier: a variant of SAVEFREEOP that uses the savestack but returns a token (probably a stack offset) that can be used to disarm the item on the savestack and turn it into a no-op:
I32 token = SAVEFREEOP\_token$o$;
\.\.\. do something unsafe that might croak \.\.\.
DISARM\_SAVESTACK$token$;
op\_free$o$;

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

-- "Procrastination grows to fill the available time" -- Mitchell's corollary to Parkinson's Law

p5pRT commented 12 years ago

From @cpansprout

On Wed Apr 25 03:38:30 2012\, davem wrote:

On Tue\, Apr 24\, 2012 at 02:01:45PM -0700\, Father Chrysostomos via RT wrote:
On Sun Apr 08 03:32:21 2012\, nicholas wrote:

But\, I'm suspecting\, that the only *real* fix to all of this mess is to garbage collect the OPs\, in some fashion.

The simplest way might be to create something like the mortals’ stack\, but for OPs. Or maybe a mortalop hash.

Code that could croak can do the equivalent of SAVEFREEOP\, and then delete the op from the mortalop stack when everything is safe.

Would that be as fast as a tortoise\, or slower?

Or maybe a suggestion I had earlier: a variant of SAVEFREEOP that uses the savestack but returns a token (probably a stack offset) that can be used to disarm the item on the savestack and turn it into a no-op:
I32 token = SAVEFREEOP\_token$o$;
\.\.\. do something unsafe that might croak \.\.\.
DISARM\_SAVESTACK$token$;
op\_free$o$;
I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

I sort of understand that in theory\, but I don’t understand it well enough to feel confident about implementing it.

--

Father Chrysostomos

p5pRT commented 12 years ago

From @cpansprout

On Wed Apr 25 03:38:30 2012\, davem wrote:

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

What exactly is that code at the top of op.c that is compiled only when PL_OP_SLAB_ALLOC is defined?

--

Father Chrysostomos

p5pRT commented 12 years ago

From @iabyn

On Thu\, May 17\, 2012 at 10:02:39AM -0700\, Father Chrysostomos via RT wrote:

On Wed Apr 25 03:38:30 2012\, davem wrote:

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

What exactly is that code at the top of op.c that is compiled only when PL_OP_SLAB_ALLOC is defined?

It's Nick Ing-Simmons's "Experimental" slab allocator for op from 1999. Its never normally used\, apart from\, apparently\, when PERL_IMPLICIT_SYS is defined.

I suspect it would need heavy reworking to make it into a 'one pool per CV and throw the whole thing away on error' system.

commit b7dc083c47d05133e90d62e8b587c747dab89267 Author: Nick Ing-Simmons \nik@tiuk\.ti\.com AuthorDate: Fri May 14 21:04:22 1999 +0000 Commit: Nick Ing-Simmons \nik@tiuk\.ti\.com CommitDate: Fri May 14 21:04:22 1999 +0000

Experimental "slab" allocator for ops. To try it -DPL_OP_SLAB_ALLOC for op.c This is for proof of concept only\, it leaks memory (ops are not free'd) so don't use in embedded apps. If this minimalist version does not show performance gain then whole idea is worthless. Nick see's approx 12% speed up vs perlmalloc running perl -Ilib -MCPAN -e '' Solaris2.6\, gcc-2.8.1 but numbers are not repeatable.

-- Nothing ventured\, nothing lost.

p5pRT commented 12 years ago

From @cpansprout

On Sun May 20 01:34:06 2012\, davem wrote:

On Thu\, May 17\, 2012 at 10:02:39AM -0700\, Father Chrysostomos via RT wrote:

On Wed Apr 25 03:38:30 2012\, davem wrote:

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

What exactly is that code at the top of op.c that is compiled only when PL_OP_SLAB_ALLOC is defined?

It's Nick Ing-Simmons's "Experimental" slab allocator for op from 1999. Its never normally used\, apart from\, apparently\, when PERL_IMPLICIT_SYS is defined.

I suspect it would need heavy reworking to make it into a 'one pool per CV and throw the whole thing away on error' system.

So basically I can just throw the whole thing away and start from scratch? :-)

Anyway this ‘slab allocation’ is not something I’ve ever done before (my C experience being limited to what I’ve done with perl).

I *think* you mean something like this:

Every CV can point to a slab\, which is allocated much like HvARRAY\, except it can never be reallocked\, because there are pointers into it.

The beginning of the slab contains a pointer to the next slab\, and so on\, so we never run out.

Freeing a CV consists of calling op_free on every element of each slab and calling Safefree or PerlMemShared_free (what is the difference between these two sets of memory functions?) on each slab at the end.

Is that how slabs work\, more or less?

What do we do about different op types? Do we allocate separate slabs for each op type? Do we just use the largest and hope the extra padding that small op structs get isn’t too much of a waste? Do we allocate a slab with different parts of the slab set aside for different op sizes (and flags at the beginning of the slab to indicate how many of each there are)?

One way to do separate slabs would be to put a flag at the beginning of each slab to say what it holds\, and then just chain them all together.

What should be the default slab size? 64 ops? That seems a bit small for\, say\, DBI\, JE\, or Parse::RecDescent\, but big for people who like lots of tiny subroutines. However\, it’s probably a good compromise.

Does sizeof(struct op) in C return the padded or unpadded size of the struct in octets?

To avoid making the xpvcv struct any bigger for XSUBs\, we could point xcv_root to the first slab. Would that break anything?

Alternatively\, we could make sure that the root is the first op in the first slab\, and then use pointer arithmetic xcv_root to get to the beginning of the slab.

--

Father Chrysostomos

p5pRT commented 12 years ago

From @bulk88

On Fri Jun 08 22:39:12 2012\, sprout wrote:

So basically I can just throw the whole thing away and start from scratch? :-)

Anyway this ‘slab allocation’ is not something I’ve ever done before (my C experience being limited to what I’ve done with perl).

I *think* you mean something like this:

Every CV can point to a slab\, which is allocated much like HvARRAY\, except it can never be reallocked\, because there are pointers into it.

The beginning of the slab contains a pointer to the next slab\, and so on\, so we never run out.

Freeing a CV consists of calling op_free on every element of each slab and calling Safefree or PerlMemShared_free (what is the difference between these two sets of memory functions?) on each slab at the end.

Is that how slabs work\, more or less?

What do we do about different op types? Do we allocate separate slabs for each op type? Do we just use the largest and hope the extra padding that small op structs get isn’t too much of a waste? Do we allocate a slab with different parts of the slab set aside for different op sizes (and flags at the beginning of the slab to indicate how many of each there are)?

One way to do separate slabs would be to put a flag at the beginning of each slab to say what it holds\, and then just chain them all together.

What should be the default slab size? 64 ops? That seems a bit small for\, say\, DBI\, JE\, or Parse::RecDescent\, but big for people who like lots of tiny subroutines. However\, it’s probably a good compromise.

Does sizeof(struct op) in C return the padded or unpadded size of the struct in octets?

To avoid making the xpvcv struct any bigger for XSUBs\, we could point xcv_root to the first slab. Would that break anything?

Alternatively\, we could make sure that the root is the first op in the first slab\, and then use pointer arithmetic xcv_root to get to the beginning of the slab.

I am jumping into this ticket blindly. You bring up the issue of what is "typical" perl usage and what ops are most important (I know pp_hot is an attempt at sorting them). That question is still in unanswered in perltodo. Each malloc block has a header\, thats 2 to 6 pointers of memory depending on OS/C lib. From looking at op.h\, all of the op structs end in pointers excecpt for BASEOP\, I think BASEOP is a multiple of 32 bits\, and gets padding on 64 bits. So I presume all the op structs are a multiple of a pointer in size due to compiler alignment. I GUESS (i'm jumping in here) the ops are made by the parser as the perl text is processed. The op structs can be placed sequentially in memory I guess. To deal with how to free the op struct blocks\, 1st choice is a double linked list header on each op struct blocks for the current compiling context or CV or eval scope or whatever. The linked list is gone down to free the blocks. Another choice 1 block per CV/whatever\, when overfilled\, realloc and move the op and fixup the pointers\, whether to make the realloc amount a % of existing size or a fix amount IDK. Or get rid of OP *s and use relative offsets for related op structs that an op struct must link to so reallocs are cheaper. Where to store the base pointer\, IDK. Another idea is small multibit bitfield that specifies the offset or index from the current op struct to its mem block header. Another way to free the blocks is the save stack. Someone will argue for perl to implement its own memory allocator\, it must request entire whole pages from the OS to be memory efficient\, not large malloc blocks that contain malloc headers and speculative realloc space after them.

p5pRT commented 12 years ago

From @cpansprout

On Fri Jun 08 23:29:45 2012\, bulk88. wrote:

On Fri Jun 08 22:39:12 2012\, sprout wrote:

So basically I can just throw the whole thing away and start from scratch? :-)

Anyway this ‘slab allocation’ is not something I’ve ever done before (my C experience being limited to what I’ve done with perl).

I *think* you mean something like this:

Every CV can point to a slab\, which is allocated much like HvARRAY\, except it can never be reallocked\, because there are pointers into it.

The beginning of the slab contains a pointer to the next slab\, and so on\, so we never run out.

Freeing a CV consists of calling op_free on every element of each slab and calling Safefree or PerlMemShared_free (what is the difference between these two sets of memory functions?) on each slab at the end.

Is that how slabs work\, more or less?

What do we do about different op types? Do we allocate separate slabs for each op type? Do we just use the largest and hope the extra padding that small op structs get isn’t too much of a waste? Do we allocate a slab with different parts of the slab set aside for different op sizes (and flags at the beginning of the slab to indicate how many of each there are)?

One way to do separate slabs would be to put a flag at the beginning of each slab to say what it holds\, and then just chain them all together.

What should be the default slab size? 64 ops? That seems a bit small for\, say\, DBI\, JE\, or Parse::RecDescent\, but big for people who like lots of tiny subroutines. However\, it’s probably a good compromise.

Does sizeof(struct op) in C return the padded or unpadded size of the struct in octets?

To avoid making the xpvcv struct any bigger for XSUBs\, we could point xcv_root to the first slab. Would that break anything?

Alternatively\, we could make sure that the root is the first op in the first slab\, and then use pointer arithmetic xcv_root to get to the beginning of the slab.

I am jumping into this ticket blindly. You bring up the issue of what is "typical" perl usage and what ops are most important (I know pp_hot is an attempt at sorting them). That question is still in unanswered in perltodo. Each malloc block has a header\, thats 2 to 6 pointers of memory depending on OS/C lib. From looking at op.h\, all of the op structs end in pointers excecpt for BASEOP\, I think BASEOP is a multiple of 32 bits\, and gets padding on 64 bits. So I presume all the op structs are a multiple of a pointer in size due to compiler alignment. I GUESS (i'm jumping in here) the ops are made by the parser as the perl text is processed.

Yes\, that’s true\, more or less.

The op structs can be placed sequentially in memory I guess.

That’s what I was suggesting when I mentioned HvARRAY\, but I wasn’t clear at all. And HvARRAY is a little different\, too.

To deal with how to free the op struct blocks\, 1st choice is a double linked list header on each op struct blocks for the current compiling context or CV or eval scope or whatever. The linked list is gone down to free the blocks.

That’s what I had in mind.

Another choice 1 block per CV/whatever\, when overfilled\, realloc and move the op and fixup the pointers\, whether to make the realloc amount a % of existing size or a fix amount IDK.

The complexity makes me shudder. That would be hard to get right.

Or get rid of OP *s and use relative offsets for related op structs that an op struct must link to so reallocs are cheaper. Where to store the base pointer\, IDK.

That would require rewriting a lot of code\, and breaking some CPAN modules.

Another idea is small multibit bitfield that specifies the offset or index from the current op struct to its mem block header. Another way to free the blocks is the save stack.

I suggested using the savestack to free individual ops\, but Dave Mitchell pointed out that less code would have to change with slab/block allocation.

As for freeing slabs/blocks via the savestack\, I’m not sure how that would work. If the slabs are attached to the CV\, then they will be freed indirectly via the savestack when there are compilation errors.

Someone will argue for perl to implement its own memory allocator\, it must request entire whole pages from the OS to be memory efficient\, not large malloc blocks that contain malloc headers and speculative realloc space after them.

That’s a separate issue altogether. On Unix\, heavy use of malloc doesn’t suffer any performance penalty. On Windows\, my understanding is that realloc is something to be avoided. Nicholas Clark mentioned using malloc.c (perl’s own malloc implementation\, which can be enabled via -Dusemymalloc) but having it use Windows malloc instead of sbrk\, which would solve the efficiency problems. I have no intention of doing Windows-specific stuff\, though.

--

Father Chrysostomos

p5pRT commented 12 years ago

From @bulk88

On Sat Jun 09 18:58:17 2012\, sprout wrote:>

Another idea is small multibit bitfield that specifies the offset or index from the current op struct to its mem block header. Another way to free the blocks is the save stack.

I suggested using the savestack to free individual ops\, but Dave Mitchell pointed out that less code would have to change with slab/block allocation. There are free bits in BASEOP.

Someone will argue for perl to implement its own memory allocator\, it must request entire whole pages from the OS to be memory efficient\, not large malloc blocks that contain malloc headers and speculative realloc space after them.

That’s a separate issue altogether. On Unix\, heavy use of malloc doesn’t suffer any performance penalty. On Windows\, my understanding is that realloc is something to be avoided. Nicholas Clark mentioned using malloc.c (perl’s own malloc implementation\, which can be enabled via -Dusemymalloc) but having it use Windows malloc instead of sbrk\, which would solve the efficiency problems. I have no intention of doing Windows-specific stuff\, though.

From reading how sbrk works\, in unix all user mode non executable space is one linear continuous uninterrupted block\, so it only grows or shrinks\, there is no concept of allocations and pointers to allocations from the paging system of the OS\, right? It also seems to me that on unix it would nearly impossible to shrink the data segment for the process due to fragmentation. So creating a cross platform memory allocator for Perl memory allocations API is impossible or just not useful?

From reading cygwin's docs\, they apparently use a system wide limit of 384 MB per process that sbrk on cygwin can allocate (http://www.perlmonks.org/?node_id=541750). A system wide setting can increase that. I assume cygwin "reserves" but doesn't "allocate" that 384 MB range using windows VM system to emulate sbrk.

If you include mmap\, from it man page\, its sounds identical to Window's virtual memory allocator\, and a cross platform allocator for allocators internal API in perl is very easy\, possibly as easy as a large macro. I don't know how vm allocation works on all the other platforms Perl runs on\, as a last resort\, the allocator for allocators can be redirected to malloc. Malloc.c seems to have been written around using sbrk\, and I couldn't find any code in it that will ever do a release to the OS using sbrk or brk.

p5pRT commented 12 years ago

From @cpansprout

On Sun Jun 10 08:30:28 2012\, bulk88. wrote:

On Sat Jun 09 18:58:17 2012\, sprout wrote:>

Another idea is small multibit bitfield that specifies the offset or index from the current op struct to its mem block header. Another way to free the blocks is the save stack.

I suggested using the savestack to free individual ops\, but Dave Mitchell pointed out that less code would have to change with slab/block allocation. There are free bits in BASEOP.

Someone will argue for perl to implement its own memory allocator\, it must request entire whole pages from the OS to be memory efficient\, not large malloc blocks that contain malloc headers and speculative realloc space after them.

That’s a separate issue altogether. On Unix\, heavy use of malloc doesn’t suffer any performance penalty. On Windows\, my understanding is that realloc is something to be avoided. Nicholas Clark mentioned using malloc.c (perl’s own malloc implementation\, which can be enabled via -Dusemymalloc) but having it use Windows malloc instead of sbrk\, which would solve the efficiency problems. I have no intention of doing Windows-specific stuff\, though.

From reading how sbrk works\, in unix all user mode non executable space is one linear continuous uninterrupted block\, so it only grows or shrinks\, there is no concept of allocations and pointers to allocations from the paging system of the OS\, right? It also seems to me that on unix it would nearly impossible to shrink the data segment for the process due to fragmentation. So creating a cross platform memory allocator for Perl memory allocations API is impossible or just not useful?

From reading cygwin's docs\, they apparently use a system wide limit of 384 MB per process that sbrk on cygwin can allocate (http://www.perlmonks.org/?node_id=541750). A system wide setting can increase that. I assume cygwin "reserves" but doesn't "allocate" that 384 MB range using windows VM system to emulate sbrk.

If you include mmap\, from it man page\, its sounds identical to Window's virtual memory allocator\, and a cross platform allocator for allocators internal API in perl is very easy\, possibly as easy as a large macro. I don't know how vm allocation works on all the other platforms Perl runs on\, as a last resort\, the allocator for allocators can be redirected to malloc. Malloc.c seems to have been written around using sbrk\, and I couldn't find any code in it that will ever do a release to the OS using sbrk or brk.

This is getting way out of my comfort zone. I don’t know enough about this to contribute any more to this aspect of the thread.

--

Father Chrysostomos

p5pRT commented 12 years ago

From @rurban

On Sun\, Apr 8\, 2012 at 6:05 AM\, Nicholas Clark \nick@ccl4\.org wrote:

On Sun\, Apr 08\, 2012 at 11:42:06AM +0100\, Dave Mitchell wrote:

On Sun\, Apr 08\, 2012 at 11:31:37AM +0100\, Nicholas Clark wrote:

But\, I'm suspecting\, that the only *real* fix to all of this mess is to garbage collect the OPs\, in some fashion.

Ah yes\, *that* quagmire. Anyway\, thanks for bisecting this.

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 to the bisect thingy to make this fall-off-a-log easy for anyone to do in future (ie valgrind --error-exitcode=1 ./perl ...).

I suggest to rather use clang -faddress-sanitizer as it is much faster\, does not need such a hack and detects many more such errors than valgrind.

Similar errors are in various CPAN modules also. -- Reini Urban http://cpanel.net/ http://www.perl-compiler.org/

p5pRT commented 12 years ago

From @cpansprout

On Wed Apr 25 03:38:30 2012\, davem wrote:

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

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 { qr/(?{})/ }?

What is the value of PL_compcv when regular expressions are compiled? Does each qr// or m// with code blocks get its own compcv?

Do run-time code blocks get their own PL_compcv?

--

Father Chrysostomos

p5pRT commented 12 years ago

From @cpansprout

On Wed Apr 25 03:38:30 2012\, davem wrote:

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

You mean something like this attachment?

--

Father Chrysostomos

p5pRT commented 12 years ago

From @cpansprout

From 14e817cdd7be799d37dc309a74b7c0da97fefba2 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos \sprout@cpan\.org Date: Fri\, 22 Jun 2012 18:30:48 -0700 Subject: [PATCH] CV-based slab allocation for ops MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit

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\, 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. :-)

Inline Patch

```diff diff --git a/cv.h b/cv.h index 072ff1e..e2644e1 100644 --- a/cv.h +++ b/cv.h @@ -105,6 +105,9 @@ See L. #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. #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. #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 () { 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 */ ```

p5pRT commented 12 years ago

From @cpansprout

On Fri Jun 22 18:31:51 2012\, sprout wrote:

On Wed Apr 25 03:38:30 2012\, davem wrote:

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

You mean something like this attachment?

I’ve broken it into a few commits and pushed it to the smoke-me/slop branch. It still contains a megapatch though\, because most of it is interdependent.

--

Father Chrysostomos

p5pRT commented 12 years ago

From @iabyn

On Fri\, Jun 22\, 2012 at 06:31:52PM -0700\, Father Chrysostomos via RT wrote:

On Wed Apr 25 03:38:30 2012\, davem wrote:

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

You mean something like this attachment?

yes\, thanks :-)

From a cursory read of the commit message\, it looks good. The only thing that stood out for me was:

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.

IIRC\, all OPs allocated for /(?{})/ code blocks are now firmly owned by a CV:

1 for literal matches\, /(?{})/\, they are in the CV containing the match; 2 for literal qr\, qr/(?{})/\, they are stored in an anon CV which is attached to the regex\, and cloned each time the qr// is run; 3 for run-time code\, the pattern is wrapped in a qr// and reparsed\, so (2) applies. 4 when a qr// is interpolated into another pattern\, e.g $r = qr/(?{})/; /a-$r/\, then the new regex contains both pointers to the ops within the (?{})\, but also a pointer to the CV those ops are embedded in: so they won't outlive the CV.

-- More than any other time in history\, mankind faces a crossroads. One path leads to despair and utter hopelessness. The other\, to total extinction. Let us pray we have the wisdom to choose correctly. -- Woody Allen

p5pRT commented 12 years ago

From @cpansprout

On Mon Jun 25 04:56:58 2012\, davem wrote:

On Fri\, Jun 22\, 2012 at 06:31:52PM -0700\, Father Chrysostomos via RT wrote:

On Wed Apr 25 03:38:30 2012\, davem wrote:

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

You mean something like this attachment?

yes\, thanks :-)

From a cursory read of the commit message\, it looks good. The only thing that stood out for me was:

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.

IIRC\, all OPs allocated for /(?{})/ code blocks are now firmly owned by a CV:

1 for literal matches\, /(?{})/\, they are in the CV containing the match; 2 for literal qr\, qr/(?{})/\, they are stored in an anon CV which is attached to the regex\, and cloned each time the qr// is run; 3 for run-time code\, the pattern is wrapped in a qr// and reparsed\, so (2) applies. 4 when a qr// is interpolated into another pattern\, e.g $r = qr/(?{})/; /a-$r/\, then the new regex contains both pointers to the ops within the (?{})\, but also a pointer to the CV those ops are embedded in: so they won't outlive the CV.

The ops may all be attached to CVs\, but I know that sometimes the op that the CV is finally attached to is not the same one that was PL_compcv when the op was created.

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. Then a const op is created in toke.c to hold the pattern (I don’t remember exactly where)\, and then op.c:pmruntime is called\, hence this hunk:

@@ -4373\,6 +4579\,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; }

--

Father Chrysostomos

p5pRT commented 12 years ago

From @iabyn

On Mon\, Jun 25\, 2012 at 08:20:27AM -0700\, Father Chrysostomos via RT wrote:

The ops may all be attached to CVs\, but I know that sometimes the op that the CV is finally attached to is not the same one that was PL_compcv when the op was created.

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. Then a const op is created in toke.c to hold the pattern (I don’t remember exactly where)\, and then op.c:pmruntime is called\, hence this hunk:

@@ -4373\,6 +4579\,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; }

I'm confused. My understand of that code path is that toke.c creates a PMOP (using the "main" PL_compcv); *then* start_subparse() is called (changing PL_compcv)\, *then* pmruntime() runs the "whoops\, guessed wrong" code and frees the inner PL_compcv. I don't see any ops being created between the start_subparse and the pmruntime ???

-- Never do today what you can put off till tomorrow.

p5pRT commented 12 years ago

From @cpansprout

On Mon Jun 25 09:31:07 2012\, davem wrote:

On Mon\, Jun 25\, 2012 at 08:20:27AM -0700\, Father Chrysostomos via RT wrote:

The ops may all be attached to CVs\, but I know that sometimes the op that the CV is finally attached to is not the same one that was PL_compcv when the op was created.

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. Then a const op is created in toke.c to hold the pattern (I don’t remember exactly where)\, and then op.c:pmruntime is called\, hence this hunk:

@@ -4373\,6 +4579\,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; }

I'm confused. My understand of that code path is that toke.c creates a PMOP (using the "main" PL_compcv); *then* start_subparse() is called (changing PL_compcv)\, *then* pmruntime() runs the "whoops\, guessed wrong" code and frees the inner PL_compcv. I don't see any ops being created between the start_subparse and the pmruntime ???

Yacc confuses me\, too. I can never figure out what order things are going to happen. But look at this gdb session (using the smoke-me/slop branch). An op is allocated between the calls to start_subparse and pmruntime. In particular\, this message comes from the op allocated in between (-DS output):

allocating op at 305b64\, slab 305a80 at -e line 1.

The CV discarded in pmruntime has the same slab address (it’s stored in CvSTART\, aka ((XPVCV*)PL_compcv->sv_any)->xcv_start_u.xcv_start).

$ gdb --args ./miniperl -DS -e 'qr/(?#(?{)/' GNU gdb 6.3.50-20050815 (Apple version gdb-1469) (Wed May 5 04:30:06 UTC 2010) Copyright 2004 Free Software Foundation\, Inc. GDB is free software\, covered by the GNU General Public License\, and you are welcome to change it and/or distribute copies of it under certain conditions. Type "show copying" to see the conditions. There is absolutely no warranty for GDB. Type "show warranty" for details. This GDB was configured as "i386-apple-darwin"...Reading symbols for shared libraries .... done

(gdb) break Perl_start_subparse Breakpoint 1 at 0x42d4f: file toke.c\, line 10759. (gdb) break Perl_pmruntime Breakpoint 2 at 0x2ed48: file op.c\, line 4474. (gdb) break Perl_Slab_Alloc Breakpoint 3 at 0x132b5: file op.c\, line 331. (gdb) run Starting program: /Users/sprout/Perl/perl.git-copy/miniperl -DS -e qr/$\?\#\(\?\{$/ Reading symbols for shared libraries +++. done

Breakpoint 3\, Perl_Slab_Alloc (sz=48) at op.c:331 331 if (!PL_compcv || CvROOT(PL_compcv) (gdb) c Continuing. Current language: auto; currently c++ allocating op at 30595c\, slab 305890 at -e line 1.

Breakpoint 1\, Perl_start_subparse (is_format=0\, flags=128) at toke.c:10759 10759 const I32 oldsavestack_ix = PL_savestack_ix; (gdb) up #1 0x00073de7 in Perl_yyparse (gramtype=258) at perly.y:1266 1266 $\$ = start_subparse(FALSE\, CVf_ANON); (gdb) c Continuing.

Breakpoint 3\, Perl_Slab_Alloc (sz=24) at op.c:331 331 if (!PL_compcv || CvROOT(PL_compcv) (gdb) bt #0 Perl_Slab_Alloc (sz=24) at op.c:331 #1 0x0001a167 in Perl_newSVOP (type=5\, flags=0\, sv=0x8222f0) at op.c:4847 #2 0x000560d5 in S_scan_const (start=0x305840 "(?#(?{)") at toke.c:3578 #3 0x0005b572 in Perl_yylex () at toke.c:4743 #4 0x00070f05 in Perl_yyparse (gramtype=258) at perly.c:430 #5 0x0000d3a1 in S_parse_body (env=0x0\, xsinit=0x30740 \<_ZL7xs_initv>) at perl.c:2256 #6 0x0000e479 in perl_parse (my_perl=0x300190\, xsinit=0x30740 \<_ZL7xs_initv>\, argc=4\, argv=0xbffff830\, env=0x0) at perl.c:1643 #7 0x000307e7 in main (argc=4\, argv=0xbffff830\, env=0xbffff844) at miniperlmain.c:117 (gdb) c Continuing. allocating op at 305b64\, slab 305a80 at -e line 1.

Breakpoint 2\, Perl_pmruntime (o=0x30595c\, expr=0x305b64\, isreg=true\, floor=38) at op.c:4474 4474 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR); (gdb) clear Perl_Slab_Alloc Deleted breakpoint 3 (gdb) n 4482 if (is_trans || o->op_type == OP_SUBST) { (gdb) 4504 return pmtrans(o\, expr\, repl); (gdb) 4482 if (is_trans || o->op_type == OP_SUBST) { (gdb) 4515 if (expr->op_type == OP_LIST) { (gdb) 4527 else if (expr->op_type != OP_CONST) (gdb) 4530 LINKLIST(expr); (gdb) s 4534 if (expr->op_type == OP_LIST) { (gdb) 4571 PL_hints |= HINT_BLOCK_SCOPE; (gdb) 4573 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV)); (gdb) 4575 if (is_compiletime) { (gdb) 4576 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; (gdb) 4577 regexp_engine const *eng = current_re_engine(); (gdb) n 4580 rx_flags |= RXf_SPLIT; (gdb) 4582 if (!has_code || !eng->op_comp) { (gdb) 4585 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) { (gdb) 4591 assert(AvFILLp(PL_comppad) == 0); /* just @_ */ (gdb) 4594 cv_forget_slab(PL_compcv); (gdb) p ((XPVCV*)PL_compcv->sv_any)->xcv_start_u.xcv_start $2 = (OP *) 0x305a80

--

Father Chrysostomos

p5pRT commented 12 years ago

From @iabyn

On Mon\, Jun 25\, 2012 at 11:09:50AM -0700\, Father Chrysostomos via RT wrote:

Breakpoint 1\, Perl_start_subparse (is_format=0\, flags=128) at toke.c:10759 10759 const I32 oldsavestack_ix = PL_savestack_ix; (gdb) up

Breakpoint 3\, Perl_Slab_Alloc (sz=24) at op.c:331 331 if (!PL_compcv || CvROOT(PL_compcv) (gdb) bt #0 Perl_Slab_Alloc (sz=24) at op.c:331 #1 0x0001a167 in Perl_newSVOP (type=5\, flags=0\, sv=0x8222f0) at op.c:4847 #2 0x000560d5 in S_scan_const (start=0x305840 "(?#(?{)") at toke.c:3578

Ah\, *that* const op ;-) Somehow I missed triggering an op alloc breakpoint when I tried it earlier.

In which case\, as regards my code\, yuck! That "we guessed we had a code block but it turns out we didn't" bit of code was always a bit of hack\, and now that I realise it leaves an op allocated in the wrong CV\, I like it even less.

I'm tempted to eliminate it altogether. Would doing this enable you to simplify the slab code?

-- But Pity stayed his hand. "It's a pity I've run out of bullets"\, he thought. -- "Bored of the Rings"

p5pRT commented 12 years ago

From @cpansprout

On Mon Jun 25 14:41:06 2012\, davem wrote:

On Mon\, Jun 25\, 2012 at 11:09:50AM -0700\, Father Chrysostomos via RT wrote:

Breakpoint 1\, Perl_start_subparse (is_format=0\, flags=128) at toke.c:10759 10759 const I32 oldsavestack_ix = PL_savestack_ix; (gdb) up

Breakpoint 3\, Perl_Slab_Alloc (sz=24) at op.c:331 331 if (!PL_compcv || CvROOT(PL_compcv) (gdb) bt #0 Perl_Slab_Alloc (sz=24) at op.c:331 #1 0x0001a167 in Perl_newSVOP (type=5\, flags=0\, sv=0x8222f0) at op.c:4847 #2 0x000560d5 in S_scan_const (start=0x305840 "(?#(?{)") at toke.c:3578

Ah\, *that* const op ;-) Somehow I missed triggering an op alloc breakpoint when I tried it earlier.

In which case\, as regards my code\, yuck! That "we guessed we had a code block but it turns out we didn't" bit of code was always a bit of hack\, and now that I realise it leaves an op allocated in the wrong CV\, I like it even less.

I'm tempted to eliminate it altogether. Would doing this enable you to simplify the slab code?

No\, because I still have to take SAVEFREEOP into account. :-) I could fiddle to get savestack items the right order\, but what I have currently is far more robust than the alternative.

The three things I didn’t have working with my earlier (non-refcounted) system were: • smartmatch • SAVEFREEOP - I just made it a no-op to get tests passing\, which leaked ops when there were no errors • re-evals

smartmatch is solved by using malloc.

SAVEFREEOP is solved using the refcounting system. That solves re-evals ‘for free’\, except for the one cv_forget_slab call in pmruntime.

--

Father Chrysostomos

p5pRT commented 12 years ago

From @cpansprout

On Sat Jun 23 16:32:20 2012\, sprout wrote:

On Fri Jun 22 18:31:51 2012\, sprout wrote:

On Wed Apr 25 03:38:30 2012\, davem wrote:

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

You mean something like this attachment?

I’ve broken it into a few commits and pushed it to the smoke-me/slop branch. It still contains a megapatch though\, because most of it is interdependent.

After two weeks writing the initial patch and another week tweaking and testing it\, I’ve finally merged it as c5fb998.

I just had another look at 8be227ab5e\, which is the main part of it\, and I think that’s the longest commit message I’ve written!

It’s probably also my greenest patch.

--

Father Chrysostomos

p5pRT commented 12 years ago

From [Unknown Contact. See original ticket]

On Sat Jun 23 16:32:20 2012\, sprout wrote:

On Fri Jun 22 18:31:51 2012\, sprout wrote:

On Wed Apr 25 03:38:30 2012\, davem wrote:

I think another suggestion that was mooted a while ago would be to allocate OPs from a pool or slab\, with a new pool/slab started each time we start compiling a new sub\, and the pool in some way marked as complete at the end of compiling the sub. On croaking\, all the OPs in the unfinished pools are freed. That way most code doesn't need to be modified.

You mean something like this attachment?

I’ve broken it into a few commits and pushed it to the smoke-me/slop branch. It still contains a megapatch though\, because most of it is interdependent.

After two weeks writing the initial patch and another week tweaking and testing it\, I’ve finally merged it as c5fb998.

I just had another look at 8be227ab5e\, which is the main part of it\, and I think that’s the longest commit message I’ve written!

It’s probably also my greenest patch.

--

Father Chrysostomos

p5pRT commented 12 years ago

@cpansprout - Status changed from 'open' to 'resolved'

p5pRT commented 12 years ago

From @cpansprout

On Mon Jun 25 14:50:38 2012\, sprout wrote:

On Mon Jun 25 14:41:06 2012\, davem wrote:

That "we guessed we had a code block but it turns out we didn't" bit of code was always a bit of hack\, and now that I realise it leaves an op allocated in the wrong CV\, I like it even less.

I'm tempted to eliminate it altogether. Would doing this enable you to simplify the slab code?

No\, because I still have to take SAVEFREEOP into account. :-) I could fiddle to get savestack items the right order\, but what I have currently is far more robust than the alternative.

The three things I didn’t have working with my earlier (non-refcounted) system were: • smartmatch • SAVEFREEOP - I just made it a no-op to get tests passing\, which leaked ops when there were no errors • re-evals

Attached is an early diff containing the alternative mentioned above\, which I am attaching here for posterity.

This was before the re-eval rewrite was merged\, before newSTUB\, and before I had thought of the CVf_SLABBED flag. The corresponding workarounds are a twisted maze. The only advantage was that freeing a slab was faster\, but probably less robust\, in that some ops might not be cleared and no check was done.

--

Father Chrysostomos

p5pRT commented 12 years ago

From @cpansprout

Inline Patch

```diff diff --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. #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 () { 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; ```

p5pRT commented 12 years ago

From [Unknown Contact. See original ticket]

On Mon Jun 25 14:50:38 2012\, sprout wrote:

On Mon Jun 25 14:41:06 2012\, davem wrote:

That "we guessed we had a code block but it turns out we didn't" bit of code was always a bit of hack\, and now that I realise it leaves an op allocated in the wrong CV\, I like it even less.

I'm tempted to eliminate it altogether. Would doing this enable you to simplify the slab code?

No\, because I still have to take SAVEFREEOP into account. :-) I could fiddle to get savestack items the right order\, but what I have currently is far more robust than the alternative.

The three things I didn’t have working with my earlier (non-refcounted) system were: • smartmatch • SAVEFREEOP - I just made it a no-op to get tests passing\, which leaked ops when there were no errors • re-evals

Attached is an early diff containing the alternative mentioned above\, which I am attaching here for posterity.

This was before the re-eval rewrite was merged\, before newSTUB\, and before I had thought of the CVf_SLABBED flag. The corresponding workarounds are a twisted maze. The only advantage was that freeing a slab was faster\, but probably less robust\, in that some ops might not be cleared and no check was done.

--

Father Chrysostomos

Perl / perl5