This queue is for tickets about the Class-Accessor-Grouped CPAN distribution.

Report information
The Basics
Id:
45577
Status:
resolved
Priority:
Low/Low

People
Owner:
claco [...] cpan.org (email delivery suspended)
Requestors:
AGRUNDMA [...] cpan.org
Cc:
AdminCc:

BugTracker
Severity:
Normal
Broken in:
(no value)
Fixed in:
(no value)



Subject: [PATCH] Use Class::XSAccessor for simple accessors
Hi guys, get/set_simple are the most-used methods in DBIC and always show up at the top of my profiles. This little patch uses Class::XSAccessor for them if available, which is quite a bit faster: Rate cag_get cag_set xs_set xs_get cag_get 602746/s -- -1% -57% -71% cag_set 607293/s 1% -- -56% -71% xs_set 1385965/s 130% 128% -- -34% xs_get 2095760/s 248% 245% 51% -- Note I had to use a non-public method, since the only public way to create accessors with XSAccessor appears to be via import().
Subject: accbench.pl
#!/usr/local/bin/perl package PP; use base 'Class::Accessor::Grouped'; PP->mk_group_accessors( simple => 'foo' ); sub new { bless {}, shift; } package XS; use Class::XSAccessor; Class::XSAccessor::newxs_accessor( 'XS::foo', 'foo', 0 ); sub new { bless {}, shift; } package main; use strict; use Benchmark qw(cmpthese); my $pp = PP->new; my $xs = XS->new; cmpthese( -5, { cag_set => sub { $pp->foo('set'); }, cag_get => sub { my $x = $pp->foo(); }, xs_set => sub { $xs->foo('set'); }, xs_get => sub { my $x = $xs->foo(); }, } );
Subject: cag-xs-accessor.patch
=== CPAN/Class/Accessor/Grouped.pm ================================================================== --- CPAN/Class/Accessor/Grouped.pm (revision 54335) +++ CPAN/Class/Accessor/Grouped.pm (local) @@ -8,6 +8,22 @@ our $VERSION = '0.08003'; +BEGIN { + my $hasXS; + + sub hasXS { + return $hasXS if defined $hasXS; + + $hasXS = 0; + eval { + require Class::XSAccessor; + $hasXS = 1; + }; + + return $hasXS; + } +} + =head1 NAME Class::Accessor::Grouped - Lets you build groups of accessors @@ -64,6 +80,8 @@ # So we don't have to do lots of lookups inside the loop. $maker = $self->can($maker) unless ref $maker; + + my $hasXS = hasXS(); foreach my $field (@fields) { if( $field eq 'DESTROY' ) { @@ -74,15 +92,20 @@ my $name = $field; ($name, $field) = @$field if ref $field; + + if ( $hasXS && $group eq 'simple' ) { + Class::XSAccessor::newxs_accessor("${class}::${name}", $field, 0); + } + else { + my $accessor = $self->$maker($group, $field); + my $alias = "_${name}_accessor"; - my $accessor = $self->$maker($group, $field); - my $alias = "_${name}_accessor"; + *{$class."\:\:$name"} = $accessor; + #unless defined &{$class."\:\:$field"} - *{$class."\:\:$name"} = $accessor; - #unless defined &{$class."\:\:$field"} - - *{$class."\:\:$alias"} = $accessor; - #unless defined &{$class."\:\:$alias"} + *{$class."\:\:$alias"} = $accessor; + #unless defined &{$class."\:\:$alias"} + } } } }
Subject: Re: [rt.cpan.org #45577] [PATCH] Use Class::XSAccessor for simple accessors
Date: Thu, 30 Apr 2009 08:47:14 -0400
To: bug-Class-Accessor-Grouped@rt.cpan.org
From: "Christopher H. Laco" <claco@chrislaco.com>
AGRUNDMA via RT wrote:
Show quoted text
> Wed Apr 29 22:59:35 2009: Request 45577 was acted upon. > Transaction: Ticket created by AGRUNDMA > Queue: Class-Accessor-Grouped > Subject: [PATCH] Use Class::XSAccessor for simple accessors > Broken in: (no value) > Severity: Normal > Owner: Nobody > Requestors: AGRUNDMA@cpan.org > Status: new > Ticket <URL: https://rt.cpan.org/Ticket/Display.html?id=45577 > > > > Hi guys, > > get/set_simple are the most-used methods in DBIC and always show up at > the top of my profiles. This little patch uses Class::XSAccessor for > them if available, which is quite a bit faster: > > Rate cag_get cag_set xs_set xs_get > cag_get 602746/s -- -1% -57% -71% > cag_set 607293/s 1% -- -56% -71% > xs_set 1385965/s 130% 128% -- -34% > xs_get 2095760/s 248% 245% 51% -- > > Note I had to use a non-public method, since the only public way to > create accessors with XSAccessor appears to be via import().
Bravo. I had thought of this when I was doing the round of speedups for the 5.10. @_ assignment issues. MSTROUT, thoughts? Just for giggles, have you run the DBIC test suit before and after this patch? I'd be curious to see what effect it has had. -=Chris
On Thu Apr 30 08:47:42 2009, claco@chrislaco.com wrote:
Show quoted text
> Just for giggles, have you run the DBIC test suit before and after this > patch? I'd be curious to see what effect it has had.
Yep, fully passing.
Subject: Re: [rt.cpan.org #45577] [PATCH] Use Class::XSAccessor for simple accessors
Date: Thu, 30 Apr 2009 09:44:51 -0400
To: bug-Class-Accessor-Grouped@rt.cpan.org
From: "Christopher H. Laco" <claco@chrislaco.com>
AGRUNDMA via RT wrote:
Show quoted text
> Queue: Class-Accessor-Grouped > Ticket <URL: https://rt.cpan.org/Ticket/Display.html?id=45577 > > > On Thu Apr 30 08:47:42 2009, claco@chrislaco.com wrote:
>> Just for giggles, have you run the DBIC test suit before and after this >> patch? I'd be curious to see what effect it has had.
> > Yep, fully passing.
I figured it would. :-) Did it seem any faster?
On Thu Apr 30 09:45:30 2009, claco@chrislaco.com wrote:
Show quoted text
> AGRUNDMA via RT wrote:
> > Queue: Class-Accessor-Grouped > > Ticket <URL: https://rt.cpan.org/Ticket/Display.html?id=45577 > > > > > On Thu Apr 30 08:47:42 2009, claco@chrislaco.com wrote:
> >> Just for giggles, have you run the DBIC test suit before and after this > >> patch? I'd be curious to see what effect it has had.
> > > > Yep, fully passing.
> > I figured it would. :-) Did it seem any faster?
Hard to say, I would guess so. :)
Looks like this patch is against the latest cpan release. I just noticed there are some changes in trunk from March for Sub::Names for Moose. Could you rwork this patch against trunk just to be safe? http://dev.catalystframework.org/repos/bast/trunk/Class-Accessor-Grouped Thanks, -=Chris
Here's a better patch against svn with a test. I can check it in if you want. CAG is near the top of my profiles even still, with get_inherited being the major issue. The whole module should probably get an XS makeover.
Index: t/accessors.t =================================================================== --- t/accessors.t (revision 6943) +++ t/accessors.t (working copy) @@ -2,9 +2,15 @@ use strict; use warnings; use lib 't/lib'; -use AccessorGroups; use Sub::Identify qw/sub_name sub_fullname/;; +BEGIN { + # Disable XSAccessor to test pure-Perl accessors + $Class::Accessor::Grouped::hasXS = 0; + + require AccessorGroups; +} + my $class = AccessorGroups->new; { @@ -90,3 +96,6 @@ # alias gets same as name is($class->$name, 'd'); }; + +1; + Index: t/accessors_xs.t =================================================================== --- t/accessors_xs.t (revision 6784) +++ t/accessors_xs.t (working copy) @@ -1,92 +1,17 @@ -use Test::More tests => 62; use strict; -use warnings; +use FindBin qw($Bin); +use File::Spec::Functions; +use Test::More; use lib 't/lib'; -use AccessorGroups; -use Sub::Identify qw/sub_name sub_fullname/;; -my $class = AccessorGroups->new; - -{ - my $warned = 0; - - local $SIG{__WARN__} = sub { - if (shift =~ /DESTROY/i) { - $warned++; - }; - }; - - $class->mk_group_accessors('warnings', 'DESTROY'); - - ok($warned); - - # restore non-accessorized DESTROY - no warnings; - *AccessorGroups::DESTROY = sub {}; -}; - -{ - my $class_name = ref $class; - my $name = 'multiple1'; - my $alias = "_${name}_accessor"; - my $accessor = $class->can($name); - my $alias_accessor = $class->can($alias); - isnt(sub_name($accessor), '__ANON__', 'accessor is named'); - isnt(sub_name($alias_accessor), '__ANON__', 'alias is named'); - is(sub_fullname($accessor), join('::',$class_name,$name), 'accessor FQ name'); - is(sub_fullname($alias_accessor), join('::',$class_name,$alias), 'alias FQ name'); +BEGIN { + # Enable XSAccessor check + $Class::Accessor::Grouped::hasXS = undef; + + require AccessorGroups; } -foreach (qw/singlefield multiple1 multiple2/) { - my $name = $_; - my $alias = "_${name}_accessor"; +plan skip_all => 'Class::XSAccessor not available' + unless Class::Accessor::Grouped::_hasXS(); - can_ok($class, $name, $alias); - - is($class->$name, undef); - is($class->$alias, undef); - - # get/set via name - is($class->$name('a'), 'a'); - is($class->$name, 'a'); - is($class->{$name}, 'a'); - - # alias gets same as name - is($class->$alias, 'a'); - - # get/set via alias - is($class->$alias('b'), 'b'); - is($class->$alias, 'b'); - is($class->{$name}, 'b'); - - # alias gets same as name - is($class->$name, 'b'); -}; - -foreach (qw/lr1 lr2/) { - my $name = "$_".'name'; - my $alias = "_${name}_accessor"; - my $field = "$_".'field'; - - can_ok($class, $name, $alias); - ok(!$class->can($field)); - - is($class->$name, undef); - is($class->$alias, undef); - - # get/set via name - is($class->$name('c'), 'c'); - is($class->$name, 'c'); - is($class->{$field}, 'c'); - - # alias gets same as name - is($class->$alias, 'c'); - - # get/set via alias - is($class->$alias('d'), 'd'); - is($class->$alias, 'd'); - is($class->{$field}, 'd'); - - # alias gets same as name - is($class->$name, 'd'); -}; +require( catfile($Bin, 'accessors.t') ); Index: t/lib/AccessorGroups.pm =================================================================== --- t/lib/AccessorGroups.pm (revision 6943) +++ t/lib/AccessorGroups.pm (working copy) @@ -3,20 +3,13 @@ use warnings; use base 'Class::Accessor::Grouped'; -__PACKAGE__->mk_group_accessors('single', 'singlefield'); -__PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/); -__PACKAGE__->mk_group_accessors('listref', [qw/lr1name lr1field/], [qw/lr2name lr2field/]); +__PACKAGE__->mk_group_accessors('simple', 'singlefield'); +__PACKAGE__->mk_group_accessors('simple', qw/multiple1 multiple2/); +__PACKAGE__->mk_group_accessors('simple', [qw/lr1name lr1field/], [qw/lr2name lr2field/]); __PACKAGE__->mk_group_accessors('component_class', 'result_class'); sub new { return bless {}, shift; }; -foreach (qw/single multiple listref/) { - no strict 'refs'; - - *{"get_$_"} = \&Class::Accessor::Grouped::get_simple; - *{"set_$_"} = \&Class::Accessor::Grouped::set_simple; -}; - 1; Index: lib/Class/Accessor/Grouped.pm =================================================================== --- lib/Class/Accessor/Grouped.pm (revision 6943) +++ lib/Class/Accessor/Grouped.pm (working copy) @@ -9,6 +9,22 @@ our $VERSION = '0.08004'; +BEGIN { + our $hasXS; + + sub _hasXS { + return $hasXS if defined $hasXS; + + $hasXS = 0; + eval { + require Class::XSAccessor; + $hasXS = 1; + }; + + return $hasXS; + } +} + =head1 NAME Class::Accessor::Grouped - Lets you build groups of accessors @@ -65,6 +81,8 @@ # So we don't have to do lots of lookups inside the loop. $maker = $self->can($maker) unless ref $maker; + + my $hasXS = _hasXS(); foreach my $field (@fields) { if( $field eq 'DESTROY' ) { @@ -75,18 +93,27 @@ my $name = $field; ($name, $field) = @$field if ref $field; - - my $accessor = $self->$maker($group, $field); - my $alias_accessor = $self->$maker($group, $field); - + my $alias = "_${name}_accessor"; my $full_name = join('::', $class, $name); my $full_alias = join('::', $class, $alias); - - *$full_name = Sub::Name::subname($full_name, $accessor); - #unless defined &{$class."\:\:$field"} - *$full_alias = Sub::Name::subname($full_alias, $alias_accessor); - #unless defined &{$class."\:\:$alias"} + + if ( $hasXS && $group eq 'simple' ) { + Class::XSAccessor::newxs_accessor("${class}::${name}", $field, 0); + Class::XSAccessor::newxs_accessor("${class}::${alias}", $field, 0); + + # XXX: is the alias accessor really necessary? + } + else { + my $accessor = $self->$maker($group, $field); + my $alias_accessor = $self->$maker($group, $field); + + *$full_name = Sub::Name::subname($full_name, $accessor); + #unless defined &{$class."\:\:$field"} + + *$full_alias = Sub::Name::subname($full_alias, $alias_accessor); + #unless defined &{$class."\:\:$alias"} + } } } }
On Thu Jul 02 11:47:49 2009, AGRUNDMA wrote:
Show quoted text
> Here's a better patch against svn with a test. I can check it in if you > want. > > CAG is near the top of my profiles even still, with get_inherited being > the major issue. The whole module should probably get an XS makeover.
Whither the accessor_xs.t to apply this patch to? :-)
use strict; I can commit this, RT isn't that great for exchanging patches. use FindBin qw($Bin); use File::Spec::Functions; use Test::More; use lib 't/lib'; BEGIN { # Enable XSAccessor check $Class::Accessor::Grouped::hasXS = undef; require AccessorGroups; } plan skip_all => 'Class::XSAccessor not available' unless Class::Accessor::Grouped::_hasXS(); require( catfile($Bin, 'accessors.t') );
Applied to trunk and uploaded as Class-Accessor-Grouped-0.08999_01.tar.gz to CPAN to kick around for a bit.


This service runs on Request Tracker, is sponsored by The Perl Foundation, and maintained by Best Practical Solutions.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.