From: gfx <gfuji@cpan.org>
Date: Sun, 30 Aug 2009 06:19:07 +0000 (+0900)
Subject: Add benchmark scripts (bench/xs/*.pl)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=027b542f266cb73036d83acf4be3baa1378ee2ae;p=gitmo%2FClass-MOP.git

Add benchmark scripts (bench/xs/*.pl)
---

diff --git a/bench/xs/accessor.pl b/bench/xs/accessor.pl
new file mode 100755
index 0000000..9d14c33
--- /dev/null
+++ b/bench/xs/accessor.pl
@@ -0,0 +1,183 @@
+#!perl
+# with "Class-MOP/topic/unified-method-generation-w-xs" and" Moose/topic/xs-accessor"
+use strict;
+use Benchmark qw(:all);
+use Config; printf "Perl/%vd in $Config{archname}\n\n", $^V;
+use warnings;
+no warnings 'once';
+
+my $cxsa_is_loaded = eval q{
+    package CXSA;
+    use Class::XSAccessor
+        constructor => 'new',
+        accessors   => {
+            simple => 'simple',
+        },
+    ;
+    1;
+};
+my $mouse_is_loaded = eval q{
+	package MousePlain;
+	use Mouse;
+	has simple => (
+		is => 'rw',
+	);
+	__PACKAGE__->meta->make_immutable;
+};
+{
+	package My::Meta::Instance;
+	use parent qw(Moose::Meta::Instance);
+	sub can_xs{ 0 }
+
+	package MoosePlain;
+	use Moose;
+	__PACKAGE__->meta->{instance_metaclass} = 'My::Meta::Instance';
+	has simple => (
+		is => 'rw',
+	);
+	has with_lazy => (
+	    is      => 'rw',
+	    lazy    => 1,
+	    default => 42,
+	);
+	has with_tc => (
+	    is  => 'rw',
+	    isa => 'Num',
+	);
+	__PACKAGE__->meta->make_immutable;
+}
+{
+	package MooseXS;
+	use Moose;
+	has simple => (
+		is => 'rw',
+	);
+	has with_lazy => (
+	    is      => 'rw',
+	    lazy    => 1,
+	    default => 42,
+	);
+	has with_tc => (
+	    is  => 'rw',
+	    isa => 'Num',
+	);
+	__PACKAGE__->meta->make_immutable;
+}
+
+use B qw(svref_2object);
+
+print "Moose/$Moose::VERSION (Class::MOP/$Class::MOP::VERSION)\n";
+print "Mouse/$Mouse::VERSION\n" if $mouse_is_loaded;
+print "Class::XSAccessor/$Class::XSAccessor::VERSION\n" if $cxsa_is_loaded;
+
+sub method_type{
+	my($class) = @_;
+	return svref_2object($class->can('simple'))->XSUB    ? 'XS'
+	     : $class->meta->get_method('simple')->is_inline ? 'Inline'
+	                                                     : 'Basic';
+}
+
+print 'MoosePlain: ', method_type('MoosePlain'), "\n";
+print 'MooseXS:    ', method_type('MooseXS'),    "\n";
+
+my $mi = MoosePlain->new();
+my $mx = MooseXS->new();
+my $mu;
+$mu = MousePlain->new if $mouse_is_loaded;
+my $cx;
+$cx = CXSA->new       if $cxsa_is_loaded;
+
+
+print "\nGETTING for simple attributes\n";
+cmpthese -1 => {
+	'Moose/Plain' => sub{
+		my $x;
+		$x = $mi->simple();
+		$x = $mi->simple();
+	},
+	'Moose/XS' => sub{
+		my $x;
+		$x = $mx->simple();
+		$x = $mx->simple();
+	},
+	$mouse_is_loaded ? (
+	'Mouse' => sub{
+		my $x;
+		$x = $mu->simple();
+		$x = $mu->simple();
+	},
+	) : (),
+	$cxsa_is_loaded ? (
+	'C::XSAccessor' => sub{
+		my $x;
+		$x = $cx->simple();
+		$x = $cx->simple();
+	},
+	) : (),
+};
+
+print "\nSETTING for simple attributes\n";
+cmpthese -1 => {
+	'Moose/Plain' => sub{
+		$mi->simple(10);
+		$mi->simple(10);
+	},
+	'Moose/XS' => sub{
+		$mx->simple(10);
+		$mx->simple(10);
+	},
+
+	$mouse_is_loaded ? (
+	'Mouse' => sub{
+		$mu->simple(10);
+		$mu->simple(10);
+	},
+	) : (),
+	$cxsa_is_loaded ? (
+	'C::XSAccessor' => sub{
+		$cx->simple(10);
+		$cx->simple(10);
+	},
+	) : (),
+
+};
+
+print "\nGETTING for lazy attributes (except for C::XSAccessor)\n";
+cmpthese -1 => {
+	'Moose/Plain' => sub{
+		my $x;
+		$x = $mi->with_lazy();
+		$x = $mi->with_lazy();
+	},
+	'Moose/XS' => sub{
+		my $x;
+		$x = $mx->with_lazy();
+		$x = $mx->with_lazy();
+	},
+	$cxsa_is_loaded ? (
+	'C::XSAccessor' => sub{
+		my $x;
+		$x = $cx->simple();
+		$x = $cx->simple();
+	},
+	) : (),
+};
+
+print "\nSETTING for attributes with type constraints (except for C::XSAccessor)\n";
+cmpthese -1 => {
+	'Moose/Plain' => sub{
+		$mi->with_tc(10);
+		$mi->with_tc(10);
+	},
+	'Moose/XS' => sub{
+		$mx->with_tc(10);
+		$mx->with_tc(10);
+	},
+	$cxsa_is_loaded ? (
+	'C::XSAccessor' => sub{
+		$cx->simple(10);
+		$cx->simple(10);
+	},
+	) : (),
+};
+
diff --git a/bench/xs/class-definition.pl b/bench/xs/class-definition.pl
new file mode 100755
index 0000000..a3a9314
--- /dev/null
+++ b/bench/xs/class-definition.pl
@@ -0,0 +1,87 @@
+#!perl
+# with "Class-MOP/topic/unified-method-generation-w-xs" and" Moose/topic/xs-accessor"
+use strict;
+use Benchmark qw(:all);
+use Config; printf "Perl/%vd in $Config{archname}\n\n", $^V;
+use warnings;
+no warnings 'once';
+
+my $mouse_is_loaded = eval { require Mouse };
+
+{
+	package My::Meta::Instance;
+	use parent qw(Moose::Meta::Instance);
+	sub can_xs{ 0 }
+}
+
+print "Class definition\n";
+my $i = 0;
+my $j = 0;
+my $k = 0;
+
+cmpthese 40 => {
+	'Moose/Plain' => sub{
+		$i++;
+		my $src = '';
+		for my $c(qw(A B C D E F G H I J)){
+			$src .= qq{{
+				package MI_$c$i;
+				use Moose;
+				my \$meta = __PACKAGE__->meta;
+				\$meta->{instance_metaclass} = 'My::Meta::Instance';
+
+				has attr1 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr2 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr3 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr4 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr5 => (is => 'rw', isa => 'Int', lazy_build => 1);
+
+				\$meta->make_immutable();
+			}};
+		}
+		eval $src or die $@;
+	},
+	'Moose/XS' => sub{
+		$j++;
+		my $src = '';
+		for my $c(qw(A B C D E F G H I J)){
+			$src .= qq{{
+				package MX_$c$j;
+				use Moose;
+				my \$meta = __PACKAGE__->meta;
+				#\$meta->{instance_metaclass} = 'My::Meta::Instance';
+
+				has attr1 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr2 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr3 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr4 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr5 => (is => 'rw', isa => 'Int', lazy_build => 1);
+
+				\$meta->make_immutable();
+			}};
+		}
+		eval $src or die $@;
+	},
+	$mouse_is_loaded ? (
+	'Mouse' => sub{
+		$k++;
+		my $src = '';
+		for my $c(qw(A B C D E F G H I J)){
+			$src .= qq{{
+				package MU_$c$k;
+				use Mouse;
+				my \$meta = __PACKAGE__->meta;
+				\$meta->{instance_metaclass} = 'My::Meta::Instance';
+
+				has attr1 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr2 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr3 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr4 => (is => 'rw', isa => 'Int', lazy_build => 1);
+				has attr5 => (is => 'rw', isa => 'Int', lazy_build => 1);
+
+				\$meta->make_immutable();
+			}};
+		}
+		eval $src or die $@;
+	}) : (),
+};
diff --git a/bench/xs/constructor.pl b/bench/xs/constructor.pl
new file mode 100755
index 0000000..65c566c
--- /dev/null
+++ b/bench/xs/constructor.pl
@@ -0,0 +1,77 @@
+#!perl -w
+use strict;
+use Config; printf "Perl/%vd in $Config{archname}\n\n", $^V;
+use Benchmark qw(:all);
+
+{
+	package MOP_Plain;
+	use metaclass;
+
+    __PACKAGE__->meta->add_attribute('foo' => (
+        reader  => 'foo',
+        default => 'FOO',
+    ));
+    __PACKAGE__->meta->add_attribute('bar' => (
+        reader  => 'bar',
+        default => 'BAR',
+    ));
+    __PACKAGE__->meta->add_attribute('baz' => (
+        reader  => 'baz',
+        default => 'BAZ',
+    ));
+    __PACKAGE__->meta->add_attribute('bax' => (
+        reader  => 'bax',
+        default => 'BAX',
+    ));
+
+	no warnings 'redefine';
+	local *Class::MOP::Instance::can_xs = sub{ 0 };
+	__PACKAGE__->meta->make_immutable;
+}
+{
+	package MOP_XS;
+	use metaclass;
+
+    __PACKAGE__->meta->add_attribute('foo' => (
+        reader  => 'foo',
+        default => 'FOO',
+    ));
+    __PACKAGE__->meta->add_attribute('bar' => (
+        reader  => 'bar',
+        default => 'BAR',
+    ));
+    __PACKAGE__->meta->add_attribute('baz' => (
+        reader  => 'baz',
+        default => 'BAZ',
+    ));
+    __PACKAGE__->meta->add_attribute('bax' => (
+        reader  => 'bax',
+        default => 'BAX',
+    ));
+
+	__PACKAGE__->meta->make_immutable;
+}
+
+# prepre caches
+MOP_Plain->new;
+MOP_XS->new;
+
+print "MOP constructor (default)\n";
+cmpthese -1 => {
+	'Plain' => sub{
+		my $x = MOP_Plain->new();
+	},
+	'XS'    => sub{
+		my $x = MOP_XS->new();
+	},
+};
+
+print "MOP constructor (non-default)\n";
+cmpthese -1 => {
+	'Plain' => sub{
+		my $x = MOP_Plain->new(foo => 'FOO', bar => 'BAR', baz => 'BAZ');
+	},
+	'XS'    => sub{
+		my $x = MOP_XS->new(foo => 'FOO', bar => 'BAR', baz => 'BAZ');
+	},
+};
diff --git a/bench/xs/loading.pl b/bench/xs/loading.pl
new file mode 100755
index 0000000..3475e58
--- /dev/null
+++ b/bench/xs/loading.pl
@@ -0,0 +1,35 @@
+#!perl -w
+use strict;
+use warnings;
+
+use Benchmark qw(:all);
+use Config; printf "Perl/%vd on $Config{archname}\n\n", $^V;
+
+my $n      = shift || 20;
+
+for my $module (qw(Moose KiokuDB HTTP::Engine Catalyst)){
+    print "For $module\n";
+    my $plain = <<"END";
+    sub Moose::Meta::Instance::can_xs{ 0 }
+    require Moose; # prefer Moose
+    require $module;
+END
+
+    my $xs = <<"END";
+    sub Moose::Meta::Instance::foo{ 0 } # dummy
+    require Moose; # prefer Moose
+    require $module;
+END
+
+    system(qq{$^X -e '$plain'}) == 0 or die $?;
+    system(qq{$^X -e '$xs'})    == 0 or die $?;
+
+    cmpthese  $n => {
+        'Moose/Plain' => sub{
+            system(qq{$^X -we '$plain'}) == 0 or die $!;
+        },
+        'Moose/XS' =>sub{
+            system(qq{$^X -we '$xs'}) == 0 or die $!;
+        },
+    };
+}