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