benchmark/accessors

   1 BEGIN {
   2   my @missing;
   3   for (qw/
   4     strictures
   5     Class::Accessor::Grouped
   6     Class::XSAccessor
   7     Class::Accessor::Fast
   8     Class::Accessor::Fast::XS
   9     Class::XSAccessor::Compat
  10     Moose
  11     Mouse
  12     Mousse
  13     Moo
  14     Dumbbench
  15   /) {
  16     eval "require $_" or push @missing, $_;
  17   }
  18
  19   if (@missing) {
  20     die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
  21       join ("\n", @missing);
  22   }
  23 }
  24
  25
  26 use strictures 1;
  27 use Benchmark::Dumb ':all';
  28
  29 {
  30   package Bench::Accessor::GrandParent;
  31   use strictures 1;
  32
  33   use base 'Class::Accessor::Grouped';
  34   __PACKAGE__->mk_group_accessors ('inherited', 'cag_inhp');
  35   __PACKAGE__->cag_inhp('initial parent value');
  36
  37   package Bench::Accessor::Parent;
  38   use strictures 1;
  39   use base 'Bench::Accessor::GrandParent';
  40
  41   package Bench::Accessor;
  42
  43   use strictures 1;
  44
  45   our @ISA;
  46
  47   use base qw/Bench::Accessor::Parent Class::Accessor::Grouped Class::Accessor::Fast/;
  48   use Class::XSAccessor { accessors => [ 'xsa' ] };
  49
  50   {
  51     local $Class::Accessor::Grouped::USE_XS = 0;
  52     __PACKAGE__->mk_group_accessors ('simple', 'cag');
  53   }
  54   {
  55     local $Class::Accessor::Grouped::USE_XS = 1;
  56     __PACKAGE__->mk_group_accessors ('simple', 'cag_xs');
  57   }
  58
  59   __PACKAGE__->mk_group_accessors ('inherited', 'cag_inh');
  60   __PACKAGE__->cag_inh('initial value');
  61
  62   __PACKAGE__->mk_accessors('caf');
  63
  64   {
  65     require Class::Accessor::Fast::XS;
  66     local @ISA = 'Class::Accessor::Fast::XS';
  67     __PACKAGE__->mk_accessors ('caf_xs');
  68   }
  69
  70   {
  71     require Class::XSAccessor::Compat;
  72     local @ISA = 'Class::XSAccessor::Compat';
  73     __PACKAGE__->mk_accessors ('caf_xsa');
  74   }
  75
  76   sub handmade {
  77     no warnings;
  78     no strict;
  79     @_ > 1 ? $_[0]->{handmade} = $_[1] : $_[0]->{handmade};
  80   }
  81
  82 }
  83 my $bench_objs = {
  84   base => bless ({}, 'Bench::Accessor')
  85 };
  86
  87 sub _add_moose_task {
  88   my ($tasks, $name, $class) = @_;
  89   my $meth = lc($name);
  90
  91   my $gen_class = "Bench::Accessor::$class";
  92   eval <<"EOC";
  93 package $gen_class;
  94 use $class;
  95 has $meth => (is => 'rw');
  96 # some moosey thingies can not do this
  97 eval { __PACKAGE__->meta->make_immutable };
  98 EOC
  99
 100   $bench_objs->{$name} = $gen_class->new;
 101   _add_task ($tasks, $name, $meth, $name);
 102 }
 103
 104 sub _add_task {
 105   my ($tasks, $name, $meth, $slot) = @_;
 106
 107   # we precompile the desired amount of loops so that the loop itself
 108   # does not get in the way with some sort of optimization or whatnot
 109
 110   use Devel::Dwarn;
 111 #  Dwarn { $meth => $bench_objs->{$slot}->can($meth) };
 112
 113   my $perl;
 114   for (1 .. 100) {
 115     $perl .= "
 116       \$::init_val = \$bench_objs->{$slot}->$meth;
 117       \$bench_objs->{$slot}->$meth($_);
 118       \$bench_objs->{$slot}->$meth(\$bench_objs->{$slot}->$meth + $_);
 119       \$bench_objs->{$slot}->$meth(undef);
 120     ";
 121   }
 122
 123   $tasks->{$name} = eval "sub { use warnings; use strict; $perl } " or die $@;
 124
 125   # prime things up (have the task run a couple times)
 126   $tasks->{$name}->() for (1..5);
 127 }
 128
 129 my $tasks = {
 130 #  'direct' => sub {
 131 #    $bench_objs->{base}{direct} = 1;
 132 #    $bench_objs->{base}{direct} = $bench_objs->{base}{direct} + 1;
 133 #  }
 134 };
 135
 136 for (qw/CAG CAG_XS CAG_INH CAG_INHP CAF CAF_XS CAF_XSA XSA HANDMADE/) {
 137   _add_task ($tasks, $_, lc($_), 'base');
 138 }
 139
 140 my $moose_based = {
 141   moOse => 'Moose',
 142   moo_XS => 'Moo',
 143   moUse_XS => 'Mouse',
 144   moUse => 'Mousse',
 145 };
 146 for (keys %$moose_based) {
 147   _add_moose_task ($tasks, $_, $moose_based->{$_})
 148 }
 149
 150 {
 151   no warnings 'once';
 152   local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
 153   _add_moose_task ($tasks, moo => 'Moo');
 154 }
 155
 156 #delete $tasks->{$_} for grep { $_ !~ /CAG/ } keys %$tasks;
 157
 158 for (1 .. 3) {
 159   print "Perl $], take $_:\n";
 160 #  DB::enable_profile();
 161   cmpthese ( '50.0001', $tasks );
 162 #  DB::disable_profile();
 163   print "\n";
 164 }