1#! /usr/bin/perl
2#
3# Copyright (C) 2007-2008 Tomash Brechko.  All rights reserved.
4#
5# This program is free software; you can redistribute it and/or modify
6# it under the same terms as Perl itself, either Perl version 5.8.8
7# or, at your option, any later version of Perl 5 you may have
8# available.
9#
10use warnings;
11use strict;
12
13
14# NOTE: at least on Linux (kernel 2.6.18.2) there is a certain
15# artifact that affects wallclock time (but not CPU time) of some
16# benchmarks: when send/receive rate changes dramatically, the system
17# doesn't adopt to it right away.  Instead, for some time a lot of
18# small-range ACK packets are being sent, and this increases the
19# latency.  Because of this '*_multi (%h)', which comes first, has
20# bigger wallclock time than '*_multi (@h)', which comes next.  I
21# tried pre-warming the connection, but this doesn't help in all
22# cases.  Seems like 'noreply' mode is also affected, and maybe
23# 'nowait'.
24
25
26use constant default_iteration_count => 1_000;
27use constant key_count => 100;
28use constant NOWAIT => 1;
29use constant NOREPLY => 1;
30
31my $value = 'x' x 40;
32
33
34use FindBin;
35
36@ARGV >= 1
37    or die("Usage: $FindBin::Script HOST:PORT... [COUNT] [\"compare\"]\n"
38           . "\n"
39           . "HOST:PORT...  - list of memcached server addresses.\n"
40           . "COUNT         - number of iterations (default "
41                              . default_iteration_count . ").\n"
42           . "                (each iteration will process "
43                              . key_count . " keys).\n"
44           . "\"compare\"     - literal string to enable comparison with\n"
45           . "                Cache::Memcached.\n");
46
47my $compare = ($ARGV[$#ARGV] =~ /^compare$/);
48pop @ARGV if $compare;
49
50my $count = ($ARGV[$#ARGV] =~ /^\d+$/ ? pop @ARGV : default_iteration_count);
51my $max_keys = $count * key_count / 2;
52
53my @addrs = @ARGV;
54
55use Cache::Memcached::Fast;
56use Benchmark qw(:hireswallclock timethese cmpthese timeit timesum timestr);
57
58my $old;
59my $old_method = qr/^(?:add|set|replace|incr|decr|delete|get)$/;
60my $old_method_multi = qr/^get$/;
61if ($compare) {
62    require Cache::Memcached;
63
64    $old = new Cache::Memcached {
65        servers   => [@addrs],
66        namespace => "Cache::Memcached::bench/$$/",
67        connect_timeout => 5,
68        select_timeout => 5,
69    };
70    $old->enable_compress(0);
71}
72
73
74my $new = new Cache::Memcached::Fast {
75    servers   => [@addrs],
76    namespace => "Cache::Memcached::bench/$$/",
77    ketama_points => 150,
78    nowait => NOWAIT,
79    connect_timeout => 5,
80    io_timeout => 5,
81};
82
83my $version = $new->server_versions;
84if (keys %$version != @addrs) {
85    my @servers = map {
86        if (ref($_) eq 'HASH') {
87            $_->{address};
88        } elsif (ref($_) eq 'ARRAY') {
89            $_->[0];
90        } else {
91            $_;
92        }
93    } @addrs;
94    warn "No server is running at "
95        . join(', ', grep { not exists $version->{$_} }
96               @servers)
97        . "\n";
98    exit 1;
99}
100
101my $min_version = 2 ** 31;
102while (my ($s, $v) = each %$version) {
103    if ($v =~ /(\d+)\.(\d+)\.(\d+)/) {
104        my $n = $1 * 10000 + $2 * 100 + $3;
105        $min_version = $n if $n < $min_version;
106    } else {
107        warn "Can't parse version of $s: $v";
108        exit 1;
109    }
110}
111
112my $noreply = NOREPLY && $min_version >= 10205;
113
114@addrs = map { +{ address => $_, noreply => $noreply } } @addrs;
115
116my $new_noreply = new Cache::Memcached::Fast {
117    servers   => [@addrs],
118    namespace => "Cache::Memcached::bench/$$/",
119    ketama_points => 150,
120    connect_timeout => 5,
121    io_timeout => 5,
122};
123
124
125sub get_key {
126    int(rand($max_keys));
127}
128
129
130sub merge_hash {
131    my ($h1, $h2) = @_;
132
133    while (my ($k, $v) = each %$h2) {
134        $h1->{$k} = $v;
135    }
136}
137
138
139sub bench_finalize {
140    my ($title, $code, $finalize) = @_;
141
142    print "Benchmark: timing $count iterations of $title...\n";
143    my $b1 = timeit($count, $code);
144
145    # We call nowait_push here.  Otherwise the time of gathering
146    # the results would be added to the following commands.
147    my $b2 = timeit(1, $finalize);
148
149    my $res = timesum($b1, $b2);
150    print "$title: ", timestr($res, 'auto'), "\n";
151
152    return { $title => $res };
153}
154
155
156sub run {
157    my ($method, $value, $cas) = @_;
158
159    my $params = sub {
160        my @params;
161        push @params, $_[0] . '-' . get_key();
162        push @params, 0 if $cas;
163        push @params, $value if defined $value;
164        return @params;
165    };
166
167    my $params_multi = sub {
168        my @res;
169        for (my $i = 0; $i < key_count; ++$i) {
170            my @params;
171            push @params, $_[0] . '-' . get_key();
172            if ($cas or defined $value) {
173                push @params, 0 if $cas;
174                push @params, $value if defined $value;
175                push @res, \@params;
176            } else {
177                push @res, @params;
178            }
179        }
180        return @res;
181    };
182
183    my @test = (
184        "$method" => sub { my $res = $new->$method(&$params('p$'))
185                             foreach (1..key_count) },
186    );
187
188    push @test, (
189        "old $method" => sub { my $res = $old->$method(&$params('o$'))
190                                 foreach (1..key_count) },
191    ) if defined $old and $method =~ /$old_method/o;
192
193    my $bench = timethese($count, {@test});
194
195    if (defined $value and $noreply) {
196        # We call get('no-such-key') here.  Otherwise the time of
197        # sending the requests might be added to the following
198        # commands.
199        my $res = bench_finalize("$method noreply",
200                                 sub { $new_noreply->$method(&$params('pr'))
201                                         foreach (1..key_count) },
202                                 sub { $new_noreply->get('no-such-key') });
203
204        merge_hash($bench, $res);
205
206        if (defined $old and $method =~ /$old_method/o) {
207            $res = bench_finalize("old $method noreply",
208                                  sub { $old->$method(&$params('or'))
209                                          foreach (1..key_count) },
210                                  sub { $old->get('no-such-key') });
211
212            merge_hash($bench, $res);
213        }
214    }
215
216    if (defined $value and NOWAIT) {
217        # We call nowait_push here.  Otherwise the time of gathering
218        # the results would be added to the following commands.
219        my $res = bench_finalize("$method nowait",
220                                 sub { $new->$method(&$params('pw'))
221                                         foreach (1..key_count) },
222                                 sub { $new->nowait_push });
223        merge_hash($bench, $res);
224    }
225
226    my $method_multi = "${method}_multi";
227    @test = (
228        "$method_multi" . (defined $value ? ' (%h)' : '')
229            => sub { my $res = $new->$method_multi(&$params_multi('m%')) },
230    );
231
232    # We use the same 'm%' prefix here as for the new module because
233    # old module doesn't have set_multi, and we want to retrieve
234    # something.
235    push @test, (
236        "old $method_multi"
237            => sub { my $res = $old->$method_multi(&$params_multi('m%')) },
238    ) if defined $old and $method =~ /$old_method_multi/o;
239
240    push @test, (
241        "$method_multi (\@a)"
242             => sub { my @res = $new->$method_multi(&$params_multi('m@')) },
243    ) if defined $value;
244
245    merge_hash($bench, timethese($count, {@test}));
246
247    if (defined $value and $noreply) {
248        # We call get('no-such-key') here.  Otherwise the time of
249        # sending the requests might be added to the following
250        # commands.
251        my $res = bench_finalize("$method_multi noreply",
252                                 sub { $new_noreply->
253                                         $method_multi(&$params_multi('mr')) },
254                                 sub { $new_noreply->get('no-such-key') });
255
256        merge_hash($bench, $res);
257    }
258
259    if (defined $value and NOWAIT) {
260        # We call nowait_push here.  Otherwise the time of gathering
261        # the results would be added to the following commands.
262        my $res = bench_finalize("$method_multi nowait",
263                                 sub {
264                                     $new->$method_multi(&$params_multi('mw'))
265                                 },
266                                 sub { $new->nowait_push });
267
268        merge_hash($bench, $res);
269    }
270
271    cmpthese($bench);
272}
273
274
275my @methods = (
276    [add        => \&run, $value],
277    [set        => \&run, $value],
278    [append     => \&run, $value],
279    [prepend    => \&run, $value],
280    [replace    => \&run, $value],
281    [cas        => \&run, $value, 'CAS'],
282    [get        => \&run],
283    [gets       => \&run],
284    [incr       => \&run, 1],
285    [decr       => \&run, 1],
286    [delete     => \&run, 0],
287);
288
289
290print "Servers: @{[ keys %$version ]}\n";
291print "Iteration count: $count\n";
292print 'Keys per iteration: ', key_count, "\n";
293print 'Value size: ', length($value), " bytes\n";
294
295srand(1);
296foreach my $args (@methods) {
297    my $sub = splice(@$args, 1, 1);
298    &$sub(@$args);
299}
300
301
302# Benchmark latency issues.
303if ($noreply) {
304    cmpthese(timethese($count, {
305        "set noreply followed by get"
306            => sub {
307                foreach (1..key_count) {
308                    $new_noreply->set('snfbg', $value);
309                    my $res = $new_noreply->get('snfbg');
310                }
311            }
312    }));
313}
314