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