Profile of B.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For xt/tapper-mcp-scheduler-with-db-longrun.t
Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:22:35 2012

Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/5.12.3/x86_64-linux/B.pm
Statements | Executed 56 statements in 2.99ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
48 | 6 | 4 | 140µs | 140µs | B::::perlstring B::perlstring (xsub)
1 | 1 | 1 | 8µs | 24µs | B::::BEGIN@237 B::BEGIN@237
1 | 1 | 1 | 8µs | 8µs | B::::BEGIN@12 B::BEGIN@12
1 | 1 | 1 | 7µs | 9µs | B::::BEGIN@30 B::BEGIN@30
0 | 0 | 0 | 0s | 0s | B::GV::::SAFENAME B::GV::SAFENAME
0 | 0 | 0 | 0s | 0s | B::IV::::as_string B::IV::as_string
0 | 0 | 0 | 0s | 0s | B::IV::::int_value B::IV::int_value
0 | 0 | 0 | 0s | 0s | B::PV::::as_string B::PV::as_string
0 | 0 | 0 | 0s | 0s | B::Section::::addB::Section::add
0 | 0 | 0 | 0s | 0s | B::Section::::defaultB::Section::default
0 | 0 | 0 | 0s | 0s | B::Section::::getB::Section::get
0 | 0 | 0 | 0s | 0s | B::Section::::indexB::Section::index
0 | 0 | 0 | 0s | 0s | B::Section::::nameB::Section::name
0 | 0 | 0 | 0s | 0s | B::Section::::newB::Section::new
0 | 0 | 0 | 0s | 0s | B::Section::::outputB::Section::output
0 | 0 | 0 | 0s | 0s | B::Section::::symtableB::Section::symtable
0 | 0 | 0 | 0s | 0s | B::::class B::class
0 | 0 | 0 | 0s | 0s | B::::clearsym B::clearsym
0 | 0 | 0 | 0s | 0s | B::::compile_stats B::compile_stats
0 | 0 | 0 | 0s | 0s | B::::debug B::debug
0 | 0 | 0 | 0s | 0s | B::::objsym B::objsym
0 | 0 | 0 | 0s | 0s | B::::parents B::parents
0 | 0 | 0 | 0s | 0s | B::::peekop B::peekop
0 | 0 | 0 | 0s | 0s | B::::savesym B::savesym
0 | 0 | 0 | 0s | 0s | B::::timing_info B::timing_info
0 | 0 | 0 | 0s | 0s | B::::walkoptree_exec B::walkoptree_exec
0 | 0 | 0 | 0s | 0s | B::::walkoptree_slow B::walkoptree_slow
0 | 0 | 0 | 0s | 0s | B::::walksymtable B::walksymtable

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | # B.pm
2 |  |  |  |  | #
3 |  |  |  |  | # Copyright (c) 1996, 1997, 1998 Malcolm Beattie
4 |  |  |  |  | #
5 |  |  |  |  | # You may distribute under the terms of either the GNU General Public
6 |  |  |  |  | # License or the Artistic License, as specified in the README file.
7 |  |  |  |  | #
8 |  |  |  |  | package B;
9 |  |  |  |  |
10 | 1 | 500ns |  |  | our $VERSION = '1.23';
11 |  |  |  |  |
12 | 3 | 83µs | 1 | 8µs | # spent 8µs within B::BEGIN@12 which was called: # once (8µs+0s) by Moose::Meta::Attribute::BEGIN@13 at line 12 use XSLoader (); # spent 8µs making 1 call to B::BEGIN@12
13 | 1 | 800ns |  |  | require Exporter;
14 | 1 | 9µs |  |  | @ISA = qw(Exporter);
15 |  |  |  |  |
16 |  |  |  |  | # walkoptree_slow comes from B.pm (you are there),
17 |  |  |  |  | # walkoptree comes from B.xs
18 | 1 | 5µs |  |  | @EXPORT_OK = qw(minus_c ppname save_BEGINs
19 |  |  |  |  | class peekop cast_I32 cstring cchar hash threadsv_names
20 |  |  |  |  | main_root main_start main_cv svref_2object opnumber
21 |  |  |  |  | sub_generation amagic_generation perlstring
22 |  |  |  |  | walkoptree_slow walkoptree walkoptree_exec walksymtable
23 |  |  |  |  | parents comppadlist sv_undef compile_stats timing_info
24 |  |  |  |  | begin_av init_av check_av end_av regex_padav dowarn defstash
25 |  |  |  |  | curstash warnhook diehook inc_gv @optype @specialsv_name
26 |  |  |  |  | );
27 | 1 | 2µs |  |  | push @EXPORT_OK, qw(unitcheck_av) if $] > 5.009;
28 |  |  |  |  |
29 |  |  |  |  | sub OPf_KIDS ();
30 | 3 | 1.09ms | 2 | 11µs | # spent 9µs (7+2) within B::BEGIN@30 which was called: # once (7µs+2µs) by Moose::Meta::Attribute::BEGIN@13 at line 30 use strict; # spent 9µs making 1 call to B::BEGIN@30 # spent 2µs making 1 call to strict::import
31 | 1 | 9µs |  |  | @B::SV::ISA = 'B::OBJECT';
32 | 1 | 8µs |  |  | @B::NULL::ISA = 'B::SV';
33 | 1 | 3µs |  |  | @B::PV::ISA = 'B::SV';
34 | 1 | 7µs |  |  | @B::IV::ISA = 'B::SV';
35 | 1 | 3µs |  |  | @B::NV::ISA = 'B::SV';
36 |  |  |  |  | # RV is eliminated with 5.11.0, but effectively is a specialisation of IV now.
37 | 1 | 5µs |  |  | @B::RV::ISA = $] >= 5.011 ? 'B::IV' : 'B::SV';
38 | 1 | 8µs |  |  | @B::PVIV::ISA = qw(B::PV B::IV);
39 | 1 | 10µs |  |  | @B::PVNV::ISA = qw(B::PVIV B::NV);
40 | 1 | 6µs |  |  | @B::PVMG::ISA = 'B::PVNV';
41 | 1 | 7µs |  |  | @B::REGEXP::ISA = 'B::PVMG' if $] >= 5.011;
42 |  |  |  |  | # Change in the inheritance hierarchy post 5.9.0
43 | 1 | 7µs |  |  | @B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG';
44 |  |  |  |  | # BM is eliminated post 5.9.5, but effectively is a specialisation of GV now.
45 | 1 | 4µs |  |  | @B::BM::ISA = $] > 5.009005 ? 'B::GV' : 'B::PVMG';
46 | 1 | 10µs |  |  | @B::AV::ISA = 'B::PVMG';
47 | 1 | 13µs |  |  | @B::GV::ISA = 'B::PVMG';
48 | 1 | 6µs |  |  | @B::HV::ISA = 'B::PVMG';
49 | 1 | 5µs |  |  | @B::CV::ISA = 'B::PVMG';
50 | 1 | 7µs |  |  | @B::IO::ISA = 'B::PVMG';
51 | 1 | 8µs |  |  | @B::FM::ISA = 'B::CV';
52 |  |  |  |  |
53 | 1 | 4µs |  |  | @B::OP::ISA = 'B::OBJECT';
54 | 1 | 3µs |  |  | @B::UNOP::ISA = 'B::OP';
55 | 1 | 8µs |  |  | @B::BINOP::ISA = 'B::UNOP';
56 | 1 | 4µs |  |  | @B::LOGOP::ISA = 'B::UNOP';
57 | 1 | 5µs |  |  | @B::LISTOP::ISA = 'B::BINOP';
58 | 1 | 3µs |  |  | @B::SVOP::ISA = 'B::OP';
59 | 1 | 3µs |  |  | @B::PADOP::ISA = 'B::OP';
60 | 1 | 3µs |  |  | @B::PVOP::ISA = 'B::OP';
61 | 1 | 10µs |  |  | @B::LOOP::ISA = 'B::LISTOP';
62 | 1 | 5µs |  |  | @B::PMOP::ISA = 'B::LISTOP';
63 | 1 | 3µs |  |  | @B::COP::ISA = 'B::OP';
64 |  |  |  |  |
65 | 1 | 3µs |  |  | @B::SPECIAL::ISA = 'B::OBJECT';
66 |  |  |  |  |
67 | 1 | 7µs |  |  | @B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
68 |  |  |  |  | # bytecode.pl contained the following comment:
69 |  |  |  |  | # Nullsv *must* come first in the following so that the condition
70 |  |  |  |  | # ($$sv == 0) can continue to be used to test (sv == Nullsv).
71 | 1 | 1µs |  |  | @B::specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no
72 |  |  |  |  | (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD);
73 |  |  |  |  |
74 |  |  |  |  | {
75 |  |  |  |  | # Stop "-w" from complaining about the lack of a real B::OBJECT class
76 | 1 | 700ns |  |  | package B::OBJECT;
77 |  |  |  |  | }
78 |  |  |  |  |
79 |  |  |  |  | sub B::GV::SAFENAME {
80 |  |  |  |  | my $name = (shift())->NAME;
81 |  |  |  |  |
82 |  |  |  |  | # The regex below corresponds to the isCONTROLVAR macro
83 |  |  |  |  | # from toke.c
84 |  |  |  |  |
85 |  |  |  |  | $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
86 |  |  |  |  | chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e;
87 |  |  |  |  |
88 |  |  |  |  | # When we say unicode_to_native we really mean ascii_to_native,
89 |  |  |  |  | # which matters iff this is a non-ASCII platform (EBCDIC).
90 |  |  |  |  |
91 |  |  |  |  | return $name;
92 |  |  |  |  | }
93 |  |  |  |  |
94 |  |  |  |  | sub B::IV::int_value {
95 |  |  |  |  | my ($self) = @_;
96 |  |  |  |  | return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV);
97 |  |  |  |  | }
98 |  |  |  |  |
99 |  |  |  |  | sub B::NULL::as_string() {""}
100 |  |  |  |  | sub B::IV::as_string() {goto &B::IV::int_value}
101 |  |  |  |  | sub B::PV::as_string() {goto &B::PV::PV}
102 |  |  |  |  |
103 | 1 | 200ns |  |  | my $debug;
104 | 1 | 300ns |  |  | my $op_count = 0;
105 | 1 | 300ns |  |  | my @parents = ();
106 |  |  |  |  |
107 |  |  |  |  | sub debug {
108 |  |  |  |  | my ($class, $value) = @_;
109 |  |  |  |  | $debug = $value;
110 |  |  |  |  | walkoptree_debug($value);
111 |  |  |  |  | }
112 |  |  |  |  |
113 |  |  |  |  | sub class {
114 |  |  |  |  | my $obj = shift;
115 |  |  |  |  | my $name = ref $obj;
116 |  |  |  |  | $name =~ s/^.*:://;
117 |  |  |  |  | return $name;
118 |  |  |  |  | }
119 |  |  |  |  |
120 |  |  |  |  | sub parents { \@parents }
121 |  |  |  |  |
122 |  |  |  |  | # For debugging
123 |  |  |  |  | sub peekop {
124 |  |  |  |  | my $op = shift;
125 |  |  |  |  | return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
126 |  |  |  |  | }
127 |  |  |  |  |
128 |  |  |  |  | sub walkoptree_slow {
129 |  |  |  |  | my($op, $method, $level) = @_;
130 |  |  |  |  | $op_count++; # just for statistics
131 |  |  |  |  | $level ||= 0;
132 |  |  |  |  | warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
133 |  |  |  |  | $op->$method($level) if $op->can($method);
134 |  |  |  |  | if ($$op && ($op->flags & OPf_KIDS)) {
135 |  |  |  |  | my $kid;
136 |  |  |  |  | unshift(@parents, $op);
137 |  |  |  |  | for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
138 |  |  |  |  | walkoptree_slow($kid, $method, $level + 1);
139 |  |  |  |  | }
140 |  |  |  |  | shift @parents;
141 |  |  |  |  | }
142 |  |  |  |  | if (class($op) eq 'PMOP'
143 |  |  |  |  | && ref($op->pmreplroot)
144 |  |  |  |  | && ${$op->pmreplroot}
145 |  |  |  |  | && $op->pmreplroot->isa( 'B::OP' ))
146 |  |  |  |  | {
147 |  |  |  |  | unshift(@parents, $op);
148 |  |  |  |  | walkoptree_slow($op->pmreplroot, $method, $level + 1);
149 |  |  |  |  | shift @parents;
150 |  |  |  |  | }
151 |  |  |  |  | }
152 |  |  |  |  |
153 |  |  |  |  | sub compile_stats {
154 |  |  |  |  | return "Total number of OPs processed: $op_count\n";
155 |  |  |  |  | }
156 |  |  |  |  |
157 |  |  |  |  | sub timing_info {
158 |  |  |  |  | my ($sec, $min, $hr) = localtime;
159 |  |  |  |  | my ($user, $sys) = times;
160 |  |  |  |  | sprintf("%02d:%02d:%02d user=$user sys=$sys",
161 |  |  |  |  | $hr, $min, $sec, $user, $sys);
162 |  |  |  |  | }
163 |  |  |  |  |
164 | 1 | 200ns |  |  | my %symtable;
165 |  |  |  |  |
166 |  |  |  |  | sub clearsym {
167 |  |  |  |  | %symtable = ();
168 |  |  |  |  | }
169 |  |  |  |  |
170 |  |  |  |  | sub savesym {
171 |  |  |  |  | my ($obj, $value) = @_;
172 |  |  |  |  | # warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
173 |  |  |  |  | $symtable{sprintf("sym_%x", $$obj)} = $value;
174 |  |  |  |  | }
175 |  |  |  |  |
176 |  |  |  |  | sub objsym {
177 |  |  |  |  | my $obj = shift;
178 |  |  |  |  | return $symtable{sprintf("sym_%x", $$obj)};
179 |  |  |  |  | }
180 |  |  |  |  |
181 |  |  |  |  | sub walkoptree_exec {
182 |  |  |  |  | my ($op, $method, $level) = @_;
183 |  |  |  |  | $level ||= 0;
184 |  |  |  |  | my ($sym, $ppname);
185 |  |  |  |  | my $prefix = " " x $level;
186 |  |  |  |  | for (; $$op; $op = $op->next) {
187 |  |  |  |  | $sym = objsym($op);
188 |  |  |  |  | if (defined($sym)) {
189 |  |  |  |  | print $prefix, "goto $sym\n";
190 |  |  |  |  | return;
191 |  |  |  |  | }
192 |  |  |  |  | savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
193 |  |  |  |  | $op->$method($level);
194 |  |  |  |  | $ppname = $op->name;
195 |  |  |  |  | if ($ppname =~
196 |  |  |  |  | /^(d?or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/)
197 |  |  |  |  | {
198 |  |  |  |  | print $prefix, uc($1), " => {\n";
199 |  |  |  |  | walkoptree_exec($op->other, $method, $level + 1);
200 |  |  |  |  | print $prefix, "}\n";
201 |  |  |  |  | } elsif ($ppname eq "match" || $ppname eq "subst") {
202 |  |  |  |  | my $pmreplstart = $op->pmreplstart;
203 |  |  |  |  | if ($$pmreplstart) {
204 |  |  |  |  | print $prefix, "PMREPLSTART => {\n";
205 |  |  |  |  | walkoptree_exec($pmreplstart, $method, $level + 1);
206 |  |  |  |  | print $prefix, "}\n";
207 |  |  |  |  | }
208 |  |  |  |  | } elsif ($ppname eq "substcont") {
209 |  |  |  |  | print $prefix, "SUBSTCONT => {\n";
210 |  |  |  |  | walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
211 |  |  |  |  | print $prefix, "}\n";
212 |  |  |  |  | $op = $op->other;
213 |  |  |  |  | } elsif ($ppname eq "enterloop") {
214 |  |  |  |  | print $prefix, "REDO => {\n";
215 |  |  |  |  | walkoptree_exec($op->redoop, $method, $level + 1);
216 |  |  |  |  | print $prefix, "}\n", $prefix, "NEXT => {\n";
217 |  |  |  |  | walkoptree_exec($op->nextop, $method, $level + 1);
218 |  |  |  |  | print $prefix, "}\n", $prefix, "LAST => {\n";
219 |  |  |  |  | walkoptree_exec($op->lastop, $method, $level + 1);
220 |  |  |  |  | print $prefix, "}\n";
221 |  |  |  |  | } elsif ($ppname eq "subst") {
222 |  |  |  |  | my $replstart = $op->pmreplstart;
223 |  |  |  |  | if ($$replstart) {
224 |  |  |  |  | print $prefix, "SUBST => {\n";
225 |  |  |  |  | walkoptree_exec($replstart, $method, $level + 1);
226 |  |  |  |  | print $prefix, "}\n";
227 |  |  |  |  | }
228 |  |  |  |  | }
229 |  |  |  |  | }
230 |  |  |  |  | }
231 |  |  |  |  |
232 |  |  |  |  | sub walksymtable {
233 |  |  |  |  | my ($symref, $method, $recurse, $prefix) = @_;
234 |  |  |  |  | my $sym;
235 |  |  |  |  | my $ref;
236 |  |  |  |  | my $fullname;
237 | 3 | 405µs | 2 | 40µs | # spent 24µs (8+16) within B::BEGIN@237 which was called: # once (8µs+16µs) by Moose::Meta::Attribute::BEGIN@13 at line 237 no strict 'refs'; # spent 24µs making 1 call to B::BEGIN@237 # spent 16µs making 1 call to strict::unimport
238 |  |  |  |  | $prefix = '' unless defined $prefix;
239 |  |  |  |  | while (($sym, $ref) = each %$symref) {
240 |  |  |  |  | $fullname = "*main::".$prefix.$sym;
241 |  |  |  |  | if ($sym =~ /::$/) {
242 |  |  |  |  | $sym = $prefix . $sym;
243 |  |  |  |  | if (svref_2object(\*$sym)->NAME ne "main::" && $sym ne "<none>::" && &$recurse($sym)) {
244 |  |  |  |  | walksymtable(\%$fullname, $method, $recurse, $sym);
245 |  |  |  |  | }
246 |  |  |  |  | } else {
247 |  |  |  |  | svref_2object(\*$fullname)->$method();
248 |  |  |  |  | }
249 |  |  |  |  | }
250 |  |  |  |  | }
251 |  |  |  |  |
252 |  |  |  |  | {
253 | 1 | 300ns |  |  | package B::Section;
254 | 1 | 100ns |  |  | my $output_fh;
255 | 1 | 400ns |  |  | my %sections;
256 |  |  |  |  |
257 |  |  |  |  | sub new {
258 |  |  |  |  | my ($class, $section, $symtable, $default) = @_;
259 |  |  |  |  | $output_fh ||= FileHandle->new_tmpfile;
260 |  |  |  |  | my $obj = bless [-1, $section, $symtable, $default], $class;
261 |  |  |  |  | $sections{$section} = $obj;
262 |  |  |  |  | return $obj;
263 |  |  |  |  | }
264 |  |  |  |  |
265 |  |  |  |  | sub get {
266 |  |  |  |  | my ($class, $section) = @_;
267 |  |  |  |  | return $sections{$section};
268 |  |  |  |  | }
269 |  |  |  |  |
270 |  |  |  |  | sub add {
271 |  |  |  |  | my $section = shift;
272 |  |  |  |  | while (defined($_ = shift)) {
273 |  |  |  |  | print $output_fh "$section->[1]\t$_\n";
274 |  |  |  |  | $section->[0]++;
275 |  |  |  |  | }
276 |  |  |  |  | }
277 |  |  |  |  |
278 |  |  |  |  | sub index {
279 |  |  |  |  | my $section = shift;
280 |  |  |  |  | return $section->[0];
281 |  |  |  |  | }
282 |  |  |  |  |
283 |  |  |  |  | sub name {
284 |  |  |  |  | my $section = shift;
285 |  |  |  |  | return $section->[1];
286 |  |  |  |  | }
287 |  |  |  |  |
288 |  |  |  |  | sub symtable {
289 |  |  |  |  | my $section = shift;
290 |  |  |  |  | return $section->[2];
291 |  |  |  |  | }
292 |  |  |  |  |
293 |  |  |  |  | sub default {
294 |  |  |  |  | my $section = shift;
295 |  |  |  |  | return $section->[3];
296 |  |  |  |  | }
297 |  |  |  |  |
298 |  |  |  |  | sub output {
299 |  |  |  |  | my ($section, $fh, $format) = @_;
300 |  |  |  |  | my $name = $section->name;
301 |  |  |  |  | my $sym = $section->symtable || {};
302 |  |  |  |  | my $default = $section->default;
303 |  |  |  |  |
304 |  |  |  |  | seek($output_fh, 0, 0);
305 |  |  |  |  | while (<$output_fh>) {
306 |  |  |  |  | chomp;
307 |  |  |  |  | s/^(.*?)\t//;
308 |  |  |  |  | if ($1 eq $name) {
309 |  |  |  |  | s{(s\\_[0-9a-f]+)} {
310 |  |  |  |  | exists($sym->{$1}) ? $sym->{$1} : $default;
311 |  |  |  |  | }ge;
312 |  |  |  |  | printf $fh $format, $_;
313 |  |  |  |  | }
314 |  |  |  |  | }
315 |  |  |  |  | }
316 |  |  |  |  | }
317 |  |  |  |  |
318 | 1 | 1.17ms | 1 | 1.16ms | XSLoader::load 'B'; # spent 1.16ms making 1 call to XSLoader::load
319 |  |  |  |  |
320 | 1 | 36µs |  |  | 1;
321 |  |  |  |  |
322 |  |  |  |  | __END__
|  |  |  |  | # spent 140µs within B::perlstring which was called 48 times, avg 3µs/call: # 20 times (72µs+0s) by Moose::Meta::TypeConstraint::Class::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/x86_64-linux/Moose/Meta/TypeConstraint/Class.pm:30] at line 28 of Moose/Meta/TypeConstraint/Class.pm, avg 4µs/call # 9 times (19µs+0s) by Moose::Meta::Attribute::_inline_throw_error at line 76 of Moose/Meta/Attribute.pm, avg 2µs/call # 9 times (8µs+0s) by Moose::Meta::Attribute::_inline_throw_error at line 77 of Moose/Meta/Attribute.pm, avg 867ns/call # 4 times (16µs+0s) by Moose::Meta::TypeConstraint::Role::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/x86_64-linux/Moose/Meta/TypeConstraint/Role.pm:32] at line 28 of Moose/Meta/TypeConstraint/Role.pm, avg 4µs/call # 3 times (22µs+0s) by Moose::Meta::Method::_inline_throw_error at line 44 of Moose/Meta/Method.pm, avg 7µs/call # 3 times (3µs+0s) by Moose::Meta::Method::_inline_throw_error at line 45 of Moose/Meta/Method.pm, avg 1µs/call sub B::perlstring; # xsub