Profile of B.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For bin/dpath
Run on Tue Jun 5 15:31:33 2012
Reported on Tue Jun 5 15:31:44 2012

Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/x86_64-linux-thread-multi/B.pm
Statements | Executed 55 statements in 12.0ms

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