compare_sort_defs.pl

package Sorter;

use strict;
use warnings;

my @chromosome = (1..22, 'X', 'Y', 'MT');

# don't leave it up to humans unless you need to!
sub index_of {
    my $i = 0;
    return map { $_ => $i++ } @_;
}

my %index = index_of(@chromosome);

# uses function prototype to avoid using the "magic" $a/$b vars
sub by_chromosome_proto($$) {
    return ($index{$_[0]} <=> $index{$_[1]});
}

# uses fully qualified variable names to get a/b from calling package
sub by_chromosome_reflect {
		# Improvements by abrummet:
		#   - Avoid indexing into result of caller by calling in scaler context.
		#   - Avoid string interpolation of $an by dereferencing instead.
    my $caller_package = caller;
    my ($an, $bn) = map { join('::', $caller_package, $_) } qw(a b);
	no strict 'refs';
    return ($index{$$an} <=> $index{$$bn});
}

# create a closure to "cache" calculation of fully qualified a/b, by abrummet
sub by_chromosome_closure {
    my $caller_package = caller;
    my ($an, $bn) = map { join('::', $caller_package, $_) } qw(a b);
	no strict 'refs';
    return sub {
        return $index{$$an} <=> $index{$$bn};
    }
}

package main;

use strict;
use warnings;

use Benchmark qw(cmpthese :hireswallclock);
use Test::More tests => 3;

my @input = qw(2 4 6 X 1 3 5);
my @expected = qw(1 2 3 4 5 6 X);

my $by_chromosome_closure = Sorter::by_chromosome_closure();

is_deeply([sort Sorter::by_chromosome_proto @input],   \@expected, 'by_chromosome_proto worked');
is_deeply([sort Sorter::by_chromosome_reflect @input], \@expected, 'by_chromosome_reflect worked');
is_deeply([sort $by_chromosome_closure @input],        \@expected, 'by_chromosome_export worked');

cmpthese(-3, {
    proto   => sub { sort Sorter::by_chromosome_proto @input },
    reflect => sub { sort Sorter::by_chromosome_reflect @input },
    scalar_caller_deref_closure => sub { sort $by_chromosome_closure  @input },
});

Revision 5 output:

1..5
not ok 1 - by_chromosome worked
#   Failed test 'by_chromosome worked'
#   at Untitled.pl line 64.
#     Structures begin differing at:
#          $got->[0] = '2'
#     $expected->[0] = '1'
ok 2 - by_chromosome_proto worked
ok 3 - by_chromosome_reflect worked
not ok 4 - by_chromosome_export worked
#   Failed test 'by_chromosome_export worked'
#   at Untitled.pl line 67.
#     Structures begin differing at:
#          $got->[0] = '2'
#     $expected->[0] = '1'
ok 5 - by_chromosome_native worked
                            Rate by_chromosome_proto by_chromosome_reflect by_chromosome_native
by_chromosome_proto   13919150/s                  --                   -6%                  -6%
by_chromosome_reflect 14822160/s                  6%                    --                  -0%
by_chromosome_native  14838340/s                  7%                    0%                   --
# Looks like you failed 2 tests of 5.

Revision 6 introduced the several improvement to by_chromosome_reflect and added by_chromosome_closure thanks to abrummet. I think I would just default to using the prototyped function and if performance was critical I would need to look into XS as well.

Revision 6 output:

1..3
ok 1 - by_chromosome_proto worked
ok 2 - by_chromosome_reflect worked
ok 3 - by_chromosome_export worked
                                  Rate scalar_caller_deref_closure proto reflect
scalar_caller_deref_closure 14224575/s                          --   -1%     -4%
proto                       14374025/s                          1%    --     -3%
reflect                     14753962/s                          4%    3%      --