| Filename | /usr/lib/perl/5.18/B.pm |
| Statements | Executed 55 statements in 2.19ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 246 | 3 | 3 | 556µs | 556µs | B::perlstring (xsub) |
| 1 | 1 | 1 | 18µs | 515µs | B::BEGIN@17 |
| 5 | 1 | 1 | 14µs | 14µs | B::opnumber (xsub) |
| 1 | 1 | 1 | 11µs | 18µs | B::BEGIN@9 |
| 1 | 1 | 1 | 7µs | 20µs | B::BEGIN@251 |
| 1 | 1 | 1 | 1µs | 1µs | B::threadsv_names (xsub) |
| 0 | 0 | 0 | 0s | 0s | B::GV::SAFENAME |
| 0 | 0 | 0 | 0s | 0s | B::IV::int_value |
| 0 | 0 | 0 | 0s | 0s | B::Section::add |
| 0 | 0 | 0 | 0s | 0s | B::Section::default |
| 0 | 0 | 0 | 0s | 0s | B::Section::get |
| 0 | 0 | 0 | 0s | 0s | B::Section::index |
| 0 | 0 | 0 | 0s | 0s | B::Section::name |
| 0 | 0 | 0 | 0s | 0s | B::Section::new |
| 0 | 0 | 0 | 0s | 0s | B::Section::output |
| 0 | 0 | 0 | 0s | 0s | B::Section::symtable |
| 0 | 0 | 0 | 0s | 0s | B::class |
| 0 | 0 | 0 | 0s | 0s | B::clearsym |
| 0 | 0 | 0 | 0s | 0s | B::compile_stats |
| 0 | 0 | 0 | 0s | 0s | B::debug |
| 0 | 0 | 0 | 0s | 0s | B::objsym |
| 0 | 0 | 0 | 0s | 0s | B::parents |
| 0 | 0 | 0 | 0s | 0s | B::peekop |
| 0 | 0 | 0 | 0s | 0s | B::savesym |
| 0 | 0 | 0 | 0s | 0s | B::timing_info |
| 0 | 0 | 0 | 0s | 0s | B::walkoptree_exec |
| 0 | 0 | 0 | 0s | 0s | B::walkoptree_slow |
| 0 | 0 | 0 | 0s | 0s | B::walksymtable |
| 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 | 64µs | 2 | 26µs | # spent 18µs (11+8) within B::BEGIN@9 which was called:
# once (11µs+8µs) by Moose::Meta::Attribute::BEGIN@6 at line 9 # spent 18µs making 1 call to B::BEGIN@9
# spent 8µs making 1 call to strict::import |
| 10 | |||||
| 11 | 1 | 700ns | 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 515µs (18+497) within B::BEGIN@17 which was called:
# once (18µs+497µs) by Moose::Meta::Attribute::BEGIN@6 at line 28 | ||||
| 18 | 1 | 300ns | $B::VERSION = '1.42_02'; | ||
| 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 | 514µs | 1 | 496µs | XSLoader::load(); # spent 496µs making 1 call to XSLoader::load |
| 28 | 1 | 1.06ms | 1 | 515µs | } # spent 515µs making 1 call to B::BEGIN@17 |
| 29 | |||||
| 30 | 1 | 5µ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)); | ||||
| 39 | |||||
| 40 | 1 | 4µs | @B::SV::ISA = 'B::OBJECT'; | ||
| 41 | 1 | 2µ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 | 1µs | @B::NV::ISA = 'B::SV'; | ||
| 45 | # RV is eliminated with 5.11.0, but effectively is a specialisation of IV now. | ||||
| 46 | 1 | 6µs | @B::RV::ISA = $] >= 5.011 ? 'B::IV' : 'B::SV'; | ||
| 47 | 1 | 4µs | @B::PVIV::ISA = qw(B::PV B::IV); | ||
| 48 | 1 | 4µs | @B::PVNV::ISA = qw(B::PVIV B::NV); | ||
| 49 | 1 | 3µs | @B::PVMG::ISA = 'B::PVNV'; | ||
| 50 | 1 | 6µs | @B::REGEXP::ISA = 'B::PVMG' if $] >= 5.011; | ||
| 51 | 1 | 2µs | @B::PVLV::ISA = 'B::GV'; | ||
| 52 | 1 | 2µs | @B::BM::ISA = 'B::GV'; | ||
| 53 | 1 | 2µs | @B::AV::ISA = 'B::PVMG'; | ||
| 54 | 1 | 13µs | @B::GV::ISA = 'B::PVMG'; | ||
| 55 | 1 | 3µs | @B::HV::ISA = 'B::PVMG'; | ||
| 56 | 1 | 3µs | @B::CV::ISA = 'B::PVMG'; | ||
| 57 | 1 | 3µs | @B::IO::ISA = 'B::PVMG'; | ||
| 58 | 1 | 5µs | @B::FM::ISA = 'B::CV'; | ||
| 59 | |||||
| 60 | 1 | 2µs | @B::OP::ISA = 'B::OBJECT'; | ||
| 61 | 1 | 2µs | @B::UNOP::ISA = 'B::OP'; | ||
| 62 | 1 | 7µs | @B::BINOP::ISA = 'B::UNOP'; | ||
| 63 | 1 | 2µs | @B::LOGOP::ISA = 'B::UNOP'; | ||
| 64 | 1 | 2µs | @B::LISTOP::ISA = 'B::BINOP'; | ||
| 65 | 1 | 2µs | @B::SVOP::ISA = 'B::OP'; | ||
| 66 | 1 | 2µs | @B::PADOP::ISA = 'B::OP'; | ||
| 67 | 1 | 1µs | @B::PVOP::ISA = 'B::OP'; | ||
| 68 | 1 | 2µs | @B::LOOP::ISA = 'B::LISTOP'; | ||
| 69 | 1 | 4µs | @B::PMOP::ISA = 'B::LISTOP'; | ||
| 70 | 1 | 2µs | @B::COP::ISA = 'B::OP'; | ||
| 71 | |||||
| 72 | 1 | 1µs | @B::SPECIAL::ISA = 'B::OBJECT'; | ||
| 73 | |||||
| 74 | 1 | 1µ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). | ||||
| 78 | 1 | 2µ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 | ||||
| 83 | 1 | 900ns | package B::OBJECT; | ||
| 84 | } | ||||
| 85 | |||||
| 86 | sub 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 | |||||
| 101 | sub B::IV::int_value { | ||||
| 102 | my ($self) = @_; | ||||
| 103 | return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV); | ||||
| 104 | } | ||||
| 105 | |||||
| 106 | sub B::NULL::as_string() {""} | ||||
| 107 | 1 | 5µs | *B::IV::as_string = \*B::IV::int_value; | ||
| 108 | 1 | 3µ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. | ||||
| 115 | 1 | 3µs | *B::IV::RV = \*B::PV::RV if $] > 5.012; | ||
| 116 | |||||
| 117 | 1 | 100ns | my $debug; | ||
| 118 | 1 | 100ns | my $op_count = 0; | ||
| 119 | 1 | 300ns | my @parents = (); | ||
| 120 | |||||
| 121 | sub debug { | ||||
| 122 | my ($class, $value) = @_; | ||||
| 123 | $debug = $value; | ||||
| 124 | walkoptree_debug($value); | ||||
| 125 | } | ||||
| 126 | |||||
| 127 | sub class { | ||||
| 128 | my $obj = shift; | ||||
| 129 | my $name = ref $obj; | ||||
| 130 | $name =~ s/^.*:://; | ||||
| 131 | return $name; | ||||
| 132 | } | ||||
| 133 | |||||
| 134 | sub parents { \@parents } | ||||
| 135 | |||||
| 136 | # For debugging | ||||
| 137 | sub peekop { | ||||
| 138 | my $op = shift; | ||||
| 139 | return sprintf("%s (0x%x) %s", class($op), $$op, $op->name); | ||||
| 140 | } | ||||
| 141 | |||||
| 142 | sub 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 | |||||
| 167 | sub compile_stats { | ||||
| 168 | return "Total number of OPs processed: $op_count\n"; | ||||
| 169 | } | ||||
| 170 | |||||
| 171 | sub 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 | |||||
| 178 | 1 | 200ns | my %symtable; | ||
| 179 | |||||
| 180 | sub clearsym { | ||||
| 181 | %symtable = (); | ||||
| 182 | } | ||||
| 183 | |||||
| 184 | sub 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 | |||||
| 190 | sub objsym { | ||||
| 191 | my $obj = shift; | ||||
| 192 | return $symtable{sprintf("sym_%x", $$obj)}; | ||||
| 193 | } | ||||
| 194 | |||||
| 195 | sub 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 | |||||
| 246 | sub walksymtable { | ||||
| 247 | my ($symref, $method, $recurse, $prefix) = @_; | ||||
| 248 | my $sym; | ||||
| 249 | my $ref; | ||||
| 250 | my $fullname; | ||||
| 251 | 2 | 408µs | 2 | 33µs | # spent 20µs (7+13) within B::BEGIN@251 which was called:
# once (7µs+13µs) by Moose::Meta::Attribute::BEGIN@6 at line 251 # spent 20µs making 1 call to B::BEGIN@251
# spent 13µ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 | { | ||||
| 268 | 1 | 200ns | package B::Section; | ||
| 269 | 1 | 0s | my $output_fh; | ||
| 270 | 1 | 400ns | 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 | |||||
| 333 | 1 | 15µs | 1; | ||
| 334 | |||||
| 335 | __END__ | ||||
# spent 14µs within B::opnumber which was called 5 times, avg 3µs/call:
# 5 times (14µs+0s) by B::Deparse::BEGIN@3201 at line 3202 of B/Deparse.pm, avg 3µs/call | |||||
# spent 556µs within B::perlstring which was called 246 times, avg 2µs/call:
# 149 times (332µs+0s) by Moose::Meta::TypeConstraint::Class::__ANON__[/usr/local/lib/perl/5.18.2/Moose/Meta/TypeConstraint/Class.pm:25] at line 23 of Moose/Meta/TypeConstraint/Class.pm, avg 2µs/call
# 89 times (206µs+0s) by Moose::Meta::TypeConstraint::Role::__ANON__[/usr/local/lib/perl/5.18.2/Moose/Meta/TypeConstraint/Role.pm:27] at line 23 of Moose/Meta/TypeConstraint/Role.pm, avg 2µs/call
# 8 times (17µs+0s) by Moose::Meta::Attribute::_inline_generate_default at line 915 of Moose/Meta/Attribute.pm, avg 2µs/call | |||||
# spent 1µs within B::threadsv_names which was called:
# once (1µs+0s) by YAML::XS::BEGIN@56 at line 3277 of B/Deparse.pm |