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