| 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 |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 48 | 6 | 4 | 140µs | 140µs | B::perlstring (xsub) |
| 1 | 1 | 1 | 8µs | 24µs | B::BEGIN@237 |
| 1 | 1 | 1 | 8µs | 8µs | B::BEGIN@12 |
| 1 | 1 | 1 | 7µs | 9µs | B::BEGIN@30 |
| 0 | 0 | 0 | 0s | 0s | B::GV::SAFENAME |
| 0 | 0 | 0 | 0s | 0s | B::IV::as_string |
| 0 | 0 | 0 | 0s | 0s | B::IV::int_value |
| 0 | 0 | 0 | 0s | 0s | B::PV::as_string |
| 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 | |||||
| 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 # 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 # 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 # 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 |