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\nxcv_outside_seq 0x%x",
 656         $cv->DEPTH, $cv->CvFLAGS, $cv->OUTSIDE_SEQ;
 657     asmf "xcv_file %d\n", $fileix;
 658     # Now save all the subfields (except for CvROOT which was handled
 659     # above) and CvSTART (now the initial element of @subfields).
 660     shift @subfields; # bye-bye CvSTART
 661     my $sv;
 662     foreach $sv (@subfields) {
 663         $sv->bytecode;
 664     }
 665 }
 666
 667 sub B::IO::bytecode {
 668     my $io = shift;
 669     return if saved($io);
 670     my $ix = $io->objix;
 671     my $top_gv = $io->TOP_GV;
 672     my $top_gvix = $top_gv->objix;
 673     my $fmt_gv = $io->FMT_GV;
 674     my $fmt_gvix = $fmt_gv->objix;
 675     my $bottom_gv = $io->BOTTOM_GV;
 676     my $bottom_gvix = $bottom_gv->objix;
 677
 678     $io->B::PVMG::bytecode;
 679     ldsv($ix);
 680     asm "xio_top_gv $top_gvix\n";
 681     asm "xio_fmt_gv $fmt_gvix\n";
 682     asm "xio_bottom_gv $bottom_gvix\n";
 683     my $field;
 684     foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
 685         asmf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
 686     }
 687     foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
 688         asmf "xio_%s %d\n", lc($field), $io->$field();
 689     }
 690     asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
 691     $top_gv->bytecode;
 692     $fmt_gv->bytecode;
 693     $bottom_gv->bytecode;
 694 }
 695
 696 sub B::SPECIAL::bytecode {
 697     # nothing extra needs doing
 698 }
 699
 700 sub bytecompile_object {
 701     for my $sv (@_) {
 702         svref_2object($sv)->bytecode;
 703     }
 704 }
 705
 706 sub B::GV::bytecodecv {
 707     my $gv = shift;
 708     my $cv = $gv->CV;
 709     if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_CV)) {
 710         if ($debug_cv) {
 711             warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
 712                          $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
 713         }
 714         $gv->bytecode;
 715     }
 716 }
 717
 718 sub save_call_queues {
 719     if (begin_av()->isa("B::AV")) {     # this is just to save 'use Foo;' calls
 720         for my $cv (begin_av()->ARRAY) {
 721             next unless grep { $_ eq $cv->STASH->NAME; } @packages;
 722             my $op = $cv->START;
 723 OPLOOP:
 724             while ($$op) {
 725                 if ($op->name eq 'require') { # save any BEGIN that does a require
 726                     $cv->bytecode;
 727                     asmf "push_begin %d\n", $cv->objix;
 728                     last OPLOOP;
 729                 }
 730                 $op = $op->next;
 731             }
 732         }
 733     }
 734     if (init_av()->isa("B::AV")) {
 735         for my $cv (init_av()->ARRAY) {
 736             next unless grep { $_ eq $cv->STASH->NAME; } @packages;
 737             $cv->bytecode;
 738             asmf "push_init %d\n", $cv->objix;
 739         }
 740     }
 741     if (end_av()->isa("B::AV")) {
 742         for my $cv (end_av()->ARRAY) {
 743             next unless grep { $_ eq $cv->STASH->NAME; } @packages;
 744             $cv->bytecode;
 745             asmf "push_end %d\n", $cv->objix;
 746         }
 747     }
 748 }
 749
 750 sub symwalk {
 751     no strict 'refs';
 752     my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages;
 753     if (grep { /^$_[0]/; } @packages) {
 754         walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]);
 755     }
 756     warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n")
 757         if $debug_bc;
 758     $ok;
 759 }
 760
 761 sub bytecompile_main {
 762     my $curpad = (comppadlist->ARRAY)[1];
 763     my $curpadix = $curpad->objix;
 764     $curpad->bytecode;
 765     save_call_queues();
 766     walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL";
 767     warn "done main program, now walking symbol table\n" if $debug_bc;
 768     if (@packages) {
 769         no strict qw(refs);
 770         walksymtable(\%{"main::"}, "bytecodecv", \&symwalk);
 771     } else {
 772         die "No packages requested for compilation!\n";
 773     }
 774     asmf "main_root %d\n", main_root->objix;
 775     asmf "main_start %d\n", main_start->objix;
 776     asmf "curpad $curpadix\n";
 777     # XXX Do min_intro_pending and max_intro_pending matter?
 778 }
 779
 780 sub compile {
 781     my @options = @_;
 782     my ($option, $opt, $arg);
 783     open(OUT, ">&STDOUT");
 784     binmode OUT;
 785     select OUT;
 786   OPTION:
 787     while ($option = shift @options) {
 788         if ($option =~ /^-(.)(.*)/) {
 789             $opt = $1;
 790             $arg = $2;
 791         } else {
 792             unshift @options, $option;
 793             last OPTION;
 794         }
 795         if ($opt eq "-" && $arg eq "-") {
 796             shift @options;
 797             last OPTION;
 798         } elsif ($opt eq "o") {
 799             $arg ||= shift @options;
 800             open(OUT, ">$arg") or return "$arg: $!\n";
 801             binmode OUT;
 802         } elsif ($opt eq "a") {
 803             $arg ||= shift @options;
 804             open(OUT, ">>$arg") or return "$arg: $!\n";
 805             binmode OUT;
 806         } elsif ($opt eq "D") {
 807             $arg ||= shift @options;
 808             foreach $arg (split(//, $arg)) {
 809                 if ($arg eq "b") {
 810                     $| = 1;
 811                     debug(1);
 812                 } elsif ($arg eq "o") {
 813                     B->debug(1);
 814                 } elsif ($arg eq "a") {
 815                     B::Assembler::debug(1);
 816                 } elsif ($arg eq "C") {
 817                     $debug_cv = 1;
 818                 }
 819             }
 820         } elsif ($opt eq "v") {
 821             $verbose = 1;
 822         } elsif ($opt eq "S") {
 823             $no_assemble = 1;
 824         } elsif ($opt eq "f") {
 825             $arg ||= shift @options;
 826             my $value = $arg !~ s/^no-//;
 827             $arg =~ s/-/_/g;
 828             my $ref = $optimise{$arg};
 829             if (defined($ref)) {
 830                 $$ref = $value;
 831             } else {
 832                 warn qq(ignoring unknown optimisation option "$arg"\n);
 833             }
 834         } elsif ($opt eq "O") {
 835             $arg = 1 if $arg eq "";
 836             my $ref;
 837             foreach $ref (values %optimise) {
 838                 $$ref = 0;
 839             }
 840             if ($arg >= 2) {
 841                 $bypass_nullops = 1;
 842             }
 843             if ($arg >= 1) {
 844                 $compress_nullops = 1;
 845                 $omit_seq = 1;
 846             }
 847         } elsif ($opt eq "u") {
 848             $arg ||= shift @options;
 849             push @packages, $arg;
 850         } else {
 851             warn qq(ignoring unknown option "$opt$arg"\n);
 852         }
 853     }
 854     if (! @packages) {
 855         warn "No package specified for compilation, assuming main::\n";
 856         @packages = qw(main);
 857     }
 858     if (@options) {
 859         die "Extraneous options left on B::Bytecode commandline: @options\n";
 860     } else {
 861         return sub {
 862             newasm(\&apr) unless $no_assemble;
 863             bytecompile_main();
 864             endasm() unless $no_assemble;
 865         };
 866     }
 867 }
 868
 869 sub apr { print @_; }
 870
 871 1;
 872
 873 __END__
 874
 875 =head1 NAME
 876
 877 B::Bytecode - Perl compiler's bytecode backend
 878
 879 =head1 SYNOPSIS
 880
 881         perl -MO=Bytecode[,OPTIONS] foo.pl
 882
 883 =head1 DESCRIPTION
 884
 885 This compiler backend takes Perl source and generates a
 886 platform-independent bytecode encapsulating code to load the
 887 internal structures perl uses to run your program. When the
 888 generated bytecode is loaded in, your program is ready to run,
 889 reducing the time which perl would have taken to load and parse
 890 your program into its internal semi-compiled form. That means that
 891 compiling with this backend will not help improve the runtime
 892 execution speed of your program but may improve the start-up time.
 893 Depending on the environment in which your program runs this may
 894 or may not be a help.
 895
 896 The resulting bytecode can be run with a special byteperl executable
 897 or (for non-main programs) be loaded via the C<byteload_fh> function
 898 in the F<B> module.
 899
 900 =head1 OPTIONS
 901
 902 If there are any non-option arguments, they are taken to be names of
 903 objects to be saved (probably doesn't work properly yet).  Without
 904 extra arguments, it saves the main program.
 905
 906 =over 4
 907
 908 =item B<-ofilename>
 909
 910 Output to filename instead of STDOUT.
 911
 912 =item B<-afilename>
 913
 914 Append output to filename.
 915
 916 =item B<-->
 917
 918 Force end of options.
 919
 920 =item B<-f>
 921
 922 Force optimisations on or off one at a time. Each can be preceded
 923 by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
 924
 925 =item B<-fcompress-nullops>
 926
 927 Only fills in the necessary fields of ops which have
 928 been optimised away by perl's internal compiler.
 929
 930 =item B<-fomit-sequence-numbers>
 931
 932 Leaves out code to fill in the op_seq field of all ops
 933 which is only used by perl's internal compiler.
 934
 935 =item B<-fbypass-nullops>
 936
 937 If op->op_next ever points to a NULLOP, replaces the op_next field
 938 with the first non-NULLOP in the path of execution.
 939
 940 =item B<-On>
 941
 942 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
 943 B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
 944 B<-O2> adds B<-fbypass-nullops>.
 945
 946 =item B<-D>
 947
 948 Debug options (concatenated or separate flags like C<perl -D>).
 949
 950 =item B<-Do>
 951
 952 Prints each OP as it's processed.
 953
 954 =item B<-Db>
 955
 956 Print debugging information about bytecompiler progress.
 957
 958 =item B<-Da>
 959
 960 Tells the (bytecode) assembler to include source assembler lines
 961 in its output as bytecode comments.
 962
 963 =item B<-DC>
 964
 965 Prints each CV taken from the final symbol tree walk.
 966
 967 =item B<-S>
 968
 969 Output (bytecode) assembler source rather than piping it
 970 through the assembler and outputting bytecode.
 971
 972 =item B<-upackage>
 973
 974 Stores package in the output.
 975
 976 =back
 977
 978 =head1 EXAMPLES
 979
 980     perl -MO=Bytecode,-O6,-ofoo.plc,-umain foo.pl
 981
 982     perl -MO=Bytecode,-S,-umain foo.pl > foo.S
 983     assemble foo.S > foo.plc
 984
 985 Note that C<assemble> lives in the C<B> subdirectory of your perl
 986 library directory. The utility called perlcc may also be used to
 987 help make use of this compiler.
 988
 989     perl -MO=Bytecode,-uFoo,-oFoo.pmc Foo.pm
 990
 991 =head1 BUGS
 992
 993 Output is still huge and there are still occasional crashes during
 994 either compilation or ByteLoading. Current status: experimental.
 995
 996 =head1 AUTHORS
 997
 998 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 999 Benjamin Stuhl, C<sho_pi@hotmail.com>
1000
1001 =cut