1# B::Bytecode.pm - The bytecode compiler (.plc), loaded by ByteLoader 2# 3# Copyright (c) 1994-1999 Malcolm Beattie. All rights reserved. 4# Copyright (c) 2003 Enache Adrian. All rights reserved. 5# Copyright (c) 2008-2011 Reini Urban <rurban@cpan.org>. All rights reserved. 6# Copyright (c) 2011-2015 cPanel Inc. All rights reserved. 7# This module is free software; you can redistribute and/or modify 8# it under the same terms as Perl itself. 9 10# Reviving 5.6 support here is work in progress, and not yet enabled. 11# So far the original is used instead, even if the list of failed tests 12# with the old 5.6. compiler is impressive: 3,6,8..10,12,15,16,18,25..28. 13 14package B::Bytecode; 15 16our $VERSION = '1.17'; 17 18use 5.008; 19use B qw( main_cv main_root main_start 20 begin_av init_av end_av cstring comppadlist 21 OPf_SPECIAL OPf_STACKED OPf_MOD 22 OPpLVAL_INTRO SVf_READONLY SVf_ROK ); 23use B::Assembler qw(asm newasm endasm); 24 25BEGIN { 26 if ( $] < 5.009 ) { 27 require B::Asmdata; 28 B::Asmdata->import(qw(@specialsv_name @optype)); 29 eval q[ 30 sub SVp_NOK() {}; # unused 31 sub SVf_NOK() {}; # unused 32 ]; 33 } 34 else { 35 B->import(qw(SVp_NOK SVf_NOK @specialsv_name @optype)); 36 } 37 if ( $] > 5.007 ) { 38 B->import(qw(defstash curstash inc_gv dowarn 39 warnhook diehook SVt_PVGV 40 SVf_FAKE)); 41 } else { 42 B->import(qw(walkoptree)); 43 } 44 if ($] > 5.017) { 45 B->import('SVf_IsCOW'); 46 } else { 47 eval q[sub SVf_IsCOW() {};]; # unused 48 } 49 if ($] > 5.021006) { 50 B->import('SVf_PROTECT'); 51 } else { 52 eval q[sub SVf_PROTECT() {};]; # unused 53 } 54 if ( $] >= 5.017005 ) { 55 @B::PAD::ISA = ('B::AV'); 56 } 57} 58use strict; 59use Config; 60use B::Concise; 61 62################################################# 63 64my $PERL56 = ( $] < 5.008001 ); 65my $PERL510 = ( $] >= 5.009005 ); 66my $PERL512 = ( $] >= 5.011 ); 67#my $PERL514 = ( $] >= 5.013002 ); 68my $PERL518 = ( $] >= 5.017006 ); 69my $PERL520 = ( $] >= 5.019002 ); 70my $PERL522 = ( $] >= 5.021005 ); 71my $DEBUGGING = ($Config{ccflags} =~ m/-DDEBUGGING/); 72our ($quiet, $includeall, $savebegins, $T_inhinc); 73my ( $varix, $opix, %debug, %walked, %files, @cloop ); 74my %strtab = ( 0, 0 ); 75my %svtab = ( 0, 0 ); 76my %optab = ( 0, 0 ); 77my %spectab = $PERL56 ? () : ( 0, 0 ); # we need the special Nullsv on 5.6 (?) 78my $tix = $PERL56 ? 0 : 1; 79my %ops = ( 0, 0 ); 80my @packages; # list of packages to compile. 5.6 only 81our $curcv; 82 83# sub asm ($;$$) { } 84sub nice ($) { } 85sub nice1 ($) { } 86 87my %optype_enum; 88my ($SVt_PVGV, $SVf_FAKE, $POK); 89if ($PERL56) { 90 *dowarn = sub {}; 91 $SVt_PVGV = 13; 92 $SVf_FAKE = 0x00100000; 93 $POK = 0x00040000 | 0x04000000; 94 sub MAGICAL56 { $_[0]->FLAGS & 0x000E000 } #(SVs_GMG|SVs_SMG|SVs_RMG) 95} else { 96 no strict 'subs'; 97 $SVt_PVGV = SVt_PVGV; 98 $SVf_FAKE = SVf_FAKE; 99} 100 101{ # block necessary for caller to work 102 my $caller = caller; 103 if ( $] > 5.017 and $] < 5.019004 and ($caller eq 'O' or $caller eq 'Od' )) { 104 require XSLoader; 105 XSLoader::load('B::C'); # for op->slabbed... workarounds 106 } 107 if ( $] > 5.021) { # for op_aux 108 require XSLoader; 109 XSLoader::load('B::C'); 110 } 111} 112 113for ( my $i = 0 ; $i < @optype ; $i++ ) { 114 $optype_enum{ $optype[$i] } = $i; 115} 116 117BEGIN { 118 my $ithreads = defined $Config::Config{'useithreads'} && $Config::Config{'useithreads'} eq 'define'; 119 eval qq{ 120 sub ITHREADS() { $ithreads } 121 sub VERSION() { $] } 122 }; 123 die $@ if $@; 124} 125 126sub as_hex($) {$quiet ? undef : sprintf("0x%x",shift)} 127 128# Fixes bug #307: use foreach, not each 129# each is not safe to use (at all). walksymtable is called recursively which might add 130# symbols to the stash, which might cause re-ordered rehashes, which will fool the hash 131# iterator, leading to missing symbols. 132# Old perl5 bug: The iterator should really be stored in the op, not the hash. 133sub walksymtable { 134 my ($symref, $method, $recurse, $prefix) = @_; 135 my ($sym, $ref, $fullname); 136 $prefix = '' unless defined $prefix; 137 foreach my $sym ( sort keys %$symref ) { 138 no strict 'refs'; 139 $ref = $symref->{$sym}; 140 $fullname = "*main::".$prefix.$sym; 141 if ($sym =~ /::$/) { 142 $sym = $prefix . $sym; 143 if (svref_2object(\*$sym)->NAME ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { 144 walksymtable(\%$fullname, $method, $recurse, $sym); 145 } 146 } else { 147 svref_2object(\*$fullname)->$method(); 148 } 149 } 150} 151 152################################################# 153 154# This is for -S commented assembler output 155sub op_flags($) { 156 return '' if $quiet; 157 # B::Concise::op_flags($_[0]); # too terse 158 # common flags (see BASOP.op_flags in op.h) 159 my $x = shift; 160 my (@v); 161 push @v, "WANT_VOID" if ( $x & 3 ) == 1; 162 push @v, "WANT_SCALAR" if ( $x & 3 ) == 2; 163 push @v, "WANT_LIST" if ( $x & 3 ) == 3; 164 push @v, "KIDS" if $x & 4; 165 push @v, "PARENS" if $x & 8; 166 push @v, "REF" if $x & 16; 167 push @v, "MOD" if $x & 32; 168 push @v, "STACKED" if $x & 64; 169 push @v, "SPECIAL" if $x & 128; 170 return join( ",", @v ); 171} 172 173# This is also for -S commented assembler output 174sub sv_flags($;$) { 175 return '' if $quiet or $B::Concise::VERSION < 0.74; # or ($] == 5.010); 176 return '' unless $debug{Comment}; 177 return 'B::SPECIAL' if $_[0]->isa('B::SPECIAL'); 178 return 'B::PADLIST' if $_[0]->isa('B::PADLIST'); 179 return 'B::PADNAMELIST' if $_[0]->isa('B::PADNAMELIST'); 180 return 'B::NULL' if $_[0]->isa('B::NULL'); 181 my ($sv) = @_; 182 my %h; 183 184 # TODO: Check with which Concise and B versions this works. 5.10.0 fails. 185 # B::Concise 0.66 fails also 186 *B::Concise::fmt_line = sub { return shift }; 187 my $op = $ops{ $tix - 1 }; 188 if (ref $op and !$op->targ) { # targ assumes a valid curcv 189 %h = B::Concise::concise_op( $op ); 190 } 191 B::Concise::concise_sv( $_[0], \%h, 0 ); 192} 193 194sub pvstring($) { 195 my $pv = shift; 196 defined($pv) ? cstring( $pv . "\0" ) : "\"\""; 197} 198 199sub pvix($) { 200 my $str = pvstring shift; 201 my $ix = $strtab{$str}; 202 defined($ix) ? $ix : do { 203 nice1 "-PV- $tix"; 204 B::Assembler::maxsvix($tix) if $debug{A}; 205 asm "newpv", $str; 206 asm "stpv", $strtab{$str} = $tix; 207 $tix++; 208 } 209} 210 211sub B::OP::ix($) { 212 my $op = shift; 213 my $ix = $optab{$$op}; 214 defined($ix) ? $ix : do { 215 nice "[" . $op->name . " $tix]"; 216 $ops{$tix} = $op; 217 # Note: This left-shift 7 encoding of the optype has nothing to do with OCSHIFT 218 # in opcode.pl 219 # The counterpart is hardcoded in Byteloader/bytecode.h: BSET_newopx 220 my $arg = $PERL56 ? $optype_enum{B::class($op)} : $op->size | $op->type << 7; 221 my $opsize = $PERL56 ? '?' : $op->size; 222 if (ref($op) eq 'B::OP') { # check wrong BASEOPs 223 # [perl #80622] Introducing the entrytry hack, needed since 5.12, 224 # fixed with 5.13.8 a425677 225 # ck_eval upgrades the UNOP entertry to a LOGOP, but B gets us just a 226 # B::OP (BASEOP). 227 # op->other points to the leavetry op, which is needed for the eval scope. 228 if ($op->name eq 'entertry') { 229 $opsize = $op->size + (2*$Config{ptrsize}); 230 $arg = $PERL56 ? $optype_enum{LOGOP} : $opsize | $optype_enum{LOGOP} << 7; 231 warn "[perl #80622] Upgrading entertry from BASEOP to LOGOP...\n" unless $quiet; 232 bless $op, 'B::LOGOP'; 233 } elsif ($op->name eq 'aelemfast') { 234 if (0) { 235 my $class = ITHREADS ? 'PADOP' : 'SVOP'; 236 my $type = ITHREADS ? $optype_enum{PADOP} : $optype_enum{SVOP}; 237 $opsize = $op->size + $Config{ptrsize}; 238 $arg = $PERL56 ? $type : $opsize | $type << 7; 239 warn "Upgrading aelemfast from BASEOP to $class...\n" unless $quiet; 240 bless $op, "B::$class"; 241 } 242 } elsif ($DEBUGGING) { # only needed when we want to check for new wrong BASEOP's 243 if (eval "require Opcodes;") { 244 my $class = Opcodes::opclass($op->type); 245 if ($class > 0) { 246 my $classname = $optype[$class]; 247 if ($classname) { 248 my $name = $op->name; 249 warn "Upgrading $name BASEOP to $classname...\n" unless $quiet; 250 bless $op, "B::".$classname; 251 } 252 } 253 } 254 } 255 } 256 B::Assembler::maxopix($tix) if $debug{A}; 257 asm "newopx", $arg, sprintf( "$arg=size:%s,type:%d", $opsize, $op->type ); 258 asm "stop", $tix if $PERL56; 259 $optab{$$op} = $opix = $ix = $tix++; 260 $op->bsave($ix); 261 $ix; 262 } 263} 264 265sub B::SPECIAL::ix($) { 266 my $spec = shift; 267 my $ix = $spectab{$$spec}; 268 defined($ix) ? $ix : do { 269 B::Assembler::maxsvix($tix) if $debug{A}; 270 nice "[SPECIAL $tix]"; 271 asm "ldspecsvx", $$spec, $specialsv_name[$$spec]; 272 asm "stsv", $tix if $PERL56; 273 $spectab{$$spec} = $varix = $tix++; 274 } 275} 276 277sub B::SV::ix($) { 278 my $sv = shift; 279 my $ix = $svtab{$$sv}; 280 defined($ix) ? $ix : do { 281 nice '[' . B::class($sv) . " $tix]"; 282 B::Assembler::maxsvix($tix) if $debug{A}; 283 my $flags = $sv->FLAGS; 284 my $type = $flags & 0xff; # SVTYPEMASK 285 # Set TMP_on, MY_off, not to be tidied (test 48), 286 # otherwise pad_tidy will set PADSTALE_on and assert. Since 5.16 TMP and STALE share the same bit. 287 #if (ref $sv eq 'B::NULL' and $sv->REFCNT > 1 and $] >= 5.016) { 288 # $flags |= 0x00020000; # SvPADTMP_on 289 # $flags &= ~0x00040000; # SvPADMY_off 290 #} 291 asm "newsvx", $flags, 292 $debug{Comment} ? sprintf("type=%d,flags=0x%x,%s", $type, $flags, sv_flags($sv)) : ''; 293 asm "stsv", $tix if $PERL56; 294 $svtab{$$sv} = $varix = $ix = $tix++; 295 $sv->bsave($ix); 296 $ix; 297 } 298} 299 300#sub B::PAD::ix($) { 301# my $sv = shift; 302# #if ($PERL522) { 303# # my $ix = $svtab{$$sv}; 304# # defined($ix) ? $ix : do { 305# # nice '[' . B::class($sv) . " $tix]"; 306# # B::Assembler::maxsvix($tix) if $debug{A}; 307# # asm "newpadx", 0, 308# # $debug{Comment} ? sprintf("pad_new(flags=0x%x)", 0) : ''; 309# # $svtab{$$sv} = $varix = $ix = $tix++; 310# # $sv->bsave($ix); 311# # $ix; 312# # } 313# #} else { 314# if ($$sv) { 315# bless $sv, 'B::AV'; 316# return $sv->B::SV::ix; 317# } else { 318# 0 319# } 320#} 321 322# since 5.18 323sub B::PADLIST::ix($) { 324 my $padl = shift; 325 my $ix = $svtab{$$padl}; 326 defined($ix) ? $ix : do { 327 nice '[' . B::class($padl) . " $tix]"; 328 B::Assembler::maxsvix($tix) if $debug{A}; 329 asm "newpadlx", 0, 330 $debug{Comment} ? sprintf("pad_new(flags=0x%x)", 0) : ''; 331 $svtab{$$padl} = $varix = $ix = $tix++; 332 $padl->bsave($ix); 333 $ix; 334 } 335} 336 337sub B::PADNAME::ix { 338 my $pn = shift; 339 my $ix = $svtab{$$pn}; 340 defined($ix) ? $ix : do { 341 nice '[' . B::class($pn) . " $tix]"; 342 B::Assembler::maxsvix($tix) if $debug{A}; 343 my $pv = $pn->PVX; 344 asm "newpadnx", $pv ? cstring $pv : ""; 345 $svtab{$$pn} = $varix = $ix = $tix++; 346 $pn->bsave($ix); 347 $ix; 348 } 349} 350 351sub B::PADNAMELIST::ix { 352 my $padnl = shift; 353 if (!$PERL522) { 354 return B::SV::ix(bless $padnl, 'B::AV'); 355 } else { 356 my $ix = $svtab{$$padnl}; 357 defined($ix) ? $ix : do { 358 nice '[' . B::class($padnl) . " $tix]"; 359 B::Assembler::maxsvix($tix) if $debug{A}; 360 my $max = $padnl->MAX; 361 asm "newpadnlx", $max, 362 $debug{Comment} ? sprintf("size=%d, %s", $max+1, sv_flags($padnl)) : ''; 363 $svtab{$$padnl} = $varix = $ix = $tix++; 364 $padnl->bsave($ix); 365 $ix; 366 } 367 } 368} 369 370sub B::GV::ix { 371 my ( $gv, $desired ) = @_; 372 my $ix = $svtab{$$gv}; 373 defined($ix) ? $ix : do { 374 if ( $debug{G} and !$PERL510 ) { 375 select *STDERR; 376 eval "require B::Debug;"; 377 $gv->B::GV::debug; 378 select *STDOUT; 379 } 380 if ( ( $PERL510 and $gv->isGV_with_GP ) 381 or ( !$PERL510 and !$PERL56 and $gv->GP ) ) 382 { # only gv with gp 383 my ( $svix, $avix, $hvix, $cvix, $ioix, $formix ); 384 # 510 without debugging misses B::SPECIAL::NAME 385 my $name; 386 if ( $PERL510 387 and ( $gv->STASH->isa('B::SPECIAL') or $gv->isa('B::SPECIAL') ) ) 388 { 389 $name = '_'; 390 nice '[GV] # "_"'; 391 return 0; 392 } 393 else { 394 $name = $gv->STASH->NAME . "::" 395 . ( B::class($gv) eq 'B::SPECIAL' ? '_' : $gv->NAME ); 396 } 397 nice "[GV $tix]"; 398 B::Assembler::maxsvix($tix) if $debug{A}; 399 asm "gv_fetchpvx", cstring $name; 400 asm "stsv", $tix if $PERL56; 401 $svtab{$$gv} = $varix = $ix = $tix++; 402 asm "sv_flags", $gv->FLAGS, as_hex($gv->FLAGS); 403 asm "sv_refcnt", $gv->REFCNT; 404 asm "xgv_flags", $gv->GvFLAGS, as_hex($gv->GvFLAGS); 405 406 asm "gp_refcnt", $gv->GvREFCNT; 407 asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob"; 408 return $ix 409 unless $desired || desired $gv; 410 $svix = $gv->SV->ix; 411 $avix = $gv->AV->ix; 412 $hvix = $gv->HV->ix; 413 414 # XXX {{{{ 415 my $cv = $gv->CV; 416 $cvix = $$cv && defined $files{ $cv->FILE } ? $cv->ix : 0; 417 my $form = $gv->FORM; 418 $formix = $$form && defined $files{ $form->FILE } ? $form->ix : 0; 419 420 $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0; 421 422 # }}}} XXX 423 424 nice1 "-GP-", asm "ldsv", $varix = $ix, sv_flags($gv) unless $ix == $varix; 425 asm "gp_sv", $svix, sv_flags( $gv->SV ) if $svix; 426 asm "gp_av", $avix, sv_flags( $gv->AV ) if $avix; 427 asm "gp_hv", $hvix, sv_flags( $gv->HV ) if $hvix; 428 asm "gp_cv", $cvix, sv_flags( $gv->CV ) if $cvix; 429 asm "gp_io", $ioix if $ioix; 430 asm "gp_cvgen", $gv->CVGEN if $gv->CVGEN; 431 asm "gp_form", $formix if $formix; 432 asm "gp_file", pvix $gv->FILE; 433 asm "gp_line", $gv->LINE if $gv->LINE; 434 asm "formfeed", $svix if $name eq "main::\cL"; 435 } 436 else { 437 nice "[GV $tix]"; 438 B::Assembler::maxsvix($tix) if $debug{A}; 439 asm "newsvx", $gv->FLAGS, $debug{Comment} ? sv_flags($gv) : ''; 440 asm "stsv", $tix if $PERL56; 441 $svtab{$$gv} = $varix = $ix = $tix++; 442 if ( !$PERL510 ) { 443 asm "xgv_flags", $gv->GvFLAGS; # GV_without_GP has no GvFlags 444 } 445 if ( !$PERL510 and !$PERL56 and $gv->STASH ) { 446 my $stashix = $gv->STASH->ix; 447 asm "xgv_stash", $stashix; 448 } 449 if ($PERL510 and $gv->FLAGS & 0x40000000) { # SVpbm_VALID 450 my $bm = bless $gv, "B::BM"; 451 $bm->bsave($ix); # also saves magic 452 } else { 453 $gv->B::PVMG::bsave($ix); 454 } 455 } 456 $ix; 457 } 458} 459 460sub B::HV::ix { 461 my $hv = shift; 462 my $ix = $svtab{$$hv}; 463 defined($ix) ? $ix : do { 464 my ( $ix, $i, @array ); 465 my $name = $hv->NAME; 466 my $flags = $hv->FLAGS & ~SVf_READONLY; 467 $flags &= ~SVf_PROTECT if $PERL522; 468 if ($name) { 469 nice "[STASH $tix]"; 470 B::Assembler::maxsvix($tix) if $debug{A}; 471 asm "gv_stashpvx", cstring $name; 472 asm "ldsv", $tix if $PERL56; 473 asm "sv_flags", $flags, as_hex($flags); 474 $svtab{$$hv} = $varix = $ix = $tix++; 475 asm "xhv_name", pvix $name; 476 477 # my $pmrootix = $hv->PMROOT->ix; # XXX 478 asm "ldsv", $varix = $ix unless $ix == $varix; 479 # asm "xhv_pmroot", $pmrootix; # XXX 480 } 481 else { 482 nice "[HV $tix]"; 483 B::Assembler::maxsvix($tix) if $debug{A}; 484 asm "newsvx", $flags, $debug{Comment} ? sv_flags($hv) : ''; 485 asm "stsv", $tix if $PERL56; 486 $svtab{$$hv} = $varix = $ix = $tix++; 487 my $stash = $hv->SvSTASH; 488 my $stashix = $stash ? $hv->SvSTASH->ix : 0; 489 for ( @array = $hv->ARRAY ) { 490 next if $i = not $i; 491 $_ = $_->ix; 492 } 493 nice1 "-HV-", asm "ldsv", $varix = $ix unless $ix == $varix; 494 ( $i = not $i ) ? asm( "newpv", pvstring $_) : asm( "hv_store", $_ ) 495 for @array; 496 if ( VERSION < 5.009 ) { 497 asm "xnv", $hv->NVX; 498 } 499 asm "xmg_stash", $stashix if $stashix; 500 asm( "xhv_riter", $hv->RITER ) if VERSION < 5.009; 501 } 502 asm "sv_refcnt", $hv->REFCNT if $hv->REFCNT != 1; 503 asm "sv_flags", $hv->FLAGS, as_hex($hv->FLAGS) if $hv->FLAGS & SVf_READONLY; 504 $ix; 505 } 506} 507 508sub B::NULL::ix { 509 my $sv = shift; 510 $$sv ? $sv->B::SV::ix : 0; 511} 512 513sub B::NULL::opwalk { 0 } 514 515################################################# 516 517sub B::NULL::bsave { 518 my ( $sv, $ix ) = @_; 519 520 nice '-' . B::class($sv) . '-', asm "ldsv", $varix = $ix, sv_flags($sv) 521 unless $ix == $varix; 522 if ($PERL56) { 523 asm "stsv", $ix; 524 } else { 525 asm "sv_refcnt", $sv->REFCNT if $sv->REFCNT != 1; 526 } 527} 528 529sub B::SV::bsave; 530*B::SV::bsave = *B::NULL::bsave; 531 532sub B::RV::bsave($$) { 533 my ( $sv, $ix ) = @_; 534 my $rvix = $sv->RV->ix; 535 $sv->B::NULL::bsave($ix); 536 # RV with DEBUGGING already requires sv_flags before SvRV_set 537 my $flags = $sv->FLAGS; 538 $flags &= ~0x8000 if $flags & $SVt_PVGV and $PERL522; # no SVpgv_GP 539 asm "sv_flags", $flags, as_hex($flags); 540 asm "xrv", $rvix; 541} 542 543sub B::PV::bsave($$) { 544 my ( $sv, $ix ) = @_; 545 $sv->B::NULL::bsave($ix); 546 return unless $sv; 547 if ($PERL56) { 548 #$sv->B::SV::bsave; 549 if ($sv->FLAGS & $POK) { 550 asm "newpv", pvstring $sv->PV; 551 asm "xpv"; 552 } 553 } elsif ($PERL518 and (($sv->FLAGS & SVf_IsCOW) == SVf_IsCOW)) { # COW 554 asm "newpv", pvstring $sv->PV; 555 asm "xpvshared"; 556 } elsif ($PERL510 and (($sv->FLAGS & 0x09000000) == 0x09000000)) { # SHARED 557 if ($sv->FLAGS & 0x40000000 and !($sv->FLAGS & 0x00008000)) { # pbm_VALID, !SCREAM 558 asm "newpv", pvstring $sv->PVBM; 559 } else { 560 asm "newpv", pvstring $sv->PV; 561 } 562 asm "xpvshared"; 563 } elsif ($PERL510 and $sv->FLAGS & 0x40000000 and !($sv->FLAGS & 0x00008000)) { # pbm_VALID, !SCREAM 564 asm "newpv", pvstring $sv->PVBM; 565 asm "xpv"; 566 } else { 567 asm "newpv", pvstring $sv->PV; 568 asm "xpv"; 569 } 570} 571 572sub B::IV::bsave($$) { 573 my ( $sv, $ix ) = @_; 574 return $sv->B::RV::bsave($ix) 575 if $PERL512 and $sv->FLAGS & B::SVf_ROK; 576 $sv->B::NULL::bsave($ix); 577 if ($PERL56) { 578 asm $sv->needs64bits ? "xiv64" : "xiv32", $sv->IVX; 579 } else { 580 asm "xiv", $sv->IVX; 581 } 582} 583 584sub B::NV::bsave($$) { 585 my ( $sv, $ix ) = @_; 586 $sv->B::NULL::bsave($ix); 587 asm "xnv", sprintf "%.40g", $sv->NVX; 588} 589 590sub B::PVIV::bsave($$) { 591 my ( $sv, $ix ) = @_; 592 if ($PERL56) { 593 $sv->B::PV::bsave($ix); 594 } else { 595 $sv->POK ? $sv->B::PV::bsave($ix) 596 : $sv->ROK ? $sv->B::RV::bsave($ix) 597 : $sv->B::NULL::bsave($ix); 598 } 599 if ($PERL510) { # See note below in B::PVNV::bsave 600 return if $sv->isa('B::AV'); 601 return if $sv->isa('B::HV'); 602 return if $sv->isa('B::CV'); 603 return if $sv->isa('B::GV'); 604 return if $sv->isa('B::IO'); 605 return if $sv->isa('B::FM'); 606 } 607 bwarn( sprintf( "PVIV sv:%s flags:0x%x", B::class($sv), $sv->FLAGS ) ) 608 if $debug{M}; 609 610 if ($PERL56) { 611 my $iv = $sv->IVX; 612 asm $sv->needs64bits ? "xiv64" : "xiv32", $iv; 613 } else { 614 # PVIV GV 8009, GV flags & (4000|8000) illegal (SVpgv_GP|SVp_POK) 615 asm "xiv", !ITHREADS 616 && (($sv->FLAGS & ($SVf_FAKE|SVf_READONLY)) == ($SVf_FAKE|SVf_READONLY)) 617 ? "0 # but true" : $sv->IVX; 618 } 619} 620 621sub B::PVNV::bsave($$) { 622 my ( $sv, $ix ) = @_; 623 $sv->B::PVIV::bsave($ix); 624 if ($PERL510) { 625 # getting back to PVMG 626 return if $sv->isa('B::AV'); 627 return if $sv->isa('B::HV'); 628 return if $sv->isa('B::CV'); 629 return if $sv->isa('B::FM'); 630 return if $sv->isa('B::GV'); 631 return if $sv->isa('B::IO'); 632 633 # cop_seq range instead of a double. (IV, NV) 634 unless ($PERL522 or $sv->FLAGS & (SVf_NOK|SVp_NOK)) { 635 asm "cop_seq_low", $sv->COP_SEQ_RANGE_LOW; 636 asm "cop_seq_high", $sv->COP_SEQ_RANGE_HIGH; 637 return; 638 } 639 } 640 asm "xnv", sprintf "%.40g", $sv->NVX; 641} 642 643sub B::PVMG::domagic($$) { 644 my ( $sv, $ix ) = @_; 645 nice1 '-MAGICAL-'; # no empty line before 646 my @mglist = $sv->MAGIC; 647 my ( @mgix, @namix ); 648 for (@mglist) { 649 my $mg = $_; 650 push @mgix, $_->OBJ->ix; 651 push @namix, $mg->PTR->ix if $mg->LENGTH == B::HEf_SVKEY; 652 $_ = $mg; 653 } 654 655 nice1 '-' . B::class($sv) . '-', asm "ldsv", $varix = $ix unless $ix == $varix; 656 for (@mglist) { 657 next unless ord($_->TYPE); 658 asm "sv_magic", ord($_->TYPE), cstring $_->TYPE; 659 asm "mg_obj", shift @mgix; # D sets itself, see mg.c:mg_copy 660 my $length = $_->LENGTH; 661 if ( $length == B::HEf_SVKEY and !$PERL56) { 662 asm "mg_namex", shift @namix; 663 } 664 elsif ($length) { 665 asm "newpv", pvstring $_->PTR; 666 $PERL56 667 ? asm "mg_pv" 668 : asm "mg_name"; 669 } 670 } 671} 672 673sub B::PVMG::bsave($$) { 674 my ( $sv, $ix ) = @_; 675 my $stashix = $sv->SvSTASH->ix; 676 $sv->B::PVNV::bsave($ix); 677 asm "xmg_stash", $stashix if $stashix; 678 # XXX added SV->MAGICAL to 5.6 for compat 679 $sv->domagic($ix) if $PERL56 ? MAGICAL56($sv) : $sv->MAGICAL; 680} 681 682sub B::PVLV::bsave($$) { 683 my ( $sv, $ix ) = @_; 684 my $targix = $sv->TARG->ix; 685 $sv->B::PVMG::bsave($ix); 686 asm "xlv_targ", $targix unless $PERL56; # XXX really? xlv_targ IS defined 687 asm "xlv_targoff", $sv->TARGOFF; 688 asm "xlv_targlen", $sv->TARGLEN; 689 asm "xlv_type", $sv->TYPE; 690} 691 692sub B::BM::bsave($$) { 693 my ( $sv, $ix ) = @_; 694 $sv->B::PVMG::bsave($ix); 695 asm "xpv_cur", $sv->CUR if $] > 5.008; 696 asm "xbm_useful", $sv->USEFUL; 697 asm "xbm_previous", $sv->PREVIOUS; 698 asm "xbm_rare", $sv->RARE; 699} 700 701sub B::IO::bsave($$) { 702 my ( $io, $ix ) = @_; 703 my $topix = $io->TOP_GV->ix; 704 my $fmtix = $io->FMT_GV->ix; 705 my $bottomix = $io->BOTTOM_GV->ix; 706 $io->B::PVMG::bsave($ix); 707 asm "xio_lines", $io->LINES; 708 asm "xio_page", $io->PAGE; 709 asm "xio_page_len", $io->PAGE_LEN; 710 asm "xio_lines_left", $io->LINES_LEFT; 711 asm "xio_top_name", pvix $io->TOP_NAME; 712 asm "xio_top_gv", $topix; 713 asm "xio_fmt_name", pvix $io->FMT_NAME; 714 asm "xio_fmt_gv", $fmtix; 715 asm "xio_bottom_name", pvix $io->BOTTOM_NAME; 716 asm "xio_bottom_gv", $bottomix; 717 asm "xio_subprocess", $io->SUBPROCESS unless $PERL510; 718 asm "xio_type", ord $io->IoTYPE; 719 if ($PERL56) { # do not mess with PerlIO 720 asm "xio_flags", $io->IoFLAGS; 721 } else { 722 # XXX IOf_NOLINE off was added with 5.8, but not used (?) 723 asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX IOf_NOLINE 32 724 } 725 # issue93: restore std handles 726 if (!$PERL56) { 727 my $o = $io->object_2svref(); 728 eval "require ".ref($o).";"; 729 my $fd = $o->fileno(); 730 # use IO::Handle (); 731 # my $fd = IO::Handle::fileno($o); 732 bwarn( "io ix=$ix perlio no fileno for ".ref($o) ) if $fd < 0; 733 my $i = 0; 734 foreach (qw(stdin stdout stderr)) { 735 if ($io->IsSTD($_) or $fd == -$i) { # negative stdout = error 736 nice1 "-perlio_$_($fd)-"; 737 # bwarn( "io $ix perlio_$_($fd)" ); 738 asm "xio_flags", $io->IoFLAGS; 739 asm "xio_ifp", $i; 740 } 741 $i++; 742 } 743 } 744} 745 746sub B::CV::bsave($$) { 747 my ( $cv, $ix ) = @_; 748 $B::Bytecode::curcv = $cv; 749 my $stashix = $cv->STASH->ix; 750 my $gvix = ($cv->GV and ref($cv->GV) ne 'B::SPECIAL') ? $cv->GV->ix : 0; 751 my $padlistix = $cv->PADLIST->ix; 752 my $outsideix = $cv->OUTSIDE->ix; 753 # there's no main_cv->START optree since 5.18 754 my $startix = $cv->START->opwalk if $] < 5.018 or $$cv != ${main_cv()}; 755 my $rootix = $cv->ROOT->ix; 756 # TODO 5.14 will need CvGV_set to add backref magic 757 my $xsubanyix = ($cv->CONST and !$PERL56) ? $cv->XSUBANY->ix : 0; 758 759 $cv->B::PVMG::bsave($ix); 760 asm "xcv_stash", $stashix if $stashix; 761 asm "xcv_start", $startix if $startix; # e.g. main_cv 5.18 762 asm "xcv_root", $rootix if $rootix; 763 asm "xcv_xsubany", $xsubanyix if !$PERL56 and $xsubanyix; 764 asm "xcv_padlist", $padlistix; 765 asm "xcv_outside", $outsideix if $outsideix; 766 asm "xcv_outside_seq", $cv->OUTSIDE_SEQ if !$PERL56 and $cv->OUTSIDE_SEQ; 767 asm "xcv_depth", $cv->DEPTH if $cv->DEPTH; 768 # add the RC flag if there's no backref magic. eg END (48) 769 my $cvflags = $cv->CvFLAGS; 770 $cvflags |= 0x400 if $] >= 5.013 and !$cv->MAGIC; 771 asm "xcv_flags", $cvflags; 772 if ($gvix) { 773 asm "xcv_gv", $gvix; 774 } elsif ($] >= 5.018001 and $cv->NAME_HEK) { # ignore main_cv 775 asm "xcv_name_hek", pvix $cv->NAME_HEK; # set name_hek for lexsub (#130) 776 #} elsif ($] >= 5.017004) { # 5.18.0 empty name, missing B API 777 # asm "xcv_name_hek", pvix "_"; 778 } 779 asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD 780} 781 782sub B::FM::bsave($$) { 783 my ( $form, $ix ) = @_; 784 785 $form->B::CV::bsave($ix); 786 asm "xfm_lines", $form->LINES; 787} 788 789# an AV or padl_sym 790sub B::PAD::bsave($$) { 791 my ( $av, $ix ) = @_; 792 my @array = $av->ARRAY; 793 $_ = $_->ix for @array; # save the elements 794 $av->B::NULL::bsave($ix); 795 my $fill = scalar @array; 796 asm "av_extend", $fill if @array; 797 if ($fill > 1 or $array[0]) { 798 asm "av_pushx", $_ for @array; 799 } 800} 801 802sub B::AV::bsave { 803 my ( $av, $ix ) = @_; 804 if (!$PERL56 and $av->MAGICAL) { 805 $av->B::PVMG::bsave($ix); 806 for ($av->MAGIC) { 807 return if $_->TYPE eq 'P'; # 'P' tied AV has no ARRAY/FETCHSIZE,..., test 16 808 # but e.g. 'I' (@ISA) has 809 } 810 } 811 my @array = $av->ARRAY; 812 $_ = $_->ix for @array; # hack. walks the ->ix methods to save the elements 813 my $stashix = $av->SvSTASH->ix; 814 nice "-AV-", 815 asm "ldsv", $varix = $ix, sv_flags($av) unless $ix == $varix; 816 817 if ($PERL56) { 818 # SvREADONLY_off($av) w PADCONST 819 asm "sv_flags", $av->FLAGS & ~SVf_READONLY, as_hex($av->FLAGS); 820 $av->domagic($ix) if MAGICAL56($av); 821 asm "xav_flags", $av->AvFLAGS, as_hex($av->AvFLAGS); 822 asm "xav_max", -1; 823 asm "xav_fill", -1; 824 if ($av->FILL > -1) { 825 asm "av_push", $_ for @array; 826 } else { 827 asm "av_extend", $av->MAX if $av->MAX >= 0 and $av->{ref} ne 'PAD'; 828 } 829 asm "sv_flags", $av->FLAGS if $av->FLAGS & SVf_READONLY; # restore flags 830 } else { 831 #$av->domagic($ix) if $av->MAGICAL; # XXX need tests for magic arrays 832 asm "av_extend", $av->MAX if $av->MAX >= 0; 833 asm "av_pushx", $_ for @array; 834 if ( !$PERL510 ) { # VERSION < 5.009 835 asm "xav_flags", $av->AvFLAGS, as_hex($av->AvFLAGS); 836 } 837 # asm "xav_alloc", $av->AvALLOC if $] > 5.013002; # XXX new but not needed 838 } 839 asm "sv_refcnt", $av->REFCNT if $av->REFCNT != 1; 840 asm "xmg_stash", $stashix if $stashix; 841} 842 843# since 5.18 844sub B::PADLIST::bsave { 845 my ( $padl, $ix ) = @_; 846 my @array = $padl->ARRAY; 847 my $max = scalar @array; 848 bless $array[0], 'B::PADNAMELIST' if ref $array[0] eq 'B::AV'; 849 bless $array[1], 'B::PAD' if ref $array[1] eq 'B::AV'; 850 my $pnl = $array[0]->ix; # padnamelist 851 my $pad = $array[1]->ix; # pad syms 852 nice "-PADLIST-", 853 asm "ldsv", $varix = $ix unless $ix == $varix; 854 asm "padl_name", $pnl; 855 asm "padl_sym", $pad; 856 if ($PERL522) { 857 asm "padl_id", $padl->id if $padl->id; 858 # 5.18-20 has no PADLIST->outid API, uses xcv_outside instead 859 asm "padl_outid", $padl->outid if $padl->outid; 860 } 861} 862 863# since 5.22 864sub B::PADNAME::bsave { 865 my ( $pn, $ix ) = @_; 866 my $stashix = $pn->OURSTASH->ix; 867 my $typeix = $pn->TYPE->ix; 868 nice "-PADNAME-", 869 asm "ldsv", $varix = $ix unless $ix == $varix; 870 asm "padn_pv", cstring $pn->PV if $pn->LEN; 871 my $flags = $pn->FLAGS; 872 asm "padn_stash", $stashix if $stashix; 873 asm "padn_type", $typeix if $typeix; 874 asm "padn_flags", $flags & 0xff if $flags & 0xff; # turn of SVf_FAKE, U8 only 875 asm "padn_seq_low", $pn->COP_SEQ_RANGE_LOW; 876 asm "padn_seq_high", $pn->COP_SEQ_RANGE_HIGH; 877 asm "padn_refcnt", $pn->REFCNT if $pn->REFCNT != 1; 878 #asm "padn_len", $pn->LEN if $pn->LEN; 879} 880 881# since 5.22 882sub B::PADNAMELIST::bsave { 883 my ( $padnl, $ix ) = @_; 884 my @array = $padnl->ARRAY; 885 $_ = $_->ix for @array; 886 nice "-PADNAMELIST-", 887 asm "ldsv", $varix = $ix unless $ix == $varix; 888 asm "padnl_push", $_ for @array; 889} 890 891sub B::GV::desired { 892 my $gv = shift; 893 my ( $cv, $form ); 894 if ( $debug{Gall} and !$PERL510 ) { 895 select *STDERR; 896 eval "require B::Debug;"; 897 $gv->debug; 898 select *STDOUT; 899 } 900 $files{ $gv->FILE } && $gv->LINE 901 || ${ $cv = $gv->CV } && $files{ $cv->FILE } 902 || ${ $form = $gv->FORM } && $files{ $form->FILE }; 903} 904 905sub B::HV::bwalk { 906 my $hv = shift; 907 return if $walked{$$hv}++; 908 my %stash = $hv->ARRAY; 909 #while ( my ( $k, $v ) = each %stash ) 910 foreach my $k (keys %stash) { 911 my $v = $stash{$k}; 912 if ( !$PERL56 and $v->SvTYPE == $SVt_PVGV ) { # XXX ref $v eq 'B::GV' 913 my $hash = $v->HV if $v->can("HV"); 914 if ( $hash and $$hash && $hash->NAME ) { 915 $hash->bwalk; 916 } 917 # B since 5.13.6 (744aaba0598) pollutes our namespace. Keep it clean 918 # XXX This fails if our source really needs any B constant 919 unless ($] > 5.013005 and $hv->NAME eq 'B') { 920 $v->ix(1) if $v->can("desired") and desired $v; 921 } 922 } 923 else { 924 if ($] > 5.013005 and $hv->NAME eq 'B') { # see above. omit B prototypes 925 return; 926 } 927 nice "[prototype $tix]"; 928 B::Assembler::maxsvix($tix) if $debug{A}; 929 asm "gv_fetchpvx", cstring ($hv->NAME . "::" . $k); 930 $svtab{$$v} = $varix = $tix; 931 # we need the sv_flags before, esp. for DEBUGGING asserts 932 asm "sv_flags", $v->FLAGS, as_hex($v->FLAGS); 933 $v->bsave( $tix++ ); 934 } 935 } 936} 937 938###################################################### 939 940sub B::OP::bsave_thin { 941 my ( $op, $ix ) = @_; 942 bwarn( B::peekop($op), ", ix: $ix" ) if $debug{o}; 943 my $next = $op->next; 944 my $nextix = $optab{$$next}; 945 $nextix = 0, push @cloop, $op unless defined $nextix; 946 if ( $ix != $opix ) { 947 nice '-' . $op->name . '-', asm "ldop", $opix = $ix; 948 } 949 asm "op_flags", $op->flags, op_flags( $op->flags ) if $op->flags; 950 asm "op_next", $nextix; 951 asm "op_targ", $op->targ if $op->type and $op->targ; # tricky 952 asm "op_private", $op->private if $op->private; # private concise flags? 953 if ($] >= 5.017 and $op->can('slabbed')) { 954 asm "op_slabbed", $op->slabbed if $op->slabbed; 955 asm "op_savefree", $op->savefree if $op->savefree; 956 asm "op_static", $op->static if $op->static; 957 if ($] >= 5.019002 and $op->can('folded')) { 958 asm "op_folded", $op->folded if $op->folded; 959 } 960 if ($] >= 5.021002 and $] < 5.021011 and $op->can('lastsib')) { 961 asm "op_lastsib", $op->lastsib if $op->lastsib; 962 } 963 elsif ($] >= 5.021011 and $op->can('moresib')) { 964 asm "op_moresib", $op->moresib if $op->moresib; 965 } 966 } 967} 968 969sub B::OP::bsave; 970*B::OP::bsave = *B::OP::bsave_thin; 971 972sub B::UNOP::bsave { 973 my ( $op, $ix ) = @_; 974 my $name = $op->name; 975 my $flags = $op->flags; 976 my $first = $op->first; 977 my $firstix = $name =~ /fl[io]p/ 978 979 # that's just neat 980 || ( !ITHREADS && $name eq 'regcomp' ) 981 982 # trick for /$a/o in pp_regcomp 983 || $name eq 'rv2sv' 984 && $op->flags & OPf_MOD 985 && $op->private & OPpLVAL_INTRO 986 987 # change #18774 (localref) made my life hard (commit 82d039840b913b4) 988 ? $first->ix 989 : 0; 990 991 # XXX Are there more new UNOP's with first? 992 $firstix = $first->ix if $name eq 'require'; #issue 97 993 $op->B::OP::bsave($ix); 994 asm "op_first", $firstix; 995} 996 997sub B::UNOP_AUX::bsave { 998 my ( $op, $ix ) = @_; 999 my $name = $op->name; 1000 my $flags = $op->flags; 1001 my $first = $op->first; 1002 my $firstix = $first->ix; 1003 my $aux = $op->aux; 1004 my @aux_list = $op->aux_list($B::Bytecode::curcv); 1005 for my $item (@aux_list) { 1006 $item->ix if ref $item; 1007 } 1008 $op->B::OP::bsave($ix); 1009 asm "op_first", $firstix; 1010 asm "unop_aux", cstring $op->aux; 1011} 1012 1013sub B::METHOP::bsave($$) { 1014 my ( $op, $ix ) = @_; 1015 my $name = $op->name; 1016 my $firstix = $name eq 'method' ? $op->first->ix : $op->meth_sv->ix; 1017 my $rclass = $op->rclass->ix; 1018 $op->B::OP::bsave($ix); 1019 if ($op->name eq 'method') { 1020 asm "op_first", $firstix; 1021 } else { 1022 asm "methop_methsv", $firstix; 1023 } 1024 asm "methop_rclass", $rclass if $rclass or ITHREADS; # padoffset 0 valid threaded 1025} 1026 1027sub B::BINOP::bsave($$) { 1028 my ( $op, $ix ) = @_; 1029 if ( $op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH() ) { 1030 my $last = $op->last; 1031 my $lastix = do { 1032 local *B::OP::bsave = *B::OP::bsave_fat; 1033 local *B::UNOP::bsave = *B::UNOP::bsave_fat; 1034 #local *B::BINOP::bsave = *B::BINOP::bsave_fat; 1035 $last->ix; 1036 }; 1037 asm "ldop", $lastix unless $lastix == $opix; 1038 asm "op_targ", $last->targ; 1039 $op->B::OP::bsave($ix); 1040 asm "op_last", $lastix; 1041 } 1042 else { 1043 $op->B::OP::bsave($ix); 1044 } 1045} 1046 1047# not needed if no pseudohashes 1048 1049*B::BINOP::bsave = *B::OP::bsave if $PERL510; #VERSION >= 5.009; 1050 1051# deal with sort / formline 1052 1053sub B::LISTOP::bsave($$) { 1054 my ( $op, $ix ) = @_; 1055 bwarn( B::peekop($op), ", ix: $ix" ) if $debug{o}; 1056 my $name = $op->name; 1057 sub blocksort() { OPf_SPECIAL | OPf_STACKED } 1058 if ( $name eq 'sort' && ( $op->flags & blocksort ) == blocksort ) { 1059 # Note: 5.21.2 PERL_OP_PARENT support work in progress 1060 my $first = $op->first; 1061 my $pushmark = $first->sibling; # XXX may be B::NULL 1062 my $rvgv = $pushmark->first; 1063 my $leave = $rvgv->first; 1064 1065 my $leaveix = $leave->ix; 1066 #asm "comment", "leave" unless $quiet; 1067 1068 my $rvgvix = $rvgv->ix; 1069 asm "ldop", $rvgvix unless $rvgvix == $opix; 1070 #asm "comment", "rvgv" unless $quiet; 1071 asm "op_first", $leaveix; 1072 1073 my $pushmarkix = $pushmark->ix; 1074 asm "ldop", $pushmarkix unless $pushmarkix == $opix; 1075 #asm "comment", "pushmark" unless $quiet; 1076 asm "op_first", $rvgvix; 1077 1078 my $firstix = $first->ix; 1079 asm "ldop", $firstix unless $firstix == $opix; 1080 #asm "comment", "first" unless $quiet; 1081 asm "op_sibling", $pushmarkix if $first->has_sibling; 1082 1083 $op->B::OP::bsave($ix); 1084 asm "op_first", $firstix; 1085 } 1086 elsif ( $name eq 'formline' ) { 1087 $op->B::UNOP::bsave_fat($ix); 1088 } 1089 elsif ( $name eq 'dbmopen' ) { 1090 require AnyDBM_File; 1091 $op->B::OP::bsave($ix); 1092 } 1093 else { 1094 $op->B::OP::bsave($ix); 1095 } 1096} 1097 1098# fat versions 1099 1100# or parent since 5.22 1101sub B::OP::has_sibling($) { 1102 my $op = shift; 1103 return $op->moresib if $op->can('moresib'); #5.22 1104 return $op->lastsib if $op->can('lastsib'); #5.21 1105 return 1; 1106} 1107 1108sub B::OP::bsave_fat($$) { 1109 my ( $op, $ix ) = @_; 1110 1111 if ($op->has_sibling) { 1112 my $sibling = $op->sibling; # might be B::NULL with 5.22 and PERL_OP_PARENT 1113 my $siblix = $sibling->ix; 1114 $op->B::OP::bsave_thin($ix); 1115 asm "op_sibling", $siblix; 1116 } elsif ($] > 5.021011 and ref($op->parent) ne 'B::NULL') { 1117 my $parent = $op->parent; 1118 my $pix = $parent->ix; 1119 $op->B::OP::bsave_thin($ix); 1120 asm "op_sibling", $pix; # but renamed to op_sibparent 1121 } else { 1122 $op->B::OP::bsave_thin($ix); 1123 } 1124 # asm "op_seq", -1; XXX don't allocate OPs piece by piece 1125} 1126 1127sub B::UNOP::bsave_fat { 1128 my ( $op, $ix ) = @_; 1129 my $firstix = $op->first->ix; 1130 1131 $op->B::OP::bsave($ix); 1132 asm "op_first", $firstix; 1133} 1134 1135sub B::BINOP::bsave_fat { 1136 my ( $op, $ix ) = @_; 1137 my $last = $op->last; 1138 my $lastix = $op->last->ix; 1139 bwarn( B::peekop($op), ", ix: $ix $last: $last, lastix: $lastix" ) 1140 if $debug{o}; 1141 if ( !$PERL510 && $op->name eq 'aassign' && $last->name eq 'null' ) { 1142 asm "ldop", $lastix unless $lastix == $opix; 1143 asm "op_targ", $last->targ; 1144 } 1145 1146 $op->B::UNOP::bsave($ix); 1147 asm "op_last", $lastix; 1148} 1149 1150sub B::LOGOP::bsave { 1151 my ( $op, $ix ) = @_; 1152 my $otherix = $op->other->ix; 1153 bwarn( B::peekop($op), ", ix: $ix" ) if $debug{o}; 1154 1155 $op->B::UNOP::bsave($ix); 1156 asm "op_other", $otherix; 1157} 1158 1159sub B::PMOP::bsave { 1160 my ( $op, $ix ) = @_; 1161 my ( $rrop, $rrarg, $rstart ); 1162 1163 # my $pmnextix = $op->pmnext->ix; # XXX 1164 bwarn( B::peekop($op), " ix: $ix" ) if $debug{M} or $debug{o}; 1165 if (ITHREADS) { 1166 if ( $op->name eq 'subst' ) { 1167 $rrop = "op_pmreplroot"; 1168 $rrarg = $op->pmreplroot->ix; 1169 $rstart = $op->pmreplstart->ix; 1170 } 1171 elsif ( $op->name eq 'pushre' ) { 1172 $rrarg = $op->pmreplroot; 1173 $rrop = "op_pmreplrootpo"; 1174 } 1175 $op->B::BINOP::bsave($ix); 1176 if ( !$PERL56 and $op->pmstashpv ) 1177 { # avoid empty stash? if (table) pre-compiled else re-compile 1178 if ( !$PERL510 ) { 1179 asm "op_pmstashpv", pvix $op->pmstashpv; 1180 } 1181 else { 1182 # XXX crash in 5.10, 5.11. Only used in OP_MATCH, with PMf_ONCE set 1183 if ( $op->name eq 'match' and $op->op_pmflags & 2) { 1184 asm "op_pmstashpv", pvix $op->pmstashpv; 1185 } else { 1186 bwarn("op_pmstashpv ignored") if $debug{M}; 1187 } 1188 } 1189 } 1190 elsif ($PERL56) { # ignored 1191 ; 1192 } 1193 else { 1194 bwarn("op_pmstashpv main") if $debug{M}; 1195 asm "op_pmstashpv", pvix "main" unless $PERL510; 1196 } 1197 } # ithreads 1198 else { 1199 $rrop = "op_pmreplrootgv"; 1200 $rrarg = $op->pmreplroot->ix; 1201 $rstart = $op->pmreplstart->ix if $op->name eq 'subst'; 1202 # 5.6 walks down the pmreplrootgv here 1203 # $op->pmreplroot->save($rrarg) unless $op->name eq 'pushre'; 1204 my $stashix = $op->pmstash->ix unless $PERL56; 1205 $op->B::BINOP::bsave($ix); 1206 asm "op_pmstash", $stashix unless $PERL56; 1207 } 1208 1209 asm $rrop, $rrarg if $rrop; 1210 asm "op_pmreplstart", $rstart if $rstart; 1211 1212 if ( !$PERL510 ) { 1213 bwarn( "PMOP op_pmflags: ", $op->pmflags ) if $debug{M}; 1214 asm "op_pmflags", $op->pmflags; 1215 asm "op_pmpermflags", $op->pmpermflags; 1216 asm "op_pmdynflags", $op->pmdynflags unless $PERL56; 1217 # asm "op_pmnext", $pmnextix; # XXX broken 1218 # Special sequence: This is the arg for the next pregcomp 1219 asm "newpv", pvstring $op->precomp; 1220 asm "pregcomp"; 1221 } 1222 elsif ($PERL510) { 1223 # Since PMf_BASE_SHIFT we need a U32, which is a new bytecode for 1224 # backwards compat 1225 asm "op_pmflags", $op->pmflags; 1226 bwarn("PMOP op_pmflags: ", $op->pmflags) if $debug{M}; 1227 my $pv = $op->precomp; 1228 asm "newpv", pvstring $pv; 1229 asm "pregcomp"; 1230 # pregcomp does not set the extflags correctly, just the pmflags 1231 asm "op_reflags", $op->reflags if $pv; # so overwrite the extflags 1232 } 1233} 1234 1235sub B::SVOP::bsave { 1236 my ( $op, $ix ) = @_; 1237 my $svix = $op->sv->ix; 1238 1239 $op->B::OP::bsave($ix); 1240 asm "op_sv", $svix; 1241} 1242 1243sub B::PADOP::bsave { 1244 my ( $op, $ix ) = @_; 1245 1246 $op->B::OP::bsave($ix); 1247 1248 # XXX crashed in 5.11 (where, why?) 1249 #if ($PERL512) { 1250 asm "op_padix", $op->padix; 1251 #} 1252} 1253 1254sub B::PVOP::bsave { 1255 my ( $op, $ix ) = @_; 1256 $op->B::OP::bsave($ix); 1257 return unless my $pv = $op->pv; 1258 1259 if ( $op->name eq 'trans' ) { 1260 asm "op_pv_tr", join ',', length($pv) / 2, unpack( "s*", $pv ); 1261 } 1262 else { 1263 asm "newpv", pvstring $pv; 1264 asm "op_pv"; 1265 } 1266} 1267 1268sub B::LOOP::bsave { 1269 my ( $op, $ix ) = @_; 1270 my $nextix = $op->nextop->ix; 1271 my $lastix = $op->lastop->ix; 1272 my $redoix = $op->redoop->ix; 1273 1274 $op->B::BINOP::bsave($ix); 1275 asm "op_redoop", $redoix; 1276 asm "op_nextop", $nextix; 1277 asm "op_lastop", $lastix; 1278} 1279 1280sub B::COP::bsave { 1281 my ( $cop, $ix ) = @_; 1282 my $warnix = $cop->warnings->ix; 1283 if (ITHREADS) { 1284 $cop->B::OP::bsave($ix); 1285 asm "cop_stashpv", pvix $cop->stashpv, $cop->stashpv; 1286 asm "cop_file", pvix $cop->file, $cop->file; 1287 } 1288 else { 1289 my $stashix = $cop->stash->ix; 1290 my $fileix = $PERL56 ? pvix($cop->file) : $cop->filegv->ix(1); 1291 $cop->B::OP::bsave($ix); 1292 asm "cop_stash", $stashix; 1293 asm "cop_filegv", $fileix; 1294 } 1295 asm "cop_label", pvix $cop->label, $cop->label if $cop->label; # XXX AD 1296 asm "cop_seq", $cop->cop_seq; 1297 asm "cop_arybase", $cop->arybase unless $PERL510; 1298 asm "cop_line", $cop->line; 1299 asm "cop_warnings", $warnix; 1300 if ( !$PERL510 and !$PERL56 ) { 1301 asm "cop_io", $cop->io->ix; 1302 } 1303} 1304 1305sub B::OP::opwalk { 1306 my $op = shift; 1307 my $ix = $optab{$$op}; 1308 defined($ix) ? $ix : do { 1309 my $ix; 1310 my @oplist = ($PERL56 and $op->isa("B::COP")) 1311 ? () : $op->oplist; # 5.6 may be called by a COP 1312 push @cloop, undef; 1313 $ix = $_->ix while $_ = pop @oplist; 1314 #print "\n# rest of cloop\n"; 1315 while ( $_ = pop @cloop ) { 1316 asm "ldop", $optab{$$_}; 1317 asm "op_next", $optab{ ${ $_->next } }; 1318 } 1319 $ix; 1320 } 1321} 1322 1323# Do run-time requires with -b savebegin and without -i includeall. 1324# Otherwise all side-effects of BEGIN blocks are already in the current 1325# compiled code. 1326# -b or !-i will have smaller code, but run-time access of dependent modules 1327# such as with python, where all modules are byte-compiled. 1328# With -i the behaviour is similar to the C or CC compiler, where everything 1329# is packed into one file. 1330# Redo only certain ops, such as push @INC ""; unshift @INC "" (TODO *INC) 1331# use/require defs and boot sections are already included. 1332sub save_begin { 1333 my $av; 1334 if ( ( $av = begin_av )->isa("B::AV") and $av->ARRAY) { 1335 nice '<push_begin>'; 1336 if ($savebegins) { 1337 for ( $av->ARRAY ) { 1338 next unless $_->FILE eq $0; 1339 asm "push_begin", $_->ix; 1340 } 1341 } 1342 else { 1343 for ( $av->ARRAY ) { 1344 next unless $_->FILE eq $0; 1345 1346 # XXX BEGIN { goto A while 1; A: } 1347 for ( my $op = $_->START ; $$op ; $op = $op->next ) { 1348 # 1. push|unshift @INC, "libpath" 1349 if ($op->name eq 'gv') { 1350 my $gv = B::class($op) eq 'SVOP' 1351 ? $op->gv 1352 : ( ( $_->PADLIST->ARRAY )[1]->ARRAY )[ $op->padix ]; 1353 nice1 '<gv '.$gv->NAME.'>' if $$gv; 1354 asm "incav", inc_gv->AV->ix if $$gv and $gv->NAME eq 'INC'; 1355 } 1356 # 2. use|require 1357 if (!$includeall) { 1358 next unless $op->name eq 'require' || 1359 # this kludge needed for tests 1360 $op->name eq 'gv' && do { 1361 my $gv = B::class($op) eq 'SVOP' 1362 ? $op->gv 1363 : ( ( $_->PADLIST->ARRAY )[1]->ARRAY )[ $op->padix ]; 1364 $$gv && $gv->NAME =~ /use_ok|plan/; 1365 }; 1366 nice1 '<require in BEGIN>'; 1367 asm "push_begin", $_->ix if $_; 1368 last; 1369 } 1370 } 1371 } 1372 } 1373 } 1374} 1375 1376sub save_init_end { 1377 my $av; 1378 if ( ( $av = init_av )->isa("B::AV") and $av->ARRAY ) { 1379 nice '<push_init>'; 1380 for ( $av->ARRAY ) { 1381 next unless $_->FILE eq $0; 1382 asm "push_init", $_->ix; 1383 } 1384 } 1385 if ( ( $av = end_av )->isa("B::AV") and $av->ARRAY ) { 1386 nice '<push_end>'; 1387 for ( $av->ARRAY ) { 1388 next unless $_->FILE eq $0; 1389 asm "push_end", $_->ix; 1390 } 1391 } 1392} 1393 1394################### perl 5.6 backport only ################################### 1395 1396sub B::GV::bytecodecv { 1397 my $gv = shift; 1398 my $cv = $gv->CV; 1399 if ( $$cv && !( $gv->FLAGS & 0x80 ) ) { # GVf_IMPORTED_CV / && !saved($cv) 1400 if ($debug{cv}) { 1401 bwarn(sprintf( "saving extra CV &%s::%s (0x%x) from GV 0x%x\n", 1402 $gv->STASH->NAME, $gv->NAME, $$cv, $$gv )); 1403 } 1404 $gv->bsave; 1405 } 1406} 1407 1408sub symwalk { 1409 no strict 'refs'; 1410 my $ok = 1 1411 if grep { ( my $name = $_[0] ) =~ s/::$//; $_ eq $name; } @packages; 1412 if ( grep { /^$_[0]/; } @packages ) { 1413 walksymtable( \%{"$_[0]"}, "desired", \&symwalk, $_[0] ); 1414 } 1415 bwarn("considering $_[0] ... " . ( $ok ? "accepted\n" : "rejected\n" )) 1416 if $debug{b}; 1417 $ok; 1418} 1419 1420################### end perl 5.6 backport ################################### 1421 1422sub compile { 1423 my ( $head, $scan, $keep_syn, $module ); 1424 my $cwd = ''; 1425 $files{$0} = 1; 1426 $DB::single=1 if defined &DB::DB; 1427 # includeall mode (without require): 1428 if ($includeall) { 1429 # add imported symbols => values %INC 1430 $files{$_} = 1 for values %INC; 1431 } 1432 1433 sub keep_syn { 1434 $keep_syn = 1; 1435 *B::OP::bsave = *B::OP::bsave_fat; 1436 *B::UNOP::bsave = *B::UNOP::bsave_fat; 1437 *B::BINOP::bsave = *B::BINOP::bsave_fat; 1438 #*B::LISTOP::bsave = *B::LISTOP::bsave_fat; 1439 #*B::LOGOP::bsave = *B::LOGOP::bsave_fat; 1440 #*B::PMOP::bsave = *B::PMOP::bsave_fat; 1441 } 1442 sub bwarn { print STDERR "Bytecode.pm: @_\n" unless $quiet; } 1443 1444 for (@_) { 1445 if (/^-q(q?)/) { 1446 $quiet = 1; 1447 } 1448 elsif (/^-S/) { 1449 $debug{Comment} = 1; 1450 $debug{-S} = 1; 1451 *newasm = *endasm = sub { }; 1452 *asm = sub($;$$) { 1453 undef $_[2] if defined $_[2] and $quiet; 1454 ( defined $_[2] ) 1455 ? print $_[0], " ", $_[1], "\t# ", $_[2], "\n" 1456 : print "@_\n"; 1457 }; 1458 *nice = sub ($) { print "\n# @_\n" unless $quiet; }; 1459 *nice1 = sub ($) { print "# @_\n" unless $quiet; }; 1460 } 1461 elsif (/^-v/) { 1462 warn "conflicting -q ignored" if $quiet; 1463 *nice = sub ($) { print "\n# @_\n"; print STDERR "@_\n" }; 1464 *nice1 = sub ($) { print "# @_\n"; print STDERR "@_\n" }; 1465 } 1466 elsif (/^-H/) { 1467 require ByteLoader; 1468 my $version = $ByteLoader::VERSION; 1469 $head = "#! $^X 1470use ByteLoader '$ByteLoader::VERSION'; 1471"; 1472 1473 # Maybe: Fix the plc reader, if 'perl -MByteLoader <.plc>' is called 1474 } 1475 elsif (/^-k/) { 1476 keep_syn() if !$PERL510 or $PERL522; 1477 } 1478 elsif (/^-m/) { 1479 $module = 1; 1480 } 1481 elsif (/^-o(.*)$/) { 1482 open STDOUT, ">$1" or die "open $1: $!"; 1483 } 1484 elsif (/^-F(.*)$/) { 1485 $files{$1} = 1; 1486 } 1487 elsif (/^-i/) { 1488 $includeall = 1; 1489 } 1490 elsif (/^-D(.*)$/) { 1491 $debug{$1}++; 1492 } 1493 elsif (/^-s(.*)$/) { 1494 $scan = length($1) ? $1 : $0; 1495 } 1496 elsif (/^-b/) { 1497 $savebegins = 1; 1498 } # this is here for the testsuite 1499 elsif (/^-TI/) { 1500 $T_inhinc = 1; 1501 } 1502 elsif (/^-TF(.*)/) { 1503 my $thatfile = $1; 1504 *B::COP::file = sub { $thatfile }; 1505 } 1506 # Use -m instead for modules 1507 elsif (/^-u(.*)/ and $PERL56) { 1508 my $arg ||= $1; 1509 push @packages, $arg; 1510 } 1511 else { 1512 bwarn "Ignoring '$_' option"; 1513 } 1514 } 1515 if ($scan) { 1516 my $f; 1517 if ( open $f, $scan ) { 1518 while (<$f>) { 1519 /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1; 1520 /^#/ and next; 1521 if ( /\bgoto\b\s*[^&]/ && !$keep_syn ) { 1522 bwarn "keeping the syntax tree: \"goto\" op found"; 1523 keep_syn; 1524 } 1525 } 1526 } 1527 else { 1528 bwarn "cannot rescan '$scan'"; 1529 } 1530 close $f; 1531 } 1532 binmode STDOUT; 1533 return sub { 1534 if ($debug{-S}) { 1535 my $header = B::Assembler::gen_header_hash; 1536 asm sprintf("#%-10s\t","magic").sprintf("0x%x",$header->{magic}); 1537 for (qw(archname blversion ivsize ptrsize byteorder longsize archflag 1538 perlversion)) { 1539 asm sprintf("#%-10s\t",$_).$header->{$_}; 1540 } 1541 } 1542 print $head if $head; 1543 newasm sub { print @_ }; 1544 1545 nice '<incav>' if $T_inhinc; 1546 asm "incav", inc_gv->AV->ix if $T_inhinc; 1547 save_begin; 1548 #asm "incav", inc_gv->AV->ix if $T_inhinc; 1549 nice '<end_begin>'; 1550 if (!$PERL56) { 1551 defstash->bwalk; 1552 } else { 1553 if ( !@packages ) { 1554 # support modules? 1555 @packages = qw(main); 1556 } 1557 for (@packages) { 1558 no strict qw(refs); 1559 #B::svref_2object( \%{"$_\::"} )->bwalk; 1560 walksymtable( \%{"$_\::"}, "bytecodecv", \&symwalk ); 1561 } 1562 walkoptree( main_root, "bsave" ) unless ref(main_root) eq "B::NULL"; 1563 } 1564 1565 asm "signal", cstring "__WARN__" # XXX 1566 if !$PERL56 and warnhook->ix; 1567 save_init_end; 1568 1569 unless ($module) { 1570 $B::Bytecode::curcv = main_cv; 1571 nice '<main_start>'; 1572 asm "main_start", $PERL56 ? main_start->ix : main_start->opwalk; 1573 #asm "main_start", main_start->opwalk; 1574 nice '<main_root>'; 1575 asm "main_root", main_root->ix; 1576 nice '<main_cv>'; 1577 asm "main_cv", main_cv->ix; 1578 nice '<curpad>'; 1579 asm "curpad", ( comppadlist->ARRAY )[1]->ix; 1580 } 1581 asm "dowarn", dowarn unless $PERL56; 1582 1583 { 1584 no strict 'refs'; 1585 nice "<DATA>"; 1586 my $dh = $PERL56 ? *main::DATA : *{ defstash->NAME . "::DATA" }; 1587 unless ( eof $dh ) { 1588 local undef $/; 1589 asm "data", ord 'D' if !$PERL56; 1590 print <$dh>; 1591 } 1592 else { 1593 asm "ret"; 1594 } 1595 } 1596 1597 endasm; 1598 } 1599} 1600 16011; 1602 1603=head1 NAME 1604 1605B::Bytecode - Perl compiler's bytecode backend 1606 1607=head1 SYNOPSIS 1608 1609B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl> 1610 1611=head1 DESCRIPTION 1612 1613Compiles a Perl script into a bytecode format that could be loaded 1614later by the ByteLoader module and executed as a regular Perl script. 1615This saves time for the optree parsing and compilation and space for 1616the sourcecode in memory. 1617 1618=head1 EXAMPLE 1619 1620 $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"' 1621 $ perl hi 1622 hi! 1623 1624=head1 OPTIONS 1625 1626=over 4 1627 1628=item B<-H> 1629 1630Prepend a C<use ByteLoader VERSION;> line to the produced bytecode. 1631This way you will not need to add C<-MByteLoader> to your perl command-line. 1632 1633Beware: This option does not yet work with 5.18 and higher. You need to use 1634C<-MByteLoader> still. 1635 1636=item B<-i> includeall 1637 1638Include all used packages and its symbols. Does no run-time require from 1639BEGIN blocks (C<use> package). 1640 1641This creates bigger and more independent code, but is more error prone and 1642does not support pre-compiled C<.pmc> modules. 1643 1644It is highly recommended to use C<-i> together with C<-b> I<safebegin>. 1645 1646=item B<-b> savebegin 1647 1648Save all the BEGIN blocks. 1649 1650Normally only BEGIN blocks that C<require> 1651other files (ex. C<use Foo;>) or push|unshift 1652to @INC are saved. 1653 1654=item B<-k> 1655 1656Keep the syntax tree - it is stripped by default. 1657 1658=item B<-o>I<outfile> 1659 1660Put the bytecode in <outfile> instead of dumping it to STDOUT. 1661 1662=item B<-s> 1663 1664Scan the script for C<# line ..> directives and for <goto LABEL> 1665expressions. When gotos are found keep the syntax tree. 1666 1667=item B<-S> 1668 1669Output assembler source rather than piping it through the assembler 1670and outputting bytecode. 1671Without C<-q> the assembler source is commented. 1672 1673=item B<-m> 1674 1675Compile to a F<.pmc> module rather than to a single standalone F<.plc> program. 1676 1677Currently this just means that the bytecodes for initialising C<main_start>, 1678C<main_root>, C<main_cv> and C<curpad> are omitted. 1679 1680=item B<-u>I<package> 1681 1682"use package." Might be needed of the package is not automatically detected. 1683 1684=item B<-F>I<file> 1685 1686Include file. If not C<-i> define all symbols in the given included 1687source file. C<-i> would all included files, 1688C<-F> only a certain file - full path needed. 1689 1690=item B<-q> 1691 1692Be quiet. 1693 1694=item B<-v> 1695 1696Be verbose. 1697 1698=item B<-TI> 1699 1700Restore full @INC for running within the CORE testsuite. 1701 1702=item B<-TF> I<cop file> 1703 1704Set the COP file - for running within the CORE testsuite. 1705 1706=item B<-Do> 1707 1708OPs, prints each OP as it's processed 1709 1710=item B<-DM> 1711 1712Debugging flag for more verbose STDERR output. 1713 1714B<M> for Magic and Matches. 1715 1716=item B<-DG> 1717 1718Debug GV's 1719 1720=item B<-DA> 1721 1722Set developer B<A>ssertions, to help find possible obj-indices out of range. 1723 1724=back 1725 1726=head1 KNOWN BUGS 1727 1728=over 4 1729 1730=item * 1731 17325.10 threaded fails with setting the wrong MATCH op_pmflags 17335.10 non-threaded fails calling anoncode, ... 1734 1735=item * 1736 1737C<BEGIN { goto A: while 1; A: }> won't even compile. 1738 1739=item * 1740 1741C<?...?> and C<reset> do not work as expected. 1742 1743=item * 1744 1745variables in C<(?{ ... })> constructs are not properly scoped. 1746 1747=item * 1748 1749Scripts that use source filters will fail miserably. 1750 1751=item * 1752 1753Special GV's fail. 1754 1755=back 1756 1757=head1 NOTICE 1758 1759There are also undocumented bugs and options. 1760 1761=head1 AUTHORS 1762 1763Originally written by Malcolm Beattie 1996 and 1764modified by Benjamin Stuhl <sho_pi@hotmail.com>. 1765 1766Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d. 1767 1768Enhanced by Reini Urban <rurban@cpan.org>, 2008-2012 1769 1770=cut 1771 1772# Local Variables: 1773# mode: cperl 1774# cperl-indent-level: 2 1775# fill-column: 100 1776# End: 1777# vim: expandtab shiftwidth=2: 1778