← Index
NYTProf Performance Profile   « line view »
For /Users/timbo/perl5/perlbrew/perls/perl-5.18.2/bin/perlcritic
  Run on Sat Mar 19 22:12:22 2016
Reported on Sat Mar 19 22:14:11 2016

Filename/Users/timbo/perl5/perlbrew/perls/perl-5.18.2/lib/5.18.2/darwin-2level/B.pm
StatementsExecuted 55 statements in 2.30ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11112µs24µsB::::BEGIN@9 B::BEGIN@9
11110µs649µsB::::BEGIN@17 B::BEGIN@17
1118µs20µsB::::BEGIN@251 B::BEGIN@251
0000s0sB::GV::::SAFENAME B::GV::SAFENAME
0000s0sB::IV::::int_value B::IV::int_value
0000s0sB::Section::::addB::Section::add
0000s0sB::Section::::defaultB::Section::default
0000s0sB::Section::::getB::Section::get
0000s0sB::Section::::indexB::Section::index
0000s0sB::Section::::nameB::Section::name
0000s0sB::Section::::newB::Section::new
0000s0sB::Section::::outputB::Section::output
0000s0sB::Section::::symtableB::Section::symtable
0000s0sB::::class B::class
0000s0sB::::clearsym B::clearsym
0000s0sB::::compile_stats B::compile_stats
0000s0sB::::debug B::debug
0000s0sB::::objsym B::objsym
0000s0sB::::parents B::parents
0000s0sB::::peekop B::peekop
0000s0sB::::savesym B::savesym
0000s0sB::::timing_info B::timing_info
0000s0sB::::walkoptree_exec B::walkoptree_exec
0000s0sB::::walkoptree_slow B::walkoptree_slow
0000s0sB::::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#
8package B;
9257µs236µs
# spent 24µs (12+12) within B::BEGIN@9 which was called: # once (12µs+12µs) by Exporter::Tiny::_exporter_install_sub at line 9
use strict;
# spent 24µs making 1 call to B::BEGIN@9 # spent 12µs making 1 call to strict::import
10
111300nsrequire Exporter;
1216µ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 649µs (10+639) within B::BEGIN@17 which was called: # once (10µs+639µs) by Exporter::Tiny::_exporter_install_sub at line 28
BEGIN {
181400ns $B::VERSION = '1.42_02';
191400ns @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
261200ns require XSLoader;
271648µs1639µs XSLoader::load();
# spent 639µs making 1 call to XSLoader::load
2811.03ms1649µs}
# spent 649µs making 1 call to B::BEGIN@17
29
3017µspush @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 unitcheck_av));
39
4013µs@B::SV::ISA = 'B::OBJECT';
4115µs@B::NULL::ISA = 'B::SV';
4212µs@B::PV::ISA = 'B::SV';
4312µs@B::IV::ISA = 'B::SV';
4412µs@B::NV::ISA = 'B::SV';
45# RV is eliminated with 5.11.0, but effectively is a specialisation of IV now.
4613µs@B::RV::ISA = $] >= 5.011 ? 'B::IV' : 'B::SV';
4713µs@B::PVIV::ISA = qw(B::PV B::IV);
4815µs@B::PVNV::ISA = qw(B::PVIV B::NV);
4914µs@B::PVMG::ISA = 'B::PVNV';
5017µs@B::REGEXP::ISA = 'B::PVMG' if $] >= 5.011;
5113µs@B::PVLV::ISA = 'B::GV';
5212µs@B::BM::ISA = 'B::GV';
5313µs@B::AV::ISA = 'B::PVMG';
54116µs@B::GV::ISA = 'B::PVMG';
5514µs@B::HV::ISA = 'B::PVMG';
5614µs@B::CV::ISA = 'B::PVMG';
5714µs@B::IO::ISA = 'B::PVMG';
5813µs@B::FM::ISA = 'B::CV';
59
6012µs@B::OP::ISA = 'B::OBJECT';
6112µs@B::UNOP::ISA = 'B::OP';
6214µs@B::BINOP::ISA = 'B::UNOP';
6312µs@B::LOGOP::ISA = 'B::UNOP';
6413µs@B::LISTOP::ISA = 'B::BINOP';
6512µs@B::SVOP::ISA = 'B::OP';
6612µs@B::PADOP::ISA = 'B::OP';
6712µs@B::PVOP::ISA = 'B::OP';
6813µs@B::LOOP::ISA = 'B::LISTOP';
6912µs@B::PMOP::ISA = 'B::LISTOP';
7012µs@B::COP::ISA = 'B::OP';
71
7212µs@B::SPECIAL::ISA = 'B::OBJECT';
73
7412µs@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
75# bytecode.pl contained the following comment:
76# Nullsv *must* come first in the following so that the condition
77# ($$sv == 0) can continue to be used to test (sv == Nullsv).
7811µs@B::specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no
79 (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD);
80
81{
82 # Stop "-w" from complaining about the lack of a real B::OBJECT class
831500ns package B::OBJECT;
84}
85
86sub B::GV::SAFENAME {
87 my $name = (shift())->NAME;
88
89 # The regex below corresponds to the isCONTROLVAR macro
90 # from toke.c
91
92 $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
93 chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e;
94
95 # When we say unicode_to_native we really mean ascii_to_native,
96 # which matters iff this is a non-ASCII platform (EBCDIC).
97
98 return $name;
99}
100
101sub B::IV::int_value {
102 my ($self) = @_;
103 return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV);
104}
105
106sub B::NULL::as_string() {""}
10719µs*B::IV::as_string = \*B::IV::int_value;
10813µs*B::PV::as_string = \*B::PV::PV;
109
110# The input typemap checking makes no distinction between different SV types,
111# so the XS body will generate the same C code, despite the different XS
112# "types". So there is no change in behaviour from doing "newXS" like this,
113# compared with the old approach of having a (near) duplicate XS body.
114# We should fix the typemap checking.
11513µs*B::IV::RV = \*B::PV::RV if $] > 5.012;
116
1171100nsmy $debug;
1181100nsmy $op_count = 0;
1191300nsmy @parents = ();
120
121sub debug {
122 my ($class, $value) = @_;
123 $debug = $value;
124 walkoptree_debug($value);
125}
126
127sub class {
128 my $obj = shift;
129 my $name = ref $obj;
130 $name =~ s/^.*:://;
131 return $name;
132}
133
134sub parents { \@parents }
135
136# For debugging
137sub peekop {
138 my $op = shift;
139 return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
140}
141
142sub walkoptree_slow {
143 my($op, $method, $level) = @_;
144 $op_count++; # just for statistics
145 $level ||= 0;
146 warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
147 $op->$method($level) if $op->can($method);
148 if ($$op && ($op->flags & OPf_KIDS)) {
149 my $kid;
150 unshift(@parents, $op);
151 for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
152 walkoptree_slow($kid, $method, $level + 1);
153 }
154 shift @parents;
155 }
156 if (class($op) eq 'PMOP'
157 && ref($op->pmreplroot)
158 && ${$op->pmreplroot}
159 && $op->pmreplroot->isa( 'B::OP' ))
160 {
161 unshift(@parents, $op);
162 walkoptree_slow($op->pmreplroot, $method, $level + 1);
163 shift @parents;
164 }
165}
166
167sub compile_stats {
168 return "Total number of OPs processed: $op_count\n";
169}
170
171sub timing_info {
172 my ($sec, $min, $hr) = localtime;
173 my ($user, $sys) = times;
174 sprintf("%02d:%02d:%02d user=$user sys=$sys",
175 $hr, $min, $sec, $user, $sys);
176}
177
1781100nsmy %symtable;
179
180sub clearsym {
181 %symtable = ();
182}
183
184sub savesym {
185 my ($obj, $value) = @_;
186# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
187 $symtable{sprintf("sym_%x", $$obj)} = $value;
188}
189
190sub objsym {
191 my $obj = shift;
192 return $symtable{sprintf("sym_%x", $$obj)};
193}
194
195sub walkoptree_exec {
196 my ($op, $method, $level) = @_;
197 $level ||= 0;
198 my ($sym, $ppname);
199 my $prefix = " " x $level;
200 for (; $$op; $op = $op->next) {
201 $sym = objsym($op);
202 if (defined($sym)) {
203 print $prefix, "goto $sym\n";
204 return;
205 }
206 savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
207 $op->$method($level);
208 $ppname = $op->name;
209 if ($ppname =~
210 /^(d?or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/)
211 {
212 print $prefix, uc($1), " => {\n";
213 walkoptree_exec($op->other, $method, $level + 1);
214 print $prefix, "}\n";
215 } elsif ($ppname eq "match" || $ppname eq "subst") {
216 my $pmreplstart = $op->pmreplstart;
217 if ($$pmreplstart) {
218 print $prefix, "PMREPLSTART => {\n";
219 walkoptree_exec($pmreplstart, $method, $level + 1);
220 print $prefix, "}\n";
221 }
222 } elsif ($ppname eq "substcont") {
223 print $prefix, "SUBSTCONT => {\n";
224 walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
225 print $prefix, "}\n";
226 $op = $op->other;
227 } elsif ($ppname eq "enterloop") {
228 print $prefix, "REDO => {\n";
229 walkoptree_exec($op->redoop, $method, $level + 1);
230 print $prefix, "}\n", $prefix, "NEXT => {\n";
231 walkoptree_exec($op->nextop, $method, $level + 1);
232 print $prefix, "}\n", $prefix, "LAST => {\n";
233 walkoptree_exec($op->lastop, $method, $level + 1);
234 print $prefix, "}\n";
235 } elsif ($ppname eq "subst") {
236 my $replstart = $op->pmreplstart;
237 if ($$replstart) {
238 print $prefix, "SUBST => {\n";
239 walkoptree_exec($replstart, $method, $level + 1);
240 print $prefix, "}\n";
241 }
242 }
243 }
244}
245
246sub walksymtable {
247 my ($symref, $method, $recurse, $prefix) = @_;
248 my $sym;
249 my $ref;
250 my $fullname;
2512413µs233µs
# spent 20µs (8+12) within B::BEGIN@251 which was called: # once (8µs+12µs) by Exporter::Tiny::_exporter_install_sub at line 251
no strict 'refs';
# spent 20µs making 1 call to B::BEGIN@251 # spent 12µs making 1 call to strict::unimport
252 $prefix = '' unless defined $prefix;
253 foreach my $sym ( sort keys %$symref ) {
254 $ref= $symref->{$sym};
255 $fullname = "*main::".$prefix.$sym;
256 if ($sym =~ /::$/) {
257 $sym = $prefix . $sym;
258 if (svref_2object(\*$sym)->NAME ne "main::" && $sym ne "<none>::" && &$recurse($sym)) {
259 walksymtable(\%$fullname, $method, $recurse, $sym);
260 }
261 } else {
262 svref_2object(\*$fullname)->$method();
263 }
264 }
265}
266
267{
2681200ns package B::Section;
26910s my $output_fh;
2701300ns my %sections;
271
272 sub new {
273 my ($class, $section, $symtable, $default) = @_;
274 $output_fh ||= FileHandle->new_tmpfile;
275 my $obj = bless [-1, $section, $symtable, $default], $class;
276 $sections{$section} = $obj;
277 return $obj;
278 }
279
280 sub get {
281 my ($class, $section) = @_;
282 return $sections{$section};
283 }
284
285 sub add {
286 my $section = shift;
287 while (defined($_ = shift)) {
288 print $output_fh "$section->[1]\t$_\n";
289 $section->[0]++;
290 }
291 }
292
293 sub index {
294 my $section = shift;
295 return $section->[0];
296 }
297
298 sub name {
299 my $section = shift;
300 return $section->[1];
301 }
302
303 sub symtable {
304 my $section = shift;
305 return $section->[2];
306 }
307
308 sub default {
309 my $section = shift;
310 return $section->[3];
311 }
312
313 sub output {
314 my ($section, $fh, $format) = @_;
315 my $name = $section->name;
316 my $sym = $section->symtable || {};
317 my $default = $section->default;
318
319 seek($output_fh, 0, 0);
320 while (<$output_fh>) {
321 chomp;
322 s/^(.*?)\t//;
323 if ($1 eq $name) {
324 s{(s\\_[0-9a-f]+)} {
325 exists($sym->{$1}) ? $sym->{$1} : $default;
326 }ge;
327 printf $fh $format, $_;
328 }
329 }
330 }
331}
332
333118µs1;
334
335__END__
Report produced by the NYTProf 6.01 Perl profiler, developed by Tim Bunce and Adam Kaplan.