ext/B/B/Bytecode.pm

   1 #      Bytecode.pm
   2 #
   3 #      Copyright (c) 1996-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::Bytecode;
   9
  10 use strict;
  11 use Carp;
  12 use B qw(main_cv main_root main_start comppadlist
  13          class peekop walkoptree svref_2object cstring walksymtable
  14          init_av begin_av end_av
  15          SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK
  16          SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV
  17          GVf_IMPORTED_SV SVTYPEMASK
  18         );
  19 use B::Asmdata qw(@optype @specialsv_name);
  20 use B::Assembler qw(newasm endasm assemble);
  21
  22 my %optype_enum;
  23 my $i;
  24 for ($i = 0; $i < @optype; $i++) {
  25     $optype_enum{$optype[$i]} = $i;
  26 }
  27
  28 # Following is SVf_POK|SVp_POK
  29 # XXX Shouldn't be hardwired
  30 sub POK () { SVf_POK|SVp_POK }
  31
  32 # Following is SVf_IOK|SVp_IOK
  33 # XXX Shouldn't be hardwired
  34 sub IOK () { SVf_IOK|SVp_IOK }
  35
  36 # Following is SVf_NOK|SVp_NOK
  37 # XXX Shouldn't be hardwired
  38 sub NOK () { SVf_NOK|SVp_NOK }
  39
  40 # nonexistant flags (see B::GV::bytecode for usage)
  41 sub GVf_IMPORTED_IO () { 0; }
  42 sub GVf_IMPORTED_FORM () { 0; }
  43
  44 my ($verbose, $no_assemble, $debug_bc, $debug_cv);
  45 my @packages;   # list of packages to compile
  46
  47 sub asm (@) {   # print replacement that knows about assembling
  48     if ($no_assemble) {
  49         print @_;
  50     } else {
  51         my $buf = join '', @_;
  52         assemble($_) for (split /\n/, $buf);
  53     }
  54 }
  55
  56 sub asmf (@) {  # printf replacement that knows about assembling
  57     if ($no_assemble) {
  58         printf shift(), @_;
  59     } else {
  60         my $format = shift;
  61         my $buf = sprintf $format, @_;
  62         assemble($_) for (split /\n/, $buf);
  63     }
  64 }
  65
  66 # Optimisation options. On the command line, use hyphens instead of
  67 # underscores for compatibility with gcc-style options. We use
  68 # underscores here because they are OK in (strict) barewords.
  69 my ($compress_nullops, $omit_seq, $bypass_nullops);
  70 my %optimise = (compress_nullops        => \$compress_nullops,
  71                 omit_sequence_numbers   => \$omit_seq,
  72                 bypass_nullops          => \$bypass_nullops);
  73
  74 my $strip_syntree;      # this is left here in case stripping the
  75                         # syntree ever becomes safe again
  76                         #       -- BKS, June 2000
  77
  78 my $nextix = 0;
  79 my %symtable;   # maps object addresses to object indices.
  80                 # Filled in at allocation (newsv/newop) time.
  81
  82 my %saved;      # maps object addresses (for SVish classes) to "saved yet?"
  83                 # flag. Set at FOO::bytecode time usually by SV::bytecode.
  84                 # Manipulated via saved(), mark_saved(), unmark_saved().
  85
  86 my %strtable;   # maps shared strings to object indices
  87                 # Filled in at allocation (pvix) time
  88
  89 my $svix = -1;  # we keep track of when the sv register contains an element
  90                 # of the object table to avoid unnecessary repeated
  91                 # consecutive ldsv instructions.
  92
  93 my $opix = -1;  # Ditto for the op register.
  94
  95 sub ldsv {
  96     my $ix = shift;
  97     if ($ix != $svix) {
  98         asm "ldsv $ix\n";
  99         $svix = $ix;
 100     }
 101 }
 102
 103 sub stsv {
 104     my $ix = shift;
 105     asm "stsv $ix\n";
 106     $svix = $ix;
 107 }
 108
 109 sub set_svix {
 110     $svix = shift;
 111 }
 112
 113 sub ldop {
 114     my $ix = shift;
 115     if ($ix != $opix) {
 116         asm "ldop $ix\n";
 117         $opix = $ix;
 118     }
 119 }
 120
 121 sub stop {
 122     my $ix = shift;
 123     asm "stop $ix\n";
 124     $opix = $ix;
 125 }
 126
 127 sub set_opix {
 128     $opix = shift;
 129 }
 130
 131 sub pvstring {
 132     my $str = shift;
 133     if (defined($str)) {
 134         return cstring($str . "\0");
 135     } else {
 136         return '""';
 137     }
 138 }
 139
 140 sub nv {
 141     # print full precision
 142     my $str = sprintf "%.40f", $_[0];
 143     $str =~ s/0+$//;            # remove trailing zeros
 144     $str =~ s/\.$/.0/;
 145     return $str;
 146 }
 147
 148 sub saved { $saved{${$_[0]}} }
 149 sub mark_saved { $saved{${$_[0]}} = 1 }
 150 sub unmark_saved { $saved{${$_[0]}} = 0 }
 151
 152 sub debug { $debug_bc = shift }
 153
 154 sub pvix {      # save a shared PV (mainly for COPs)
 155     return $strtable{$_[0]} if defined($strtable{$_[0]});
 156     asmf "newpv %s\n", pvstring($_[0]);
 157     my $ix = $nextix++;
 158     $strtable{$_[0]} = $ix;
 159     asmf "stpv %d\n", $ix;
 160     return $ix;
 161 }
 162
 163 sub B::OBJECT::nyi {
 164     my $obj = shift;
 165     warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n",
 166                  class($obj), $$obj);
 167 }
 168
 169 #
 170 # objix may stomp on the op register (for op objects)
 171 # or the sv register (for SV objects)
 172 #
 173 sub B::OBJECT::objix {
 174     my $obj = shift;
 175     my $ix = $symtable{$$obj};
 176     if (defined($ix)) {
 177         return $ix;
 178     } else {
 179         $obj->newix($nextix);
 180         return $symtable{$$obj} = $nextix++;
 181     }
 182 }
 183
 184 sub B::SV::newix {
 185     my ($sv, $ix) = @_;
 186     asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv);
 187     stsv($ix);
 188 }
 189
 190 sub B::GV::newix {
 191     my ($gv, $ix) = @_;
 192     my $gvname = $gv->NAME;
 193     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
 194     asm "gv_fetchpv $name\n";
 195     stsv($ix);
 196 }
 197
 198 sub B::HV::newix {
 199     my ($hv, $ix) = @_;
 200     my $name = $hv->NAME;
 201     if ($name) {
 202         # It's a stash
 203         asmf "gv_stashpv %s\n", cstring($name);
 204         stsv($ix);
 205     } else {
 206         # It's an ordinary HV. Fall back to ordinary newix method
 207         $hv->B::SV::newix($ix);
 208     }
 209 }
 210
 211 sub B::SPECIAL::newix {
 212     my ($sv, $ix) = @_;
 213     # Special case. $$sv is not the address of the SV but an
 214     # index into svspecialsv_list.
 215     asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv];
 216     stsv($ix);
 217 }
 218
 219 sub B::OP::newix {
 220     my ($op, $ix) = @_;
 221     my $class = class($op);
 222     my $typenum = $optype_enum{$class};
 223     croak("OP::newix: can't understand class $class") unless defined($typenum);
 224     asm "newop $typenum\t# $class\n";
 225     stop($ix);
 226 }
 227
 228 sub B::OP::walkoptree_debug {
 229     my $op = shift;
 230     warn(sprintf("walkoptree: %s\n", peekop($op)));
 231 }
 232
 233 sub B::OP::bytecode {
 234     my $op = shift;
 235     my $next = $op->next;
 236     my $nextix;
 237     my $sibix = $op->sibling->objix unless $strip_syntree;
 238     my $ix = $op->objix;
 239     my $type = $op->type;
 240
 241     if ($bypass_nullops) {
 242         $next = $next->next while $$next && $next->type == 0;
 243     }
 244     $nextix = $next->objix;
 245
 246     asmf "# %s\n", peekop($op) if $debug_bc;
 247     ldop($ix);
 248     asm "op_next $nextix\n";
 249     asm "op_sibling $sibix\n" unless $strip_syntree;
 250     asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type;
 251     asmf("op_seq %d\n", $op->seq) unless $omit_seq;
 252     if ($type || !$compress_nullops) {
 253         asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
 254             $op->targ, $op->flags, $op->private;
 255     }
 256 }
 257
 258 sub B::UNOP::bytecode {
 259     my $op = shift;
 260     my $firstix = $op->first->objix unless $strip_syntree;
 261     $op->B::OP::bytecode;
 262     if (($op->type || !$compress_nullops) && !$strip_syntree) {
 263         asm "op_first $firstix\n";
 264     }
 265 }
 266
 267 sub B::LOGOP::bytecode {
 268     my $op = shift;
 269     my $otherix = $op->other->objix;
 270     $op->B::UNOP::bytecode;
 271     asm "op_other $otherix\n";
 272 }
 273
 274 sub B::SVOP::bytecode {
 275     my $op = shift;
 276     my $sv = $op->sv;
 277     my $svix = $sv->objix;
 278     $op->B::OP::bytecode;
 279     asm "op_sv $svix\n";
 280     $sv->bytecode;
 281 }
 282
 283 sub B::PADOP::bytecode {
 284     my $op = shift;
 285     my $padix = $op->padix;
 286     $op->B::OP::bytecode;
 287     asm "op_padix $padix\n";
 288 }
 289
 290 sub B::PVOP::bytecode {
 291     my $op = shift;
 292     my $pv = $op->pv;
 293     $op->B::OP::bytecode;
 294     #
 295     # This would be easy except that OP_TRANS uses a PVOP to store an
 296     # endian-dependent array of 256 shorts instead of a plain string.
 297     #
 298     if ($op->name eq "trans") {
 299         my @shorts = unpack("s256", $pv); # assembler handles endianness
 300         asm "op_pv_tr ", join(",", @shorts), "\n";
 301     } else {
 302         asmf "newpv %s\nop_pv\n", pvstring($pv);
 303     }
 304 }
 305
 306 sub B::BINOP::bytecode {
 307     my $op = shift;
 308     my $lastix = $op->last->objix unless $strip_syntree;
 309     $op->B::UNOP::bytecode;
 310     if (($op->type || !$compress_nullops) && !$strip_syntree) {
 311         asm "op_last $lastix\n";
 312     }
 313 }
 314
 315 sub B::LOOP::bytecode {
 316     my $op = shift;
 317     my $redoopix = $op->redoop->objix;
 318     my $nextopix = $op->nextop->objix;
 319     my $lastopix = $op->lastop->objix;
 320     $op->B::LISTOP::bytecode;
 321     asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
 322 }
 323
 324 sub B::COP::bytecode {
 325     my $op = shift;
 326     my $file = $op->file;
 327     my $line = $op->line;
 328     if ($debug_bc) { # do this early to aid debugging
 329         asmf "# line %s:%d\n", $file, $line;
 330     }
 331     my $stashpv = $op->stashpv;
 332     my $warnings = $op->warnings;
 333     my $warningsix = $warnings->objix;
 334     my $labelix = pvix($op->label);
 335     my $stashix = pvix($stashpv);
 336     my $fileix = pvix($file);
 337     $warnings->bytecode;
 338     $op->B::OP::bytecode;
 339     asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase;
 340 cop_label %d
 341 cop_stashpv %d
 342 cop_seq %d
 343 cop_file %d
 344 cop_arybase %d
 345 cop_line $line
 346 cop_warnings $warningsix
 347 EOT
 348 }
 349
 350 sub B::PMOP::bytecode {
 351     my $op = shift;
 352     my $replroot = $op->pmreplroot;
 353     my $replrootix = $replroot->objix;
 354     my $replstartix = $op->pmreplstart->objix;
 355     my $opname = $op->name;
 356     # pmnext is corrupt in some PMOPs (see misc.t for example)
 357     #my $pmnextix = $op->pmnext->objix;
 358
 359     if ($$replroot) {
 360         # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
 361         # argument to a split) stores a GV in op_pmreplroot instead
 362         # of a substitution syntax tree. We don't want to walk that...
 363         if ($opname eq "pushre") {
 364             $replroot->bytecode;
 365         } else {
 366             walkoptree($replroot, "bytecode");
 367         }
 368     }
 369     $op->B::LISTOP::bytecode;
 370     if ($opname eq "pushre") {
 371         asmf "op_pmreplrootgv $replrootix\n";
 372     } else {
 373         asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
 374     }
 375     my $re = pvstring($op->precomp);
 376     # op_pmnext omitted since a perl bug means it's sometime corrupt
 377     asmf <<"EOT", $op->pmflags, $op->pmpermflags;
 378 op_pmflags 0x%x
 379 op_pmpermflags 0x%x
 380 newpv $re
 381 pregcomp
 382 EOT
 383 }
 384
 385 sub B::SV::bytecode {
 386     my $sv = shift;
 387     return if saved($sv);
 388     my $ix = $sv->objix;
 389     my $refcnt = $sv->REFCNT;
 390     my $flags = sprintf("0x%x", $sv->FLAGS);
 391     ldsv($ix);
 392     asm "sv_refcnt $refcnt\nsv_flags $flags\n";
 393     mark_saved($sv);
 394 }
 395
 396 sub B::PV::bytecode {
 397     my $sv = shift;
 398     return if saved($sv);
 399     $sv->B::SV::bytecode;
 400     asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
 401 }
 402
 403 sub B::IV::bytecode {
 404     my $sv = shift;
 405     return if saved($sv);
 406     my $iv = $sv->IVX;
 407     $sv->B::SV::bytecode;
 408     asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV
 409 }
 410
 411 sub B::NV::bytecode {
 412     my $sv = shift;
 413     return if saved($sv);
 414     $sv->B::SV::bytecode;
 415     asmf "xnv %s\n", nv($sv->NVX);
 416 }
 417
 418 sub B::RV::bytecode {
 419     my $sv = shift;
 420     return if saved($sv);
 421     my $rv = $sv->RV;
 422     my $rvix = $rv->objix;
 423     $rv->bytecode;
 424     $sv->B::SV::bytecode;
 425     asm "xrv $rvix\n";
 426 }
 427
 428 sub B::PVIV::bytecode {
 429     my $sv = shift;
 430     return if saved($sv);
 431     my $iv = $sv->IVX;
 432     $sv->B::PV::bytecode;
 433     asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
 434 }
 435
 436 sub B::PVNV::bytecode {
 437     my $sv = shift;
 438     my $flag = shift || 0;
 439     # The $flag argument is passed through PVMG::bytecode by BM::bytecode
 440     # and AV::bytecode and indicates special handling. $flag = 1 is used by
 441     # BM::bytecode and means that we should ensure we save the whole B-M
 442     # table. It consists of 257 bytes (256 char array plus a final \0)
 443     # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
 444     # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
 445     # call SV::bytecode instead of saving PV and calling NV::bytecode since
 446     # PV/NV/IV stuff is different for AVs.
 447     return if saved($sv);
 448     if ($flag == 2) {
 449         $sv->B::SV::bytecode;
 450     } else {
 451         my $pv = $sv->PV;
 452         $sv->B::IV::bytecode;
 453         asmf "xnv %s\n", nv($sv->NVX);
 454         if ($flag == 1) {
 455             $pv .= "\0" . $sv->TABLE;
 456             asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
 457         } else {
 458             asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
 459         }
 460     }
 461 }
 462
 463 sub B::PVMG::bytecode {
 464     my ($sv, $flag) = @_;
 465     # See B::PVNV::bytecode for an explanation of $flag.
 466     return if saved($sv);
 467     # XXX We assume SvSTASH is already saved and don't save it later ourselves
 468     my $stashix = $sv->SvSTASH->objix;
 469     my @mgchain = $sv->MAGIC;
 470     my (@mgobjix, $mg);
 471     #
 472     # We need to traverse the magic chain and get objix for each OBJ
 473     # field *before* we do B::PVNV::bytecode since objix overwrites
 474     # the sv register. However, we need to write the magic-saving
 475     # bytecode *after* B::PVNV::bytecode since sv isn't initialised
 476     # to refer to $sv until then.
 477     #
 478     @mgobjix = map($_->OBJ->objix, @mgchain);
 479     $sv->B::PVNV::bytecode($flag);
 480     asm "xmg_stash $stashix\n";
 481     foreach $mg (@mgchain) {
 482         asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
 483             cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
 484     }
 485 }
 486
 487 sub B::PVLV::bytecode {
 488     my $sv = shift;
 489     return if saved($sv);
 490     $sv->B::PVMG::bytecode;
 491     asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
 492 xlv_targoff %d
 493 xlv_targlen %d
 494 xlv_type %s
 495 EOT
 496 }
 497
 498 sub B::BM::bytecode {
 499     my $sv = shift;
 500     return if saved($sv);
 501     # See PVNV::bytecode for an explanation of what the argument does
 502     $sv->B::PVMG::bytecode(1);
 503     asmf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
 504         $sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
 505 }
 506
 507 sub empty_gv {  # is a GV empty except for imported stuff?
 508     my $gv = shift;
 509
 510     return 0 if ($gv->SV->FLAGS & SVTYPEMASK);  # sv not SVt_NULL
 511     my @subfield_names = qw(AV HV CV FORM IO);
 512     @subfield_names = grep {;
 513                                 no strict 'refs';
 514                                 !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()) && ${$gv->$_()};
 515                         } @subfield_names;
 516     return scalar @subfield_names;
 517 }
 518
 519 sub B::GV::bytecode {
 520     my $gv = shift;
 521     return if saved($gv);
 522     return unless grep { $_ eq $gv->STASH->NAME; } @packages;
 523     return if $gv->NAME =~ m/^\(/;      # ignore overloads - they'll be rebuilt
 524     my $ix = $gv->objix;
 525     mark_saved($gv);
 526     ldsv($ix);
 527     asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS;
 528 sv_flags 0x%x
 529 xgv_flags 0x%x
 530 EOT
 531     my $refcnt = $gv->REFCNT;
 532     asmf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
 533     return if $gv->is_empty;
 534     asmf <<"EOT", $gv->LINE, pvix($gv->FILE);
 535 gp_line %d
 536 gp_file %d
 537 EOT
 538     my $gvname = $gv->NAME;
 539     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
 540     my $egv = $gv->EGV;
 541     my $egvix = $egv->objix;
 542     my $gvrefcnt = $gv->GvREFCNT;
 543     asmf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
 544     if ($gvrefcnt > 1 &&  $ix != $egvix) {
 545         asm "gp_share $egvix\n";
 546     } else {
 547         if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
 548             my $i;
 549             my @subfield_names = qw(SV AV HV CV FORM IO);
 550             @subfield_names = grep {;
 551                                         no strict 'refs';
 552                                         !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->());
 553                                 } @subfield_names;
 554             my @subfields = map($gv->$_(), @subfield_names);
 555             my @ixes = map($_->objix, @subfields);
 556             # Reset sv register for $gv
 557             ldsv($ix);
 558             for ($i = 0; $i < @ixes; $i++) {
 559                 asmf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
 560             }
 561             # Now save all the subfields
 562             my $sv;
 563             foreach $sv (@subfields) {
 564                 $sv->bytecode;
 565             }
 566         }
 567     }
 568 }
 569
 570 sub B::HV::bytecode {
 571     my $hv = shift;
 572     return if saved($hv);
 573     mark_saved($hv);
 574     my $name = $hv->NAME;
 575     my $ix = $hv->objix;
 576     if (!$name) {
 577         # It's an ordinary HV. Stashes have NAME set and need no further
 578         # saving beyond the gv_stashpv that $hv->objix already ensures.
 579         my @contents = $hv->ARRAY;
 580         my ($i, @ixes);
 581         for ($i = 1; $i < @contents; $i += 2) {
 582             push(@ixes, $contents[$i]->objix);
 583         }
 584         for ($i = 1; $i < @contents; $i += 2) {
 585             $contents[$i]->bytecode;
 586         }
 587         ldsv($ix);
 588         for ($i = 0; $i < @contents; $i += 2) {
 589             asmf("newpv %s\nhv_store %d\n",
 590                    pvstring($contents[$i]), $ixes[$i / 2]);
 591         }
 592         asmf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
 593     }
 594 }
 595
 596 sub B::AV::bytecode {
 597     my $av = shift;
 598     return if saved($av);
 599     my $ix = $av->objix;
 600     my $fill = $av->FILL;
 601     my $max = $av->MAX;
 602     my (@array, @ixes);
 603     if ($fill > -1) {
 604         @array = $av->ARRAY;
 605         @ixes = map($_->objix, @array);
 606         my $sv;
 607         foreach $sv (@array) {
 608             $sv->bytecode;
 609         }
 610     }
 611     # See PVNV::bytecode for the meaning of the flag argument of 2.
 612     $av->B::PVMG::bytecode(2);
 613     # Recover sv register and set AvMAX and AvFILL to -1 (since we
 614     # create an AV with NEWSV and SvUPGRADE rather than doing newAV
 615     # which is what sets AvMAX and AvFILL.
 616     ldsv($ix);
 617     asmf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST
 618     asmf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
 619     if ($fill > -1) {
 620         my $elix;
 621         foreach $elix (@ixes) {
 622             asm "av_push $elix\n";
 623         }
 624     } else {
 625         if ($max > -1) {
 626             asm "av_extend $max\n";
 627         }
 628     }
 629     asmf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above
 630 }
 631
 632 sub B::CV::bytecode {
 633     my $cv = shift;
 634     return if saved($cv);
 635     return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV);
 636     my $fileix = pvix($cv->FILE);
 637     my $ix = $cv->objix;
 638     $cv->B::PVMG::bytecode;
 639     my $i;
 640     my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE);
 641     my @subfields = map($cv->$_(), @subfield_names);
 642     my @ixes = map($_->objix, @subfields);
 643     # Save OP tree from CvROOT (first element of @subfields)
 644     my $root = shift @subfields;
 645     if ($$root) {
 646         walkoptree($root, "bytecode");
 647     }
 648     # Reset sv register for $cv (since above ->objix calls stomped on it)
 649     ldsv($ix);
 650     for ($i = 0; $i < @ixes; $i++) {
 651         asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
 652     }
 653     asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS;
 654     asmf "xcv_file %d\n", $fileix;
 655     # Now save all the subfields (except for CvROOT which was handled
 656     # above) and CvSTART (now the initial element of @subfields).
 657     shift @subfields; # bye-bye CvSTART
 658     my $sv;
 659     foreach $sv (@subfields) {
 660         $sv->bytecode;
 661     }
 662 }
 663
 664 sub B::IO::bytecode {
 665     my $io = shift;
 666     return if saved($io);
 667     my $ix = $io->objix;
 668     my $top_gv = $io->TOP_GV;
 669     my $top_gvix = $top_gv->objix;
 670     my $fmt_gv = $io->FMT_GV;
 671     my $fmt_gvix = $fmt_gv->objix;
 672     my $bottom_gv = $io->BOTTOM_GV;
 673     my $bottom_gvix = $bottom_gv->objix;
 674
 675     $io->B::PVMG::bytecode;
 676     ldsv($ix);
 677     asm "xio_top_gv $top_gvix\n";
 678     asm "xio_fmt_gv $fmt_gvix\n";
 679     asm "xio_bottom_gv $bottom_gvix\n";
 680     my $field;
 681     foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
 682         asmf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
 683     }
 684     foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
 685         asmf "xio_%s %d\n", lc($field), $io->$field();
 686     }
 687     asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
 688     $top_gv->bytecode;
 689     $fmt_gv->bytecode;
 690     $bottom_gv->bytecode;
 691 }
 692
 693 sub B::SPECIAL::bytecode {
 694     # nothing extra needs doing
 695 }
 696
 697 sub bytecompile_object {
 698     for my $sv (@_) {
 699         svref_2object($sv)->bytecode;
 700     }
 701 }
 702
 703 sub B::GV::bytecodecv {
 704     my $gv = shift;
 705     my $cv = $gv->CV;
 706     if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_CV)) {
 707         if ($debug_cv) {
 708             warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
 709                          $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
 710         }
 711         $gv->bytecode;
 712     }
 713 }
 714
 715 sub save_call_queues {
 716     if (begin_av()->isa("B::AV")) {     # this is just to save 'use Foo;' calls
 717         for my $cv (begin_av()->ARRAY) {
 718             next unless grep { $_ eq $cv->STASH->NAME; } @packages;
 719             my $op = $cv->START;
 720 OPLOOP:
 721             while ($$op) {
 722                 if ($op->name eq 'require') { # save any BEGIN that does a require
 723                     $cv->bytecode;
 724                     asmf "push_begin %d\n", $cv->objix;
 725                     last OPLOOP;
 726                 }
 727                 $op = $op->next;
 728             }
 729         }
 730     }
 731     if (init_av()->isa("B::AV")) {
 732         for my $cv (init_av()->ARRAY) {
 733             next unless grep { $_ eq $cv->STASH->NAME; } @packages;
 734             $cv->bytecode;
 735             asmf "push_init %d\n", $cv->objix;
 736         }
 737     }
 738     if (end_av()->isa("B::AV")) {
 739         for my $cv (end_av()->ARRAY) {
 740             next unless grep { $_ eq $cv->STASH->NAME; } @packages;
 741             $cv->bytecode;
 742             asmf "push_end %d\n", $cv->objix;
 743         }
 744     }
 745 }
 746
 747 sub symwalk {
 748     no strict 'refs';
 749     my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages;
 750     if (grep { /^$_[0]/; } @packages) {
 751         walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]);
 752     }
 753     warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n")
 754         if $debug_bc;
 755     $ok;
 756 }
 757
 758 sub bytecompile_main {
 759     my $curpad = (comppadlist->ARRAY)[1];
 760     my $curpadix = $curpad->objix;
 761     $curpad->bytecode;
 762     save_call_queues();
 763     walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL";
 764     warn "done main program, now walking symbol table\n" if $debug_bc;
 765     if (@packages) {
 766         no strict qw(refs);
 767         walksymtable(\%{"main::"}, "bytecodecv", \&symwalk);
 768     } else {
 769         die "No packages requested for compilation!\n";
 770     }
 771     asmf "main_root %d\n", main_root->objix;
 772     asmf "main_start %d\n", main_start->objix;
 773     asmf "curpad $curpadix\n";
 774     # XXX Do min_intro_pending and max_intro_pending matter?
 775 }
 776
 777 sub compile {
 778     my @options = @_;
 779     my ($option, $opt, $arg);
 780     open(OUT, ">&STDOUT");
 781     binmode OUT;
 782     select OUT;
 783   OPTION:
 784     while ($option = shift @options) {
 785         if ($option =~ /^-(.)(.*)/) {
 786             $opt = $1;
 787             $arg = $2;
 788         } else {
 789             unshift @options, $option;
 790             last OPTION;
 791         }
 792         if ($opt eq "-" && $arg eq "-") {
 793             shift @options;
 794             last OPTION;
 795         } elsif ($opt eq "o") {
 796             $arg ||= shift @options;
 797             open(OUT, ">$arg") or return "$arg: $!\n";
 798             binmode OUT;
 799         } elsif ($opt eq "a") {
 800             $arg ||= shift @options;
 801             open(OUT, ">>$arg") or return "$arg: $!\n";
 802             binmode OUT;
 803         } elsif ($opt eq "D") {
 804             $arg ||= shift @options;
 805             foreach $arg (split(//, $arg)) {
 806                 if ($arg eq "b") {
 807                     $| = 1;
 808                     debug(1);
 809                 } elsif ($arg eq "o") {
 810                     B->debug(1);
 811                 } elsif ($arg eq "a") {
 812                     B::Assembler::debug(1);
 813                 } elsif ($arg eq "C") {
 814                     $debug_cv = 1;
 815                 }
 816             }
 817         } elsif ($opt eq "v") {
 818             $verbose = 1;
 819         } elsif ($opt eq "S") {
 820             $no_assemble = 1;
 821         } elsif ($opt eq "f") {
 822             $arg ||= shift @options;
 823             my $value = $arg !~ s/^no-//;
 824             $arg =~ s/-/_/g;
 825             my $ref = $optimise{$arg};
 826             if (defined($ref)) {
 827                 $$ref = $value;
 828             } else {
 829                 warn qq(ignoring unknown optimisation option "$arg"\n);
 830             }
 831         } elsif ($opt eq "O") {
 832             $arg = 1 if $arg eq "";
 833             my $ref;
 834             foreach $ref (values %optimise) {
 835                 $$ref = 0;
 836             }
 837             if ($arg >= 2) {
 838                 $bypass_nullops = 1;
 839             }
 840             if ($arg >= 1) {
 841                 $compress_nullops = 1;
 842                 $omit_seq = 1;
 843             }
 844         } elsif ($opt eq "u") {
 845             $arg ||= shift @options;
 846             push @packages, $arg;
 847         } else {
 848             warn qq(ignoring unknown option "$opt$arg"\n);
 849         }
 850     }
 851     if (! @packages) {
 852         warn "No package specified for compilation, assuming main::\n";
 853         @packages = qw(main);
 854     }
 855     if (@options) {
 856         die "Extraneous options left on B::Bytecode commandline: @options\n";
 857     } else {
 858         return sub {
 859             newasm(\&apr) unless $no_assemble;
 860             bytecompile_main();
 861             endasm() unless $no_assemble;
 862         };
 863     }
 864 }
 865
 866 sub apr { print @_; }
 867
 868 1;
 869
 870 __END__
 871
 872 =head1 NAME
 873
 874 B::Bytecode - Perl compiler's bytecode backend
 875
 876 =head1 SYNOPSIS
 877
 878         perl -MO=Bytecode[,OPTIONS] foo.pl
 879
 880 =head1 DESCRIPTION
 881
 882 This compiler backend takes Perl source and generates a
 883 platform-independent bytecode encapsulating code to load the
 884 internal structures perl uses to run your program. When the
 885 generated bytecode is loaded in, your program is ready to run,
 886 reducing the time which perl would have taken to load and parse
 887 your program into its internal semi-compiled form. That means that
 888 compiling with this backend will not help improve the runtime
 889 execution speed of your program but may improve the start-up time.
 890 Depending on the environment in which your program runs this may
 891 or may not be a help.
 892
 893 The resulting bytecode can be run with a special byteperl executable
 894 or (for non-main programs) be loaded via the C<byteload_fh> function
 895 in the F<B> module.
 896
 897 =head1 OPTIONS
 898
 899 If there are any non-option arguments, they are taken to be names of
 900 objects to be saved (probably doesn't work properly yet).  Without
 901 extra arguments, it saves the main program.
 902
 903 =over 4
 904
 905 =item B<-ofilename>
 906
 907 Output to filename instead of STDOUT.
 908
 909 =item B<-afilename>
 910
 911 Append output to filename.
 912
 913 =item B<-->
 914
 915 Force end of options.
 916
 917 =item B<-f>
 918
 919 Force optimisations on or off one at a time. Each can be preceded
 920 by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
 921
 922 =item B<-fcompress-nullops>
 923
 924 Only fills in the necessary fields of ops which have
 925 been optimised away by perl's internal compiler.
 926
 927 =item B<-fomit-sequence-numbers>
 928
 929 Leaves out code to fill in the op_seq field of all ops
 930 which is only used by perl's internal compiler.
 931
 932 =item B<-fbypass-nullops>
 933
 934 If op->op_next ever points to a NULLOP, replaces the op_next field
 935 with the first non-NULLOP in the path of execution.
 936
 937 =item B<-On>
 938
 939 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
 940 B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
 941 B<-O2> adds B<-fbypass-nullops>.
 942
 943 =item B<-D>
 944
 945 Debug options (concatenated or separate flags like C<perl -D>).
 946
 947 =item B<-Do>
 948
 949 Prints each OP as it's processed.
 950
 951 =item B<-Db>
 952
 953 Print debugging information about bytecompiler progress.
 954
 955 =item B<-Da>
 956
 957 Tells the (bytecode) assembler to include source assembler lines
 958 in its output as bytecode comments.
 959
 960 =item B<-DC>
 961
 962 Prints each CV taken from the final symbol tree walk.
 963
 964 =item B<-S>
 965
 966 Output (bytecode) assembler source rather than piping it
 967 through the assembler and outputting bytecode.
 968
 969 =item B<-upackage>
 970
 971 Stores package in the output.
 972
 973 =back
 974
 975 =head1 EXAMPLES
 976
 977     perl -MO=Bytecode,-O6,-ofoo.plc,-umain foo.pl
 978
 979     perl -MO=Bytecode,-S,-umain foo.pl > foo.S
 980     assemble foo.S > foo.plc
 981
 982 Note that C<assemble> lives in the C<B> subdirectory of your perl
 983 library directory. The utility called perlcc may also be used to
 984 help make use of this compiler.
 985
 986     perl -MO=Bytecode,-uFoo,-oFoo.pmc Foo.pm
 987
 988 =head1 BUGS
 989
 990 Output is still huge and there are still occasional crashes during
 991 either compilation or ByteLoading. Current status: experimental.
 992
 993 =head1 AUTHORS
 994
 995 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 996 Benjamin Stuhl, C<sho_pi@hotmail.com>
 997
 998 =cut